RFC: porting SLOF's fdt.fs to OpenBIOS - OpenBIOS

19 Jul 2019

Hello,
This is an attempt to port ftd.fs for FDT unflattening from SLOF to 
OpenBIOS. This compiles but I have not tried to feed it any fdt yet 
because I'm sure it won't work yet as some words are wrong. The words I 
had to implement for it (marked with a FIXME comment) should be reviewed 
and checked if they could work and the set-unit word is still missing so 
that needs to be implemented. Also 64bit stuff and claim usage should be 
clarified. Those words that are copied and do work may have better 
alternatives that I haven't found so could be replaced. Anyway this is a 
start to try to get this done. Once it works it will expect an FDT in 
memory at address fdt-start then the fdt-doit word at the end is an 
example of how to unflatten that into an OF device-tree (at least that's 
what SLOF does if I got that right).
Any insight or comments on this are welcome.
Regards,
BALATON Zoltan

diff --git a/forth/util/build.xml b/forth/util/build.xml
index 4839d2c..25e02db 100644
--- a/forth/util/build.xml
+++ b/forth/util/build.xml
@@ -11,6 +11,7 @@
  <dictionary name="openbios" target="forth">
   <object source="util.fs"/>
   <object source="pci.fs"/>
+  <object source="fdt.fs"/>
   <!-- We don't want/need these at the moment
   <object source="apic.fs"/>
   -->
diff --git a/forth/util/fdt.fs b/forth/util/fdt.fs
new file mode 100644
index 0000000..af29bba
--- /dev/null
+++ b/forth/util/fdt.fs
@@ -0,0 +1,586 @@
+\ *****************************************************************************
+\ * Copyright (c) 2011 IBM Corporation
+\ * All rights reserved.
+\ * This program and the accompanying materials
+\ * are made available under the terms of the BSD License
+\ * which accompanies this distribution, and is available at
+\ * http://www.opensource.org/licenses/bsd-license.php
+\ *
+\ * Contributors:
+\ *     IBM Corporation - initial implementation
+\ ****************************************************************************/
+\ Changes for OpenBIOS: BALATON Zoltan, 2019
+
+1 VALUE fdt-debug
+TRUE VALUE fdt-cas-fix?
+0 VALUE fdt-start
+
+struct
+  4 field >fdth_magic
+  4 field >fdth_tsize
+  4 field >fdth_struct_off
+  4 field >fdth_string_off
+  4 field >fdth_rsvmap_off
+  4 field >fdth_version
+  4 field >fdth_compat_vers
+  4 field >fdth_boot_cpu
+  4 field >fdth_string_size
+  4 field >fdth_struct_size
+constant /fdth
+
+h# d00dfeed constant OF_DT_HEADER
+h#        1 constant OF_DT_BEGIN_NODE
+h#        2 constant OF_DT_END_NODE
+h#        3 constant OF_DT_PROP
+h#        4 constant OF_DT_NOP
+h#        9 constant OF_DT_END
+
+\ Create some variables early
+0 value fdt-start-addr
+0 value fdt-struct
+0 value fdt-strings
+
+
+\ FIXME: review the following words which were added for OpenBIOS
+\ some of these copied verbatim from SLOF others try to implement
+\ alternatives
+\
+\ definitely wrong/missing: set-unit and claim disabled further below
+\
+\ may be wrong: find-node, and other related node words and 64bit stuff
+\ (SLOF seems to always be in 64bit mode and not sure if that's needed
+\ to parse FDT or could it be changed for 32bit as OpenBIOS does not
+\ define some words in 32bit mode.)
+
+: get-node ?active-package ;
+: set-node active-package! ;
+: node>path " ?" ; \ only used for debugging and errors
+: get-parent get-node parent ;
+: my-#address-cells my-#acells ;
+: get-property get-package-property ;
+: find-node ( path len -- phandle|0 )
+  find-dev 0= if \ find-dev returns ( phandle true | false )
+    0
+  then
+;
+
+\ : set-space get-node dup >r node>space ! true r> node>space? ! ;
+\ : set-address
+\   my-#address-cells 1 ?DO
+\   get-node node>space i cells + ! LOOP
+\ ;
+: set-unit 3drop ; \ set-space set-address ;
+
+: str= ( str1 len1 str2 len2 -- equal? )
+  rot over <> IF 3drop false ELSE comp 0= THEN ;
+
+: from-cstring ( addr - len )
+  dup dup BEGIN c@ 0 <> WHILE 1 + dup REPEAT
+  swap -
+;
+
+: test-string ( param len -- true | false )
+  0 ?DO
+    dup i + c@                     \ Get character / byte at current index
+    dup 20 <  swap 7e >  OR IF     \ Is it out of range 32 to 126 (=ASCII)
+      drop FALSE UNLOOP EXIT       \ FALSE means: No ASCII string
+    THEN
+  LOOP
+  drop TRUE    \ Only ASCII found --> it is a string
+;
+
+: find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
+  \ if substr-len == 0 ?
+  dup 0 = IF
+    \ return 0
+    2drop 2drop 0 exit THEN
+  \ if substr-len <= basestr-len ?
+  dup 3 pick <= IF
+    \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
+    2 pick over - 1+ 0 DO dup 0 DO
+      \ substr-ptr[i] == basestr-ptr[j+i] ?
+      over i + c@ 4 pick j + i + c@ = IF
+        \ (I+1) == substr-len ?
+        dup i 1+ = IF
+          \ return J
+          2drop 2drop j unloop unloop exit THEN
+      ELSE leave THEN
+    LOOP LOOP
+  THEN
+  \ if there is no match then exit with basestr-len as return value
+  2drop nip
+;
+
+CREATE $catpad 400 allot
+: $cat ( str1 len1 str2 len2 -- str3 len3 )
+   >r >r dup >r $catpad swap move
+   r> dup $catpad + r> swap r@ move
+   r> + $catpad swap ;
+
+: split ( str len char -- left len right len )
+  >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
+: generic-decode-unit ( str len ncells -- addr.lo ... addr.hi )
+  dup >r -rot BEGIN r@ WHILE r> 1- >r [char] , split 2swap
+  $number IF 0 THEN r> swap >r >r REPEAT r> 3drop
+  BEGIN dup WHILE 1- r> swap REPEAT drop ;
+: generic-encode-unit ( addr.lo ... addr.hi ncells -- str len )
+  0 0 rot ?dup IF 0 ?DO rot (u.) $cat s" ," $cat LOOP 1- THEN ;
+: hex-decode-unit ( str len ncells -- addr.lo ... addr.hi )
+  base @ >r hex generic-decode-unit r> base ! ;
+: hex-encode-unit ( addr.lo ... addr.hi ncells -- str len )
+  base @ >r hex generic-encode-unit r> base ! ;
+
+64bit? [IF]
+: hex64-decode-unit ( str len ncells -- addr.lo ... addr.hi )
+  dup 2 <> IF
+    hex-decode-unit
+  ELSE
+    drop
+    base @ >r hex
+    $number IF 0 0 ELSE xlsplit THEN
+    r> base !
+  THEN
+;
+: hex64-encode-unit ( addr.lo ... addr.hi ncells -- str len )
+  dup 2 <> IF
+     hex-encode-unit
+  ELSE
+     drop
+     base @ >r hex
+     lxjoin (u.)
+     r> base !
+  THEN
+;
+[ELSE]
+: hex64-decode-unit hex-decode-unit ;
+: hex64-encode-unit hex-encode-unit ;
+: x@ l@ ;
+: xlsplit ( o -- quad.lo quad.hi )
+  dup h# ffffffff and swap d# 32 rshift
+  ;
+[THEN]
+
+\ functions to review end here, also see fdt-claim-reserve below
+
+
+: fdt-init ( fdt-start -- )
+    dup to fdt-start-addr
+    dup dup >fdth_struct_off l@ + to fdt-struct
+    dup dup >fdth_string_off l@ + to fdt-strings
+    drop
+;
+
+\ Dump fdt header for all to see and check FDT validity
+: fdt-check-header ( -- )
+    fdt-start-addr dup 0 = IF
+        ." No flat device tree !" cr drop -1 throw EXIT THEN
+    hex
+    fdt-debug IF
+        ." Flat device tree header at 0x" dup . s" :" type cr
+        ."  magic            : 0x" dup >fdth_magic l@ . cr
+        ."  total size       : 0x" dup >fdth_tsize l@ . cr
+        ."  offset to struct : 0x" dup >fdth_struct_off l@ . cr
+        ."  offset to strings: 0x" dup >fdth_string_off l@ . cr
+        ."  offset to rsvmap : 0x" dup >fdth_rsvmap_off l@ . cr
+        ."  version          : " dup >fdth_version l@ decimal . hex cr
+        ."  last compat vers : " dup >fdth_compat_vers l@ decimal . hex cr
+        dup >fdth_version l@ 2 >= IF
+            ."  boot CPU         : 0x" dup >fdth_boot_cpu l@ . cr
+        THEN
+        dup >fdth_version l@ 3 >= IF
+            ."  strings size     : 0x" dup >fdth_string_size l@ . cr
+        THEN
+        dup >fdth_version l@ 11 >= IF
+            ."  struct size      : 0x" dup >fdth_struct_size l@ . cr
+        THEN
+    THEN
+    dup >fdth_magic l@ OF_DT_HEADER <> IF
+        ." Flat device tree has incorrect magic value !" cr
+	drop -1 throw EXIT
+    THEN
+    dup >fdth_version l@ 10 < IF
+        ." Flat device tree has usupported version !" cr
+	drop -1 throw EXIT
+    THEN
+
+    drop
+;
+
+\ Fetch next tag, skip nops and increment address
+: fdt-next-tag ( addr -- nextaddr tag )
+  0	       	      	 	( dummy tag on stack for loop )
+  BEGIN
+    drop			( drop previous tag )
+    dup l@			( read new tag )
+    swap 4 + swap		( increment addr )
+  dup OF_DT_NOP <> UNTIL 	( loop until not nop )
+;
+
+\ Parse unit name and advance addr
+: fdt-fetch-unit ( addr -- addr $name )
+  dup from-cstring	       \  get string size
+  2dup + 1 + 3 + fffffffc and -rot
+;
+
+\ Update unit with information from the reg property...
+\ ... this is required for the PCI nodes for example.
+: fdt-reg-unit ( prop-addr prop-len -- )
+      decode-phys               ( prop-addr' prop-len' phys.lo ... phys.hi )
+      set-unit                  ( prop-addr' prop-len' )
+      2drop
+;
+
+\ Lookup a string by index
+: fdt-fetch-string ( index -- str-addr str-len )
+  fdt-strings + dup from-cstring
+;
+
+: fdt-create-dec  s" decode-unit" $CREATE , DOES> @ hex64-decode-unit ;
+: fdt-create-enc  s" encode-unit" $CREATE , DOES> @ hex64-encode-unit ;
+
+\ Check whether array contains an zero-terminated ASCII string:
+: fdt-prop-is-string?  ( addr len -- string? )
+   dup 1 < IF 2drop FALSE EXIT THEN                \ Check for valid length
+   1-
+   2dup + c@ 0<> IF 2drop FALSE EXIT THEN          \ Check zero-termination
+   test-string
+;
+
+\ Encode fdt property to OF property
+: fdt-encode-prop  ( addr len -- )
+   2dup fdt-prop-is-string? IF
+      1- encode-string
+   ELSE
+      encode-bytes
+   THEN
+;
+
+\ Method to unflatten a node
+: fdt-unflatten-node ( start -- end )
+  \ this can and will recurse
+  recursive
+
+  \ Get & check first tag of node ( addr -- addr)
+  fdt-next-tag dup OF_DT_BEGIN_NODE <> IF
+    s" Weird tag 0x" type . " at start of node" type cr
+    -1 throw
+  THEN drop
+
+  new-device
+
+  \ Parse name, split unit address
+  fdt-fetch-unit
+  dup 0 = IF drop drop " /" THEN
+  40 left-parse-string
+  \ Set name
+  device-name
+
+  \ Set preliminary unit address - might get overwritten by reg property
+  dup IF
+     " #address-cells" get-parent get-package-property IF
+        2drop
+     ELSE
+        decode-int nip nip
+	hex-decode-unit
+	set-unit
+     THEN
+  ELSE 2drop THEN
+
+  \ Iterate sub tags
+  BEGIN
+    fdt-next-tag dup OF_DT_END_NODE <>
+  WHILE
+    dup OF_DT_PROP = IF
+      \ Found property
+      drop dup			( drop tag, dup addr     : a1 a1 )
+      dup l@ dup rot 4 +	( fetch size, stack is   : a1 s s a2)
+      dup l@ swap 4 +		( fetch nameid, stack is : a1 s s i a3 )
+      rot			( we now have: a1 s i a3 s )
+      fdt-encode-prop rot	( a1 s pa ps i)
+      fdt-fetch-string		( a1 s pa ps na ns )
+      2dup s" reg" str= IF
+          2swap 2dup fdt-reg-unit 2swap
+      THEN
+      property
+      + 8 + 3 + fffffffc and
+    ELSE dup OF_DT_BEGIN_NODE = IF
+      drop			( drop tag )
+      4 -
+      fdt-unflatten-node
+    ELSE
+      drop -1 throw
+    THEN THEN
+  REPEAT drop \ drop tag
+
+  \ Create encode/decode unit
+  " #address-cells" get-node get-package-property IF ELSE
+    decode-int dup fdt-create-dec fdt-create-enc 2drop
+  THEN
+
+  finish-device
+;
+
+\ Start unflattening
+: fdt-unflatten-tree
+    fdt-debug IF
+        ." Unflattening device tree..." cr THEN
+    fdt-struct fdt-unflatten-node drop
+    fdt-debug IF
+        ." Done !" cr THEN
+;
+
+\ Find memory size
+: fdt-parse-memory
+    \ XXX FIXME Handle more than one memory node, and deal
+    \     with RMA vs. full access
+    " /memory@0" find-device
+    " reg" get-node get-package-property IF throw -1 THEN
+
+    \ XXX FIXME Assume one entry only in "reg" property for now
+    decode-phys 2drop decode-phys
+    my-#address-cells 1 > IF 20 << or THEN
+
+    fdt-debug IF
+        dup ." Memory size: " . cr
+    THEN
+    \ claim.fs already released the memory between 0 and MIN-RAM-SIZE,
+    \ so we've got only to release the remaining memory now:
+\    MIN-RAM-SIZE swap MIN-RAM-SIZE - release
+    2drop device-end
+;
+
+\ FIXME: Find out if this is needed and what should it do
+: claim 3drop ;
+
+\ Claim fdt memory and reserve map
+: fdt-claim-reserve
+    fdt-start-addr
+    dup dup >fdth_tsize l@ 0 claim drop
+    dup >fdth_rsvmap_off l@ +
+    BEGIN
+        dup dup x@ swap 8 + x@
+	dup 0 <>
+    WHILE
+	fdt-debug IF
+	    2dup swap ." Reserve map entry: " . ." : " . cr
+	THEN
+	0 claim drop
+	10 +
+    REPEAT drop drop drop
+;
+
+\ The following functions are use to replace the FDT phandle and
+\ linux,phandle properties with our own OF1275 phandles...
+
+\ This is used to check whether we successfully replaced a phandle value
+0 VALUE (fdt-phandle-replaced)
+
+\ Replace phandle value in "interrupt-map" property
+: fdt-replace-interrupt-map  ( old new prop-addr prop-len -- old new )
+   BEGIN
+      dup                    ( old new prop-addr prop-len prop-len )
+   WHILE
+      \ This is a little bit ugly ... we're accessing the property at
+      \ hard-coded offsets instead of analyzing it completely...
+      swap dup 10 +          ( old new prop-len prop-addr prop-addr+10 )
+      dup l@ 5 pick = IF
+          \ it matches the old phandle value!
+          3 pick swap l!
+          TRUE TO (fdt-phandle-replaced)
+      ELSE
+          drop
+      THEN
+      ( old new prop-len prop-addr )
+      1c + swap 1c -
+      ( old new new-prop-addr new-prop-len )
+   REPEAT
+   2drop
+;
+
+: (fdt-replace-phandles) ( old new propname propnamelen node -- )
+    get-property IF 2drop EXIT THEN
+    BEGIN
+        dup
+    WHILE                   ( old new prop-addr prop-len )
+        over l@
+        4 pick = IF
+            2 pick 2 pick l! \ replace old with new in place
+            TRUE TO (fdt-phandle-replaced)
+        THEN
+        4 - swap 4 + swap
+    REPEAT
+    2drop 2drop
+;
+
+\ Replace one phandle "old" with a phandle "new" in "node" and recursively
+\ in its child nodes:
+: fdt-replace-all-phandles ( old new node -- )
+   \ ." Replacing in " dup node>path type cr
+   >r
+   s" interrupt-map" r@ get-property 0= IF
+      ( old new prop-addr prop-len  R: node )
+      fdt-replace-interrupt-map
+   THEN
+
+   2dup s" interrupt-parent" r@ (fdt-replace-phandles)
+   2dup s" ibm,gpu" r@ (fdt-replace-phandles)
+   2dup s" ibm,npu" r@ (fdt-replace-phandles)
+   2dup s" ibm,nvlink" r@ (fdt-replace-phandles)
+   2dup s" memory-region" r@ (fdt-replace-phandles)
+
+   \ ... add more properties that have to be fixed here ...
+   r>
+   \ Now recurse over all child nodes:       ( old new node )
+   child BEGIN
+      dup
+   WHILE
+      3dup RECURSE
+      PEER
+   REPEAT
+   3drop
+;
+
+\ Replace one FDT phandle "val" with a OF1275 phandle "node" in the
+\ whole tree:
+: fdt-update-phandle ( val node -- )
+   >r
+   FALSE TO (fdt-phandle-replaced)
+   r@ s" /" find-node               ( val node root )
+   fdt-replace-all-phandles
+   (fdt-phandle-replaced) IF
+      r@ set-node
+      s" phandle" delete-property
+      s" linux,phandle" delete-property
+   ELSE
+      diagnostic-mode? IF
+         cr ." Warning: Did not replace phandle in " r@ node>path type cr
+      THEN
+   THEN
+r> drop
+;
+
+\ Check whether a node has "phandle" or "linux,phandle" properties
+\ and replace them:
+: fdt-fix-node-phandle  ( node -- )
+   >r
+   s" phandle" r@ get-property 0= IF
+      decode-int nip nip
+      \ ." found phandle: " dup . cr
+      r@ fdt-update-phandle
+   THEN
+   r> drop
+;
+
+\ Recursively walk through all nodes to fix their phandles:
+: fdt-fix-phandles  ( node -- )
+   \ ." fixing phandles of " dup node>path type cr
+   dup fdt-fix-node-phandle
+   child BEGIN
+      dup
+   WHILE
+      dup RECURSE
+      PEER
+   REPEAT
+   drop
+   device-end
+;
+
+: fdt-create-cas-node ( name  -- )
+    2dup
+    2dup " memory@" find-substr 0 = IF
+	fdt-debug IF ." Creating memory@ " cr THEN
+	new-device
+	2dup " @" find-substr nip device-name       \ Parse the node name
+	2dup
+	2dup " @" find-substr rot over + 1 + -rot - 1 - \ Jump to addr afte "@"
+	parse-2int nip xlsplit set-unit                 \ Parse and set unit
+	finish-device
+    ELSE
+	2dup " ibm,dynamic-reconfiguration-memory" find-substr 0 = IF
+	    fdt-debug IF  ." Creating ibm,dynamic-reconfiguration-memory " cr THEN
+	    new-device
+	    device-name
+	    finish-device
+	ELSE
+	    2drop 2drop
+	    false to fdt-cas-fix?
+	    ." Node not supported " cr
+	    EXIT
+	THEN
+    THEN
+
+    find-node ?dup 0 <> IF set-node THEN
+;
+
+: fdt-fix-cas-node ( start -- end )
+    recursive
+    fdt-next-tag dup OF_DT_BEGIN_NODE <> IF
+	." Error " cr
+	false to fdt-cas-fix?
+	EXIT
+    THEN drop
+    fdt-fetch-unit
+    dup 0 = IF drop drop " /" THEN
+    40 left-parse-string
+    2swap ?dup 0 <> IF
+	nip
+	1 + + \ Add the string len +@
+    ELSE
+	drop
+    THEN
+    fdt-debug IF ." Setting node: " 2dup type cr THEN
+    2dup find-node ?dup 0 <> IF
+	set-node 2drop
+    ELSE
+	fdt-debug IF ." Node not found, creating " 2dup type cr THEN
+	fdt-create-cas-node
+    THEN
+    fdt-debug IF ." Current  now: " pwd cr THEN
+    BEGIN
+	fdt-next-tag dup OF_DT_END_NODE <>
+    WHILE
+	dup OF_DT_PROP = IF
+	    fdt-debug IF ." Found property " cr THEN
+	    drop dup		( drop tag, dup addr     : a1 a1 )
+	    dup l@ dup rot 4 +	( fetch size, stack is   : a1 s s a2)
+	    dup l@ swap 4 +	( fetch nameid, stack is : a1 s s i a3 )
+	    rot			( we now have: a1 s i a3 s )
+	    fdt-encode-prop rot	( a1 s pa ps i)
+	    fdt-fetch-string		( a1 s pa ps na ns )
+	    property
+	    fdt-debug IF ." Setting property done " cr THEN
+	    + 8 + 3 + fffffffc and
+	ELSE dup OF_DT_BEGIN_NODE = IF
+		drop			( drop tag )
+		4 -
+		fdt-fix-cas-node
+		get-parent set-node
+		fdt-debug IF ." Returning back " pwd cr THEN
+	    ELSE
+		." Error " cr
+		drop
+		false to fdt-cas-fix?
+		EXIT
+	    THEN
+	THEN
+    REPEAT
+    drop \ drop tag
+;
+
+: fdt-fix-cas-success
+    fdt-cas-fix?
+;
+
+: fdt-doit
+    \ Bail out if no fdt
+    fdt-start 0 = IF
+        ." No fdt-start" cr
+        -1 throw
+    THEN
+    fdt-start fdt-init
+    fdt-check-header
+    fdt-unflatten-tree
+    fdt-parse-memory
+    fdt-claim-reserve
+    s" /" find-node fdt-fix-phandles
+;

    