\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: devtree.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)devtree.fth 3.23 06/02/16 19:19:51
copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
: get ( acf -- value ) 0 perform-action ;
: set ( value acf -- ) 1 perform-action ;
: decode ( value acf -- adr len ) 3 perform-action ;
: encode ( adr len acf -- true | value false )
4 ['] perform-action catch if
\ Don't use the system search order; use a private stack
\ $find searches through the private stack
\ Change names back from "regprop" to "reg", etc.
\ Either implement a true breadth-first search or don't specify it.
action: drop context token@ ;
action: drop context token! definitions ;
create current-device use-actions
: >node-offset ( apf -- addr ) @ current-device >body >user + ;
: (ufield) \ name ( offset size -- offset' )
: ufield \ name ( offset size -- offset' )
action: >node-offset token@ execute ;
action: >node-offset token! ;
: node-defer \ name ( offset -- offset' )
/token (ufield) use-actions
\ Notes for a more abstract searching mechanism:
\ Instead of the child and peer links in the device node, packages
\ with children have "search", "create", and "enumerate" methods.
\ To search a level, call that package's search method. Those
\ methods probably need to work from a phandle, not an ihandle.
\ The 'check-user-size' below enables user space to grow on demand.
: unaligned-ualloc ( size -- user# )
check-user-size #user @ swap #user +! ( user# )
/link #threads * ufield 'threads \ Package methods
dup \ These fields will be "ualloc"ed
/token ufield 'child \ Pointer to first child
/token ufield 'peer \ Pointer to next peer
/token ufield 'properties \ Pointer to properties vocabulary
/n ufield '#adr-cells \ Size of a parent address
/n ufield support-node? \ is this a support node?
/n ufield inherit-node-flags? \ inherit parent props?
node-defer (encode-unit) \ encode-unit method
node-defer (decode-unit) \ decode-unit method
( starting-offset ending-offset ) swap - ( size-to-ualloc )
: >parent ( node -- parent-node ) >voc-link link@ ;
: push-package ( phandle -- ) also execute definitions ;
: pop-package ( -- ) previous definitions ;
: push-device ( acf -- ) to current-device ;
current-device >parent ( parent-voc )
non-null? if push-device then
\ Each package instance has its own private data storage area.
\ The data creation words "value", "variable", and "buffer:",
\ when used during compilation of a package, allocate memory
\ relative to a base pointer. The package definition includes the
\ initial values for the words created with "value" and "variable".
\ When a package instance is created, memory is allocated for the
\ package's data and the portion used for values and variables is
\ initialized from the values stored in the package definition.
\ While the package is being defined (i.e. its code is being compiled),
\ a "dummy" instance is created with space for data, so that
\ data words may be used as soon as they are created. The "dummy"
\ instance data area is given a "generous" default size (for 100 * cellsize
\ bytes of initialized data, 700 * cellsize for buffers).
\ Hopefully this won't be exceeded.
variable package-level package-level off
variable next-is-instance next-is-instance off
variable instance-mode instance-mode off
\ \ Debugging code. Keep this in until we have "sanitized" the drivers.
\ package-level @ 0<> next-is-instance @ 0= and instance-mode @ and if
\ ." Instance problem " where ??cr
package-level @ 0<> next-is-instance @ instance-mode @ or and
: instance ( -- ) next-is-instance on ;
\ Now in machine code in obp/os/bootprom/sparc/instance.fth
\ : >instance-data ( pfa -- adr ) @ my-self + ;
: value#, ( size -- adr )
'#values @ dup , ( size offset )
tuck + '#values ! ( offset )
overload: value \ name ( initial-value -- )
header noop \ Will patch with (value)
action: >instance-data @ ;
action: >instance-data ! ;
: (value) ( initial-value -- )
create-cf use-actions /n value#,
; patch (value) noop value
\ Create fields which are present in every instance record.
: fibuf: \ name ( offset -- offset' )
create -1 na+ dup , ( offset' )
: fival: \ name ( offset -- offset' )
create dup , na1+ ( offset' )
overload: buffer: \ name ( size -- )
header noop \ Will patch with (buffer:)
action: >instance-data ! ;
overload: (buffer:) ( #bytes -- )
\ The address computation should use "#dalign round-up", but
\ #dalign (8) is defined later, in the "allocator" vocabulary.
'#buffers @ swap 8 round-up - dup , '#buffers ! use-actions
; patch (buffer:) noop buffer:
overload: variable \ name ( -- )
header noop \ Will patch with (variable)
action: >instance-data ! ;
create-cf use-actions 0 /n value#, else user-cf 0 /n user#,
; patch (variable) noop variable
overload: defer \ name ( -- )
header noop \ Will patch with (defer)
action: >instance-data token@ execute ;
action: >instance-data token! ;
action: >instance-data token@ ;
create-cf ['] crash /token ( value data-size )
defer-cf ['] crash /token ( value data-size )
; patch (defer) noop defer
\ Instance values that are automatically created for every package instance.
fival: my-adr0 \ F: First component of device probe address
fival: my-adr1 \ F: Intermediate component of device probe address
fival: my-adr2 \ F: Intermediate component of device probe address
fival: my-space \ F: Last component of device probe address
fival: frame-buffer-adr \ F: Frame buffer address. Strictly speaking, this
\ should not be in every package, but we put it
\ here as a work-around for some old CG6 FCode
\ drivers whose selftest routines use frame-buffer-adr
\ for diagnostics mappings. If frame-buffer-adr is
\ global, that would cause dual-cg6 systems to break.
fival: interposed? \ Was this instance interposed?
fibuf: my-voc \ Package definition (code) for this instance
fibuf: my-parent \ Current instance just before this one was created
fibuf: my-args-adr \ Argument string - base address
fibuf: my-args-len \ Argument string - length
fibuf: my-unit-3 \ Fourth component of device instance address
fibuf: my-unit-2 \ Third component of device instance address
fibuf: my-unit-1 \ Second component of device instance address
fibuf: my-unit-low \ First component of device instance address
: my-args ( -- adr len ) my-args-adr my-args-len ;
: allocate-instance ( value-size variable-size -- )
\ Allocate instance record
my-self >r ( val-size var-size )
tuck + alloc-mem ( var-size base-adr )
current-device to my-voc ( )
0 to my-args-len 0 to my-args-adr ( ) \ May be changed later
0 to my-unit-low 0 to my-unit-1 ( )
0 to my-unit-2 0 to my-unit-3 ( )
: initial-values ( -- adr ) 'values token@ ;
\ Returns the address of the initial value of the named instance data.
: (initial-addr) ( adr -- adr' ) my-self - initial-values + ;
: initial-addr \ name ( -- addr )
state @ if compile (initial-addr) else (initial-addr) then
: copy-args ( args-adr,len -- )
dup alloc-mem to my-args-adr ( args-adr,len )
to my-args-len ( args-adr )
my-args-adr my-args-len move ( )
\ my-self points to a position in the middle of the instance record.
\ Initialized data ("values") is at positive offsets from my-self,
\ and uninitialized data ("variables" and "buffers") is at negative offsets.
: new-instance ( args-adr args-len -- )
'#values @ '#buffers @ negate allocate-instance
\ Copy in the initialized data
initial-values my-self '#values @ move ( args-adr args-len )
: deallocate-instance ( value-size variabled-size -- )
my-args-len if my-args-adr my-args-len free-mem then
my-self my-parent is my-self ( val-size var-size self )
over - ( val-size var-size base-adr )
\ Destroy instance has the side effect of setting my-self to the parent
\ of the node that is being destroyed. This prevents my-self from referring
\ to a non-existent instance.
: destroy-instance ( -- )
'#values @ '#buffers @ negate ( value-size variable-size )
previous ( value-size variable-size )
\ When creating a package definition, we initialize the buffer
\ (unitialized data) allocation pointer and the value (initialized data)
\ Size of the buffer that is used as the instance data when the package
\ is being created. This allows variables, buffers, and values to be
\ used while the package is being created.
: initial-sizes ( -- value-size variable-size )
1 package-level +! initial-sizes allocate-instance
: allot-package-data ( -- )
acf-align here dup 'values token! '#values @ dup allot erase
: finish-package-data ( -- )
\ Copy the initialized data into the dictionary and set up the
'#values @ if allot-package-data then
my-self initial-values '#values @ move ( )
initial-addr frame-buffer-adr off
initial-addr my-termemu off
initial-sizes deallocate-instance ( )
package-level @ 1- 0 max package-level !
\ Internal factor used to implement first-child and next-child
: set-child? ( link-adr -- flag )
get-token? if push-device true else false then
\ Interface to searching code in breadth.fth:
: first-child ( -- another? ) 'child set-child? ;
: next-child ( -- another? ) 'peer pop-device set-child? ;
\ Removes the voc-link field from the most-recently-created vocabulary
voc-link link@ >voc-link link@ voc-link link!
\ Creates an unnamed vocabulary
: allocate-node-record ( -- )
\ Allocate user (RAM) space for properties, "last" field, children, peers
/devnode-extra unaligned-ualloc drop
lastacf push-device ( parent's-child-field )
: init-properties ( -- ) (vocabulary) lastacf 'properties token! ;
\ this was moved from finddev because the encode/decode unit recovery
\ mechanism needs it, and in order to only complain once about missing
\ methods and to accelerate the device tree parsing these were moved here.
variable saved-method-package
defer no-proc ' true is no-proc \ definition requires forward references..
: setup-method$ ( adr len phandle -- adr len phandle )
>r r@ saved-method-package ! ( adr len )
2dup saved-method$ 2! ( adr len )
: current-properties ( -- ) 'properties token@ ;
: $vexecute? ( adr len voc-acf -- true | ??? false)
(search-wordlist) if execute false else true then
: $vexecute ( adr len voc-acf -- ?? ) $vexecute? drop ;
\ Used during compilation (probing), when the search order includes
\ the current vocabulary as well as the parent vocabularies.
: get-property ( name-adr,len -- true | value-adr,len false )
current-properties $vexecute?
" #address-cells" get-property if 2 else get-encoded-int then
\ this routine will only execute once per node, unless the device tree
\ changes (via cd, device-end or finish-device) it looks up the static
\ acf for the encode/decode method substituting the default 2cell form
\ and complaining once, if the method does not exist.
: (lookup-method) ( ? ? def-acf ptr method$ -- ? ? )
current-device setup-method$ (search-wordlist) if ( ? ? def-acf ptr acf )
>r ( ? ? default-acf ptr )
else ( ? ? default-acf ptr )
2 #adr-cells tuck ( ? ? ptr -2 n 2 n )
<> swap 0<> and if throw else drop then ( ? ? ptr )
diagnostic-mode? if ( ? ? ptr )
??cr ." Notice: " abort-message type cr
r> tuck swap ( ? ? acf acf ptr )
\ Moved from findev.fth because the device tree depends upon
\ encode-unit and decode-unit, and because some cards are missing those
\ methods and we have to workaround them this becomes a fundamental part
\ of the device tree operation now.
create bad-number ," Bad number syntax"
: safe->number ( adr len -- n ) $hnumber if bad-number throw then ;
: parse-int ( adr len -- n ) dup if safe->number else 2drop 0 then ;
: parse-2int ( adr len -- address space )
ascii , left-parse-string ( after-str before-str )
parse-int >r ( after-str )
parse-int r> ( address space )
: (encode-2ints) ( l h -- adr,len ) swap <# u#s drop ascii , hold u#s u#> ;
: lookup-decode-unit ( unit$ -- pa.lo .. pa.hi )
['] parse-2int ['] (decode-unit) " decode-unit" (lookup-method)
: lookup-encode-unit ( pa.lo .. pa.hi -- unit$ )
['] (encode-2ints) ['] (encode-unit) " encode-unit" (lookup-method)
\ reset the current device cached encode/decode methods
['] lookup-decode-unit is (decode-unit)
['] lookup-encode-unit is (encode-unit)
: init-node ( #address-cells -- )
'child !null-token \ No children yet
'peer !null-token \ Null peer
#fixed-vals '#values ! \ Initialize data sizes
'values !null-token \ No initial data values yet
0 support-node? ! \ Not a support node by default
true inherit-node-flags? ! \ inherit by default
: link-to-peer ( parent's-child-field -- )
dup token@ 'peer token! ( parent's-child-field )
current-device swap token! ( )
: device-node? ( voc -- flag )
voc-link begin another-link? while ( voc link )
2dup voc> = if 2drop false exit then ( voc link )
(vocabulary) current-device link, ( ) \ Up-link to parent device
\ Save parent linkage address on stack for later use
inherit-node-flags? @ ( in? )
support-node? @ over and ( in? support? )
'child ( in? support? parent's-child-field )
#adr-cells init-node ( in? support? parent's-child-field )
link-to-peer ( in? support? )
inherit-node-flags? ! ( )
: new-device ( -- ) new-node extend-package ;
\ The false will be patched later with device-context?
false if reset-xxcoders then
only forth also definitions package-level off
my-self if \ Use current instance's package if there is a current instance
my-voc also execute '#adr-cells @ previous
else \ Otherwise use the active package
\ my-address applies to the current instance, regardless of whether or
\ not the active package corresponds to the current instance, thus it must
\ use my-#adr-cells, which explicitly refers to the current instance's
: my-address ( -- phys.lo .. )
addr my-adr0 my-#adr-cells 1- 1 max /n* bounds ?do i @ /n +loop
: my-unit ( -- phys.lo .. )
addr my-unit-low my-#adr-cells /n* bounds ?do i @ /n +loop
erase-voc-link null link, \ Root has no parent
: root-device ( -- ) only forth also ['] root-node push-device ;
: finish-device ( -- ) reset-xxcoders finish-package-data pop-device ;
\ The magic-device-types vocabulary contains words whose names are the
\ same as the names of the device_type property values that we wish to
\ recognize as special cases. "device_type" in the "magic-properties"
\ vocabulary searches this vocabulary every time that a "device_type"
\ property is created, and executes the corresponding word if a match
\ is found. That word may look at the property name and value on the
\ stack, but it must not remove them. However, it might wish to alter
vocabulary magic-device-types
\ The magic-properties vocabulary contains words whose names are the
\ same as the names of properties that we wish to recognize as special
\ cases. "property" searches this vocabulary every time that an
\ property is created, and executes the corresponding word if a match
\ is found. That word may look at the property name and value on the
\ stack, but it must not remove them. However, it might wish to alter
\ either the name or the value!
vocabulary magic-properties
also magic-properties definitions
: device_type ( value-str name-str -- value-str name-str )
2over get-encoded-string ['] magic-device-types $vexecute
\ The parameter field of a property word contains:
\ Offset is the 32-bit positive distance from the beginning of the
\ property-encoded byte array to the parameter field address. size is the
\ 16-bit size of the property value array. This representation depends on
\ the fact that property-encoded arrays are stored in the dictionary.
: make-property-name ( name-adr,len -- )
current token@ >r current-properties current token!
action: dup dup unaligned-l@ l->n - swap la1+ w@ ;
action: ( adr,len apf -- )
dup rot - swap unaligned-l! ( )
: (property) ( value-adr,len name-adr,len -- )
2dup ['] magic-properties $vexecute ( value-str name-str )
2dup current-properties (search-wordlist) if ( value-str name-str acf )
else ( value-str name-str )
make-property-name ( value-str )
here rot - l, w, align use-actions ( )
: property ( value-adr,len name-adr,len -- )
context token@ >r my-voc execute
: delete-property ( name-adr,len -- )
current-properties (search-wordlist) if
>link current-properties remove-word
overload: forget \ name ( -- )
current token@ device-node? abort" Can't forget device methods"
: get-unit ( -- true | adr len false ) " reg" get-property ;
: unit-str>phys- ( adr len -- phys.hi .. phys.lo )
'#adr-cells @ 0 ?do decode-int -rot loop 2drop ( phys.hi .. phys.lo )
: reorder ( xn .. x1 n -- x1 .. xn ) 0 ?do i roll loop ;
: unit-str>phys ( adr len -- phys.lo .. phys.hi )
unit-str>phys- ( phys.hi .. phys.lo )
'#adr-cells @ reorder ( phys.lo .. phys.hi )
projects / OpenSPARC-T2-SAM / blob