![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to devices.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / admin|
Return to devices.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / admin |
1.1 root 1: \ tag: device tree administration
2: \
3: \ this code implements IEEE 1275-1994
4: \
5: \ Copyright (C) 2003 Samuel Rydh
6: \ Copyright (C) 2003-2006 Stefan Reinauer
7: \
8: \ See the file "COPYING" for further information about
9: \ the copyright and warranty status of this work.
10: \
11:
12:
13: \ 7.4.11.1 Device alias
14:
15: : devalias ( "{alias-name}< >{device-specifier}<cr>" -- )
16: ;
17:
18: : nvalias ( "alias-name< >device-specifier<cr>" -- )
19: ;
20:
21: : $nvalias ( name-str name-len dev-str dev-len -- )
22: ;
23:
24: : nvunalias ( "alias-name< >" -- )
25: ;
26:
27: : $nvunalias ( name-str name-len -- )
28: ;
29:
30:
31: \ 7.4.11.2 Device tree browsing
32:
33: : dev ( "<spaces>device-specifier" -- )
34: bl parse
35: find-device
36: ;
37:
38: : cd
39: dev
40: ;
41:
42: \ find-device ( dev-str dev-len -- )
43: \ implemented in pathres.fs
44:
45: : device-end ( -- )
46: 0 active-package!
47: ;
48:
49: \ Open selected device node and make it the current instance
50: \ section H.8 errata: pre OpenFirmware, but Sun OBP compatible
51: : select-dev ( -- )
52: open-dev dup 0= abort" failed opening parent."
53: dup to my-self
54: ihandle>phandle active-package!
55: ;
56:
57: \ Close current node, deselect active package and current instance,
58: \ leaving no instance selected
59: \ section H.8 errata: pre OpenFirmware, but Sun OBP compatible
60: : unselect-dev ( -- )
61: my-self close-dev
62: device-end
63: 0 to my-self
64: ;
65:
66: : begin-package ( arg-str arg-len reg-str reg-len dev-str dev-len -- )
67: select-dev
68: new-device
69: set-args
70: ;
71:
72: : end-package ( -- )
73: finish-device
74: unselect-dev
75: ;
76:
77: : ?active-package ( -- phandle )
78: active-package dup 0= abort" no active device"
79: ;
80:
81: \ -------------------------------------------------------
82: \ path handling
83: \ -------------------------------------------------------
84:
85: \ used if parent lacks an encode-unit method
86: : def-encode-unit ( unitaddr ... )
87: pocket tohexstr
88: ;
89:
90: : get-encode-unit-xt ( phandle.parent -- xt )
91: >dn.parent @
92: " encode-unit" rot find-method
93: 0= if ['] def-encode-unit then
94: ;
95:
96: : get-nodename ( phandle -- str len )
97: " name" rot get-package-property if " <noname>" else 1- then
98: ;
99:
100: \ helper, return the node name in the format 'cpus@addr'
101: : pnodename ( phandle -- str len )
102: dup get-nodename rot
103: dup " reg" rot get-package-property if drop exit then rot
104:
105: \ set active-package and clear my-self (decode-phys needs this)
106: my-self >r 0 to my-self
107: active-package >r
108: dup active-package!
109:
110: ( name len prop len phandle )
111: get-encode-unit-xt
112:
113: ( name len prop len xt )
114: depth >r >r
115: decode-phys r> execute
116: r> -rot >r >r depth! 3drop
117:
118: ( name len R: len str )
119: r> r> " @"
120: here 20 + \ abuse dictionary for temporary storage
121: tmpstrcat >r
122: 2swap r> tmpstrcat drop
123: pocket tmpstrcpy drop
124:
125: r> active-package!
126: r> to my-self
127: ;
128:
129: : inodename ( ihandle -- str len )
130: my-self over to my-self >r
131: ihandle>phandle get-nodename
132:
133: \ nonzero unit number?
134: false >r
135: depth >r my-unit r> 1+
136: begin depth over > while
137: swap 0<> if r> drop true >r then
138: repeat
139: drop
140:
141: \ if not... check for presence of "reg" property
142: r> ?dup 0= if
143: " reg" my-self ihandle>phandle get-package-property
144: if false else 2drop true then
145: then
146:
147: ( name len print-unit-flag )
148: if
149: my-self ihandle>phandle get-encode-unit-xt
150:
151: ( name len xt )
152: depth >r >r
153: my-unit r> execute
154: r> -rot >r >r depth! drop
155: r> r>
156: ( name len str len )
157: here 20 + tmpstrcpy
158: " @" rot tmpstrcat drop
159: 2swap pocket tmpstrcat drop
160: then
161:
162: \ add :arguments
163: my-args dup if
164: " :" pocket tmpstrcat drop
165: 2swap pocket tmpstrcat drop
166: else
167: 2drop
168: then
169:
170: r> to my-self
171: ;
172:
173: \ helper, also used by client interface (package-to-path)
174: : get-package-path ( phandle -- str len )
175: ?dup 0= if 0 0 then
176:
177: dup >dn.parent @ 0= if drop " /" exit then
178: \ dictionary abused for temporary storage
179: >r 0 0 here 40 +
180: begin r> dup >dn.parent @ dup >r while
181: ( path len tempbuf phandle R: phandle.parent )
182: pnodename rot tmpstrcat
183: " /" rot tmpstrcat
184: repeat
185: r> 3drop
186: pocket tmpstrcpy drop
187: ;
188:
189: \ used by client interface (instance-to-path)
190: : get-instance-path ( ihandle -- str len )
191: ?dup 0= if 0 0 then
192:
193: dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
194:
195: \ dictionary abused for temporary storage
196: >r 0 0 here 40 +
197: begin r> dup >in.my-parent @ dup >r while
198: ( path len tempbuf ihandle R: ihandle.parent )
199: dup >in.interposed @ 0= if
200: inodename rot tmpstrcat
201: " /" rot tmpstrcat
202: else
203: drop
204: then
205: repeat
206: r> 3drop
207: pocket tmpstrcpy drop
208: ;
209:
210: \ used by client interface (instance-to-interposed-path)
211: : get-instance-interposed-path ( ihandle -- str len )
212: ?dup 0= if 0 0 then
213:
214: dup ihandle>phandle >dn.parent @ 0= if drop " /" exit then
215:
216: \ dictionary abused for temporary storage
217: >r 0 0 here 40 +
218: begin r> dup >in.my-parent @ dup >r while
219: ( path len tempbuf ihandle R: ihandle.parent )
220: dup >r inodename rot tmpstrcat
221: r> >in.interposed @ if " /%" else " /" then
222: rot tmpstrcat
223: repeat
224: r> 3drop
225: pocket tmpstrcpy drop
226: ;
227:
228: : pwd ( -- )
229: ?active-package get-package-path type
230: ;
231:
232: : ls ( -- )
233: cr
234: ?active-package >dn.child @
235: begin dup while
236: dup u. dup pnodename type cr
237: >dn.peer @
238: repeat
239: drop
240: ;
241:
242:
243: \ -------------------------------------------
244: \ property printing
245: \ -------------------------------------------
246:
247: : .p-string? ( data len -- true | data len false )
248: \ no trailing zero?
249: 2dup + 1- c@ if 0 exit then
250:
251: swap >r 0
252: \ count zeros and detect unprintable characters?
253: over 1- begin 1- dup 0>= while
254: dup r@ + c@
255: ( len zerocnt n ch )
256:
257: ?dup 0= if
258: swap 1+ swap
259: else
260: dup 1b <= swap 80 >= or
261: if 2drop r> swap 0 exit then
262: then
263: repeat drop r> -rot
264: ( data len zerocnt )
265:
266: \ simple string
267: 0= if
268: ascii " emit 1- type ascii " emit true exit
269: then
270:
271: \ make sure there are no double zeros (except possibly at the end)
272: 2dup over + swap
273: ( data len end ptr )
274: begin 2dup <> while
275: dup c@ 0= if
276: 2dup 1+ <> if 2drop false exit then
277: then
278: dup cstrlen 1+ +
279: repeat
280: 2drop
281:
282: ." {"
283: 0 -rot over + swap
284: \ multistring ( cnt end ptr )
285: begin 2dup <> while
286: rot dup if ." , " then 1+ -rot
287: dup cstrlen 2dup
288: ascii " emit type ascii " emit
289: 1+ +
290: repeat
291: ." }"
292: 3drop true
293: ;
294:
295: : .p-int? ( data len -- 1 | data len 0 )
296: dup 4 <> if false exit then
297: decode-int -rot 2drop true swap
298: dup 0>= if . exit then
299: dup -ff < if u. exit then
300: .
301: ;
302:
303: \ Print a number zero-padded
304: : 0.r ( u minlen -- )
305: 0 swap <# 1 ?do # loop #s #> type
306: ;
307:
308: : .p-bytes? ( data len -- 1 | data len 0 )
309: ." -- " dup . ." : "
310: swap >r 0
311: begin 2dup > while
312: dup r@ + c@
313: ( len n ch )
314:
315: 2 0.r space
316: 1+
317: repeat
318: 2drop r> drop 1
319: ;
320:
321: \ this function tries to heuristically determine the data format
322: : (.property) ( data len -- )
323: dup 0= if 2drop ." <empty>" exit then
324:
325: .p-string? if exit then
326: .p-int? if exit then
327: .p-bytes? if exit then
328: 2drop ." <unimplemented type>"
329: ;
330:
331: \ Print the value of a property in "reg" format
332: : .p-reg ( #acells #scells data len -- )
333: 2dup + -rot ( #acells #scells data+len data len )
334: >r >r -rot ( data+len #acells #scells R: len data )
335: 4 * swap 4 * dup r> r> ( data+len #sbytes #abytes #abytes data len )
336: bounds ( data+len #sbytes #abytes #abytes data+len data ) ?do
337: dup 0= if 2 spaces then \ start of "size" part
338: 2dup <> if \ non-first byte in row
339: dup 3 and 0= if space then \ make numbers more readable
340: then
341: i c@ 2 0.r \ print byte
342: 1- 3dup nip + 0= if \ end of row
343: 3 pick i 1+ > if \ non-last byte
344: cr \ start new line
345: d# 26 spaces \ indentation
346: then
347: drop dup \ update counter
348: then
349: loop
350: 3drop drop
351: ;
352:
353: \ Return the number of cells per physical address
354: : .p-translations-#pacells ( -- #cells )
355: " /" find-package if
356: " #address-cells" rot get-package-property if
357: 1
358: else
359: decode-int nip nip 1 max
360: then
361: else
362: 1
363: then
364: ;
365:
366: \ Return the number of cells per translation entry
367: : .p-translations-#cells ( -- #cells )
368: [IFDEF] CONFIG_PPC
369: my-#acells 3 *
370: .p-translations-#pacells +
371: [ELSE]
372: my-#acells 3 *
373: [THEN]
374: ;
375:
376: \ Set up column offsets
377: : .p-translations-cols ( -- col1 ... coln #cols )
378: .p-translations-#cells 4 *
379: [IFDEF] CONFIG_PPC
380: 4 -
381: dup 4 -
382: dup .p-translations-#pacells 4 * -
383: 3
384: [ELSE]
385: my-#acells 4 * -
386: dup my-#scells 4 * -
387: 2
388: [THEN]
389: ;
390:
391: \ Print the value of the MMU translations property
392: : .p-translations ( data len -- )
393: >r >r .p-translations-cols r> r> ( col1 ... coln #cols data len )
394: 2dup + -rot ( col1 ... coln #cols data+len data len )
395: >r >r .p-translations-#cells 4 * dup r> r>
396: ( col1 ... coln #cols data+len #bytes #bytes len data )
397: bounds ( col1 ... coln #cols data+len #bytes #bytes data+len data ) ?do
398: 3 pick 4 + 4 ?do \ check all defined columns
399: i pick over = if
400: 2 spaces \ start new column
401: then
402: loop
403: 2dup <> if \ non-first byte in row
404: dup 3 and 0= if space then \ make numbers more readable
405: then
406: i c@ 2 0.r \ print byte
407: 1- dup 0= if \ end of row
408: 2 pick i 1+ > if \ non-last byte
409: cr \ start new line
410: d# 26 spaces \ indentation
411: then
412: drop dup \ update counter
413: then
414: loop
415: 2drop drop 0 ?do drop loop
416: ;
417:
418: \ This function hardwires data formats to particular node properties
419: : (.property-by-name) ( name-str name-len data len -- )
420: 2over " reg" strcmp 0= if
421: my-#acells my-#scells 2swap .p-reg
422: 2drop exit
423: then
424:
425: active-package get-nodename " memory" strcmp 0= if
426: 2over " available" strcmp 0= if
427: my-#acells my-#scells 2swap .p-reg
428: 2drop exit
429: then
430: then
431: " /chosen" find-dev if
432: " mmu" rot get-package-property 0= if
433: decode-int nip nip ihandle>phandle active-package = if
434: 2over " available" strcmp 0= if
435: my-#acells my-#scells 1 max 2swap .p-reg
436: 2drop exit
437: then
438: 2over " translations" strcmp 0= if
439: .p-translations
440: 2drop exit
441: then
442: then
443: then
444: then
445:
446: 2swap 2drop ( data len )
447: (.property)
448: ;
449:
450: : .properties ( -- )
451: ?active-package dup >r if
452: 0 0
453: begin
454: r@ next-property
455: while
456: cr 2dup dup -rot type
457: begin ." " 1+ dup d# 26 >= until drop
458: 2dup
459: 2dup active-package get-package-property drop
460: ( name-str name-len data len )
461: (.property-by-name)
462: repeat
463: then
464: r> drop
465: cr
466: ;
467:
468:
469: \ 7.4.11 Device tree
470:
471: : print-dev ( phandle -- phandle )
472: dup u.
473: dup get-package-path type
474: dup " device_type" rot get-package-property if
475: cr
476: else
477: ." (" decode-string type ." )" cr 2drop
478: then
479: ;
480:
481: : show-sub-devs ( subtree-phandle -- )
482: print-dev
483: >dn.child @
484: begin dup while
485: dup recurse
486: >dn.peer @
487: repeat
488: drop
489: ;
490:
491: : show-all-devs ( -- )
492: active-package
493: cr " /" find-device
494: ?active-package show-sub-devs
495: active-package!
496: ;
497:
498:
499: : show-devs ( "{device-specifier}<cr>" -- )
500: active-package
501: cr " /" find-device
502: linefeed parse find-device
503: ?active-package show-sub-devs
504: active-package!
505: ;
506:
507:
508:
509: \ 7.4.11.3 Device probing
510:
511: : probe-all ( -- )
512: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.