diff options
Diffstat (limited to 'qemu/roms/SLOF/slof/fs/fcode')
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/1275.fs | 465 | ||||
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/core.fs | 173 | ||||
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/evaluator.fs | 119 | ||||
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/little-big.fs | 96 | ||||
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/locals.fs | 155 | ||||
| -rw-r--r-- | qemu/roms/SLOF/slof/fs/fcode/tokens.fs | 480 |
6 files changed, 1488 insertions, 0 deletions
diff --git a/qemu/roms/SLOF/slof/fs/fcode/1275.fs b/qemu/roms/SLOF/slof/fs/fcode/1275.fs new file mode 100644 index 000000000..c2a67bcc9 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/1275.fs @@ -0,0 +1,465 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 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 +\ ****************************************************************************/ + + +: fcode-revision ( -- n ) + 00030000 \ major * 65536 + minor + ; + +: b(lit) ( -- n ) + next-ip read-fcode-num32 + ?compile-mode IF literal, THEN + ; + +: b(") + next-ip read-fcode-string + ?compile-mode IF fc-string, align postpone count THEN + ; + +: b(') + next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN + ; + +: ?jump-direction ( n -- ) + dup 8000 >= IF + 10000 - \ Create cell-sized negative value + THEN + fcode-offset - \ IP is already behind offset, so subtract offset size +; + +: ?negative + 8000 and + ; + +: dest-on-top + 0 >r BEGIN dup @ 0= WHILE >r REPEAT + BEGIN r> dup WHILE swap REPEAT + drop + ; + +: read-fcode-offset + next-ip + ?offset16 IF + read-fcode-num16 + ELSE + read-byte + dup 80 and IF FF00 or THEN \ Fake 16-bit signed offset + THEN +; + +: b?branch ( flag -- ) + ?compile-mode IF + read-fcode-offset ?negative IF + dest-on-top postpone until + ELSE + postpone if + THEN + ELSE + ( flag ) IF + fcode-offset jump-n-ip \ Skip over offset value + ELSE + read-fcode-offset + ?jump-direction jump-n-ip + THEN + THEN +; immediate + +: bbranch ( -- ) + ?compile-mode IF + read-fcode-offset + ?negative IF + dest-on-top postpone again + ELSE + postpone else + get-ip next-ip fcode@ B2 = IF + drop + ELSE + set-ip + THEN + THEN + ELSE + read-fcode-offset ?jump-direction jump-n-ip + THEN +; immediate + +: b(<mark) ( -- ) + ?compile-mode IF postpone begin THEN + ; immediate + +: b(>resolve) ( -- ) + ?compile-mode IF postpone then THEN + ; immediate + +: b(;) + <semicolon> compile, reveal + postpone [ +; immediate + +: b(:) ( -- ) + <colon> compile, ] + ; immediate + +: b(case) ( sel -- sel ) + postpone case + ; immediate + +: b(endcase) + postpone endcase + ; immediate + +: b(of) + postpone of + read-fcode-offset drop \ read and discard offset + ; immediate + +: b(endof) + postpone endof + read-fcode-offset drop + ; immediate + +: b(do) + postpone do + read-fcode-offset drop + ; immediate + +: b(?do) + postpone ?do + read-fcode-offset drop + ; immediate + +: b(loop) + postpone loop + read-fcode-offset drop + ; immediate + +: b(+loop) + postpone +loop + read-fcode-offset drop + ; immediate + +: b(leave) + postpone leave + ; immediate + + +0 VALUE fc-instance? +: fc-instance ( -- ) \ Mark next defining word as instance-specific. + TRUE TO fc-instance? +; + +: new-token \ unnamed local fcode function + align here next-ip read-fcode# 0 swap set-token + ; + +: external-token ( -- ) \ named local fcode function + next-ip read-fcode-string + \ fc-instance? IF cr ." ext instance token: " 2dup type ." in " pwd cr THEN + header ( str len -- ) \ create a header in the current dictionary entry + new-token + ; + +: new-token + eva-debug? IF + s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup + header + THEN + new-token +; + +\ decide wether or not to give a new token an own name in the dictionary +: named-token + fcode-debug? IF + external-token + ELSE + next-ip read-fcode-string 2drop \ Forget about the name + new-token + THEN +; + +: b(to) ( val -- ) + next-ip read-fcode# + get-token drop ( val xt ) + dup @ ( val xt @xt ) + dup <value> = over <defer> = OR IF + \ Destination is value or defer + drop + >body cell - + ( val addr ) + ?compile-mode IF + literal, postpone ! + ELSE + ! + THEN + ELSE + <create> <> IF ( val xt ) + TRUE ABORT" Invalid destination for FCODE b(to)" + THEN + dup cell+ @ ( val xt @xt+1cell ) + dup <instancevalue> <> swap <instancedefer> <> AND IF + TRUE ABORT" Invalid destination for FCODE b(to)" + THEN + \ Destination is instance-value or instance-defer + >body @ ( val instance-offset ) + ?compile-mode IF + literal, postpone >instance postpone ! + ELSE + >instance ! + THEN + ELSE + THEN +; immediate + +: b(value) + fc-instance? IF + <create> , \ Needed for "(instance?)" for example + <instancevalue> , + (create-instance-var) + FALSE TO fc-instance? + ELSE + <value> , , + THEN + reveal +; + +: b(variable) + fc-instance? IF + <create> , \ Needed for "(instance?)" + <instancevariable> , + 0 (create-instance-var) + FALSE TO fc-instance? + ELSE + <variable> , 0 , + THEN + reveal +; + +: b(constant) + <constant> , , reveal + ; + +: undefined-defer + cr cr ." Uninitialized defer word has been executed!" cr cr + true fcode-end ! + ; + +: b(defer) + fc-instance? IF + <create> , \ Needed for "(instance?)" + <instancedefer> , + ['] undefined-defer (create-instance-var) + reveal + FALSE TO fc-instance? + ELSE + <defer> , reveal + postpone undefined-defer + THEN +; + +: b(create) + <variable> , + postpone noop reveal + ; + +: b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size ) + <colon> , over literal, + postpone + + <semicolon> compile, + reveal + + +; + +: b(buffer:) ( E: -- a-addr) ( F: size -- ) + fc-instance? IF + <create> , \ Needed for "(instance?)" + <instancebuffer> , + (create-instance-buf) + FALSE TO fc-instance? + ELSE + <buffer:> , allot + THEN + reveal +; + +: suspend-fcode ( -- ) + noop \ has to be implemented more efficiently ;-) + ; + +: offset16 ( -- ) + 2 to fcode-offset + ; + +: version1 ( -- ) + 1 to fcode-spread + 1 to fcode-offset + read-header + ; + +: start0 ( -- ) + 0 to fcode-spread + offset16 + read-header + ; + +: start1 ( -- ) + 1 to fcode-spread + offset16 + read-header + ; + +: start2 ( -- ) + 2 to fcode-spread + offset16 + read-header + ; + +: start4 ( -- ) + 4 to fcode-spread + offset16 + read-header + ; + +: end0 ( -- ) + true fcode-end ! + ; + +: end1 ( -- ) + end0 + ; + +: ferror ( -- ) + clear end0 + cr ." FCode# " fcode-num @ . ." not assigned!" + cr ." FCode evaluation aborted." cr + ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr + abort + ; + +: reset-local-fcodes + FFF 800 DO ['] ferror 0 i set-token LOOP + ; + +: byte-load ( addr xt -- ) + >r >r + save-evaluator-state + r> r> + reset-fcode-end + 1 to fcode-spread + dup 1 = IF drop ['] rb@ THEN to fcode-rb@ + set-ip + reset-local-fcodes + depth >r + evaluate-fcode + r> depth 1- <> IF + clear end0 + cr ." Ambiguous stack depth after byte-load!" + cr ." FCode evaluation aborted." cr cr + ELSE + restore-evaluator-state + THEN + ['] c@ to fcode-rb@ +; + +\ Functions for accessing memory ... since some FCODE programs use the normal +\ memory access functions for accessing MMIO memory, too, we got to use a little +\ hack to support them: When address is bigger than MIN-RAM-SIZE, assume the +\ FCODE is trying to access MMIO memory and use the register based access +\ functions instead! +: fc-c@ ( addr -- byte ) dup MIN-RAM-SIZE > IF rb@ ELSE c@ THEN ; +: fc-w@ ( addr -- word ) dup MIN-RAM-SIZE > IF rw@ ELSE w@ THEN ; +: fc-<w@ ( addr -- word ) fc-w@ dup 8000 >= IF 10000 - THEN ; +: fc-l@ ( addr -- long ) dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ; +: fc-<l@ ( addr -- long ) fc-l@ signed ; +: fc-x@ ( addr -- dlong ) dup MIN-RAM-SIZE > IF rx@ ELSE x@ THEN ; +: fc-c! ( byte addr -- ) dup MIN-RAM-SIZE > IF rb! ELSE c! THEN ; +: fc-w! ( word addr -- ) dup MIN-RAM-SIZE > IF rw! ELSE w! THEN ; +: fc-l! ( long addr -- ) dup MIN-RAM-SIZE > IF rl! ELSE l! THEN ; +: fc-x! ( dlong addr -- ) dup MIN-RAM-SIZE > IF rx! ELSE x! THEN ; + +: fc-fill ( add len byte -- ) 2 pick MIN-RAM-SIZE > IF rfill ELSE fill THEN ; +: fc-move ( src dst len -- ) + 2 pick MIN-RAM-SIZE > \ Check src + 2 pick MIN-RAM-SIZE > \ Check dst + OR IF rmove ELSE move THEN +; + +\ Destroy virtual mapping (should maybe also update "address" property here?) +: free-virtual ( virt size -- ) + s" map-out" $call-parent +; + +\ Map the specified region, return virtual address +: map-low ( phys.lo ... size -- virt ) + my-space swap s" map-in" $call-parent +; + +\ Get MAC address +: mac-address ( -- mac-str mac-len ) + s" local-mac-address" get-my-property IF + 0 0 + THEN +; + +\ Output line and column number - not used yet +VARIABLE #line +0 #line ! +VARIABLE #out +0 #out ! + +\ Display device status +: display-status ( n -- ) + ." Device status: " . cr +; + +\ Obsolete variables: +VARIABLE group-code +0 group-code ! + +\ Obsolete: Allocate memory for DMA +: dma-alloc ( byte -- virtual ) + s" dma-alloc" $call-parent +; + +\ Obsolete: Get params property +: my-params ( -- addr len ) + s" params" get-my-property IF + 0 0 + THEN +; + +\ Obsolete: Convert SBus interrupt level to CPU interrupt level +: sbus-intr>cpu ( sbus-intr# -- cpu-intr# ) +; + +\ Obsolete: Set "intr" property +: intr ( interrupt# vector -- ) + >r sbus-intr>cpu encode-int r> encode-int+ s" intr" property +; + +\ Obsolete: Create the "name" property +: driver ( addr len -- ) + encode-string s" name" property +; + +\ Obsolete: Return type of CPU +: processor-type ( -- cpu-type ) + 0 +; + +\ Obsolete: Return firmware version +: firmware-version ( -- n ) + 10000 \ Just a dummy value +; + +\ Obsolete: Return fcode-version +: fcode-version ( -- n ) + fcode-revision +; diff --git a/qemu/roms/SLOF/slof/fs/fcode/core.fs b/qemu/roms/SLOF/slof/fs/fcode/core.fs new file mode 100644 index 000000000..8fd98ec19 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/core.fs @@ -0,0 +1,173 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 2008 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 +\ ****************************************************************************/ + +: ?offset16 ( -- true|false ) + fcode-offset 2 = + ; + +: ?arch64 ( -- true|false ) + cell 8 = + ; + +: ?bigendian ( -- true|false ) + deadbeef fcode-num ! + fcode-num ?arch64 IF 4 + THEN + c@ de = + ; + +: reset-fcode-end ( -- ) + false fcode-end ! + ; + +: get-ip ( -- n ) + ip @ + ; + +: set-ip ( n -- ) + ip ! + ; + +: next-ip ( -- ) + get-ip 1+ set-ip + ; + +: jump-n-ip ( n -- ) + get-ip + set-ip + ; + +: read-byte ( -- n ) + get-ip fcode-rb@ + ; + +: ?compile-mode ( -- on|off ) + state @ + ; + +: save-evaluator-state + get-ip eva-debug? IF ." saved ip " dup . cr THEN + fcode-end @ eva-debug? IF ." saved fcode-end " dup . cr THEN + fcode-offset eva-debug? IF ." saved fcode-offset " dup . cr THEN +\ local fcodes are currently NOT saved! + fcode-spread eva-debug? IF ." saved fcode-spread " dup . cr THEN + ['] fcode@ behavior eva-debug? IF ." saved fcode@ " dup . cr THEN + ; + +: restore-evaluator-state + eva-debug? IF ." restored fcode@ " dup . cr THEN to fcode@ + eva-debug? IF ." restored fcode-spread " dup . cr THEN to fcode-spread +\ local fcodes are currently NOT restored! + eva-debug? IF ." restored fcode-offset " dup . cr THEN to fcode-offset + eva-debug? IF ." restored fcode-end " dup . cr THEN fcode-end ! + eva-debug? IF ." restored ip " dup . cr THEN set-ip + ; + +: token-table-index ( fcode# -- addr ) + cells token-table + + ; + +: join-immediate ( xt immediate? addr -- xt+immediate? addr ) + -rot + swap + ; + +: split-immediate ( xt+immediate? -- xt immediate? ) + dup 1 and 2dup - rot drop swap + ; + +: literal, ( n -- ) + postpone literal + ; + +: fc-string, + postpone sliteral + dup c, bounds ?do i c@ c, loop + ; + +: set-token ( xt immediate? fcode# -- ) + token-table-index join-immediate ! + ; + +: get-token ( fcode# -- xt immediate? ) + token-table-index @ split-immediate + ; + +( ---------------------------------------------------- ) + +#include "little-big.fs" + +( ---------------------------------------------------- ) + +: read-fcode# ( -- FCode# ) + read-byte + dup 01 0F between IF drop read-fcode-num16 THEN + ; + +: read-header ( adr -- ) + next-ip read-byte drop + next-ip read-fcode-num16 drop + next-ip read-fcode-num32 drop + ; + +: read-fcode-string ( -- str len ) + read-byte \ get string length ( -- len ) + next-ip get-ip \ get string addr ( -- len str ) + swap \ type needs the parameters swapped ( -- str len ) + dup 1- jump-n-ip \ jump to the end of the string in FCode + ; + + +-1 VALUE break-fcode-addr +0 VALUE break-fcode-steps + +: evaluate-fcode ( -- ) + BEGIN + get-ip break-fcode-addr = IF + TRUE fcode-end ! + THEN + fcode-end @ 0= + WHILE + fcode@ ( fcode# ) + eva-debug? IF + dup + get-ip 8 u.r ." : " + ." [" 3 u.r ." ] " + THEN + \ When it is not immediate and in compile-mode, then compile + get-token 0= ?compile-mode AND IF ( xt ) + compile, + ELSE \ immediate or "interpretation" mode + eva-debug? IF dup xt>name type space THEN + execute + THEN + eva-debug? IF .s cr THEN + break-fcode-steps IF + break-fcode-steps 1- TO break-fcode-steps + break-fcode-steps 0= IF + TRUE fcode-end ! + THEN + THEN + next-ip + REPEAT +; + +\ Run FCODE for n steps +: steps-fcode ( n -- ) + to break-fcode-steps + break-fcode-addr >r -1 to break-fcode-addr + reset-fcode-end + evaluate-fcode + r> to break-fcode-addr +; + +\ Step through one FCODE instruction +: step-fcode ( -- ) + 1 steps-fcode +; diff --git a/qemu/roms/SLOF/slof/fs/fcode/evaluator.fs b/qemu/roms/SLOF/slof/fs/fcode/evaluator.fs new file mode 100644 index 000000000..8f0bae527 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/evaluator.fs @@ -0,0 +1,119 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 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 +\ ****************************************************************************/ + + +variable ip +variable fcode-end +variable fcode-num + 1 value fcode-spread + 2 value fcode-offset +false value eva-debug? +true value fcode-debug? +defer fcode-rb@ +defer fcode@ + +' c@ to fcode-rb@ + +create token-table 2000 cells allot \ 1000h = 4096d + +#include "core.fs" +#include "1275.fs" +#include "tokens.fs" +#include "locals.fs" + +0 value buff +0 value buff-size + +' read-fcode# to fcode@ + +( ---------------------------------------------------- ) + +: execute-rom-fcode ( addr len | false -- ) + reset-fcode-end + ?dup IF + diagnostic-mode? IF ." , executing ..." cr THEN + dup >r r@ alloc-mem dup >r swap rmove + r@ set-ip evaluate-fcode + diagnostic-mode? IF ." Done." cr THEN + r> r> free-mem + THEN +; + +: rom-code-ignored ( image-addr name len -- image-addr ) + diagnostic-mode? IF + type ." code found in image " dup . ." , ignoring ..." cr + ELSE + 2drop + THEN +; + +: pci-find-rom ( baseaddr -- addr ) + dup IF + dup rw@-le aa55 = IF + diagnostic-mode? IF ." Device ROM header found at " dup . cr THEN + ELSE + drop 0 + THEN + THEN +; + +: pci-find-fcode ( baseaddr -- addr len | false ) + BEGIN + 1ff NOT and \ Image must start at 512 byte boundary + pci-find-rom dup + WHILE + dup 18 + rw@-le + ( pcir-addr ) + \ Check for PCIR magic ... since pcir-addr might not be + \ 4-byte aligned, we've got to use two reads here: + dup rw@-le 4350 ( 'PC' ) <> ( pcir-addr hasPC? ) + over 2+ rw@-le 5249 ( 'IR' ) <> OR IF + diagnostic-mode? IF + ." Invalid PCI Data structure, ignoring ROM contents" cr + THEN + drop false EXIT + THEN ( pcir-addr ) + dup 14 + rb@ CASE \ Get image code type + 0 OF s" Intel x86 BIOS" rom-code-ignored ENDOF + 1 OF + diagnostic-mode? IF + ." Open Firmware FCode found in image at " dup . cr + THEN + dup 1ff NOT AND \ Back to the ROM image header + dup 2+ rw@-le + \ Pointer to FCODE (PCI bus binding ch.9) + swap 10 + rw@-le 200 * \ Image length + EXIT + ENDOF + 2 OF s" HP PA RISC" rom-code-ignored ENDOF + 3 OF s" EFI" rom-code-ignored ENDOF + dup OF s" Unknown type" rom-code-ignored ENDOF + ENDCASE + dup 15 + rb@ 80 and IF \ End of last image? + drop false EXIT + THEN + dup 10 + rw@-le 200 * + \ Next image start + REPEAT +; + + +\ Prepare and run a FCODE program from a PCI Option ROM. +: pci-execute-fcode ( baseaddr -- ) + pci-find-fcode dup 0= IF + 2drop EXIT + THEN ( addr len ) + fc-set-pci-mmio-tokens \ Prepare PCI access functions + \ Now run the FCODE: + ['] execute-rom-fcode CATCH IF + cr ." FCODE failed!" cr + 2drop + THEN + fc-set-normal-mmio-tokens \ Restore normal MMIO access functions +; diff --git a/qemu/roms/SLOF/slof/fs/fcode/little-big.fs b/qemu/roms/SLOF/slof/fs/fcode/little-big.fs new file mode 100644 index 000000000..309c626a9 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/little-big.fs @@ -0,0 +1,96 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 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 +\ ****************************************************************************/ + +\ little- and big-endian FCODE IP access functions + + +?bigendian [IF] \ Big endian access functions first + + +: read-fcode-num16 ( -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 6 + C! + next-ip + read-byte fcode-num 7 + C! + ELSE + read-byte fcode-num 2 + C! + next-ip + read-byte fcode-num 3 + C! + THEN + fcode-num @ +; + +: read-fcode-num32 ( -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 4 + C! + next-ip + read-byte fcode-num 5 + C! + next-ip + read-byte fcode-num 6 + C! + next-ip + read-byte fcode-num 7 + C! + ELSE + read-byte fcode-num 0 + C! + next-ip + read-byte fcode-num 1 + C! + next-ip + read-byte fcode-num 2 + C! + next-ip + read-byte fcode-num 3 + C! + THEN + fcode-num @ +; + + +[ELSE] \ Now the little endian access functions + + +: read-fcode-num16 ( -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 7 + C! + next-ip + read-byte fcode-num 6 + C! + ELSE + read-byte fcode-num 1 + C! + next-ip + read-byte fcode-num 0 + C! + THEN + fcode-num @ +; + +: read-fcode-num32 ( adr -- n ) + 0 fcode-num ! + ?arch64 IF + read-byte fcode-num 7 + C! + next-ip + read-byte fcode-num 6 + C! + next-ip + read-byte fcode-num 5 + C! + next-ip + read-byte fcode-num 4 + C! + ELSE + read-byte fcode-num 3 + C! + next-ip + read-byte fcode-num 2 + C! + next-ip + read-byte fcode-num 1 + C! + next-ip + read-byte fcode-num 0 + C! + THEN + fcode-num @ +; + + +[THEN] diff --git a/qemu/roms/SLOF/slof/fs/fcode/locals.fs b/qemu/roms/SLOF/slof/fs/fcode/locals.fs new file mode 100644 index 000000000..5381df058 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/locals.fs @@ -0,0 +1,155 @@ +\ ***************************************************************************** +\ * 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 +\ ****************************************************************************/ +\ * +\ * Support for old-fashioned local values in FCODE. +\ * +\ * There is one old FCODE tokenizer that uses the FCODE opcodes in the range +\ * of 0x407 to 0x41f for supporting Forth local values. Each locals stack +\ * frame contains 8 variables. The opcodes from 0x407 to 0x40f are used to +\ * push 0 up to 8 values from the normal data stack into the current locals +\ * stack frame. All other variables in the current stack frame are not +\ * pre-initialized. +\ * The opcodes from 0x410 to 0x417 can be used for reading the first, second, +\ * ... eighth value out of the locals stack frame, and the opcode from 0x418 +\ * to 0x41f can be used to set the first, second, ... eighth value in the +\ * stack frame respectively. +\ * + +80 cells CONSTANT LOCALS-STACK-SIZE + +LOCALS-STACK-SIZE BUFFER: localsstackbuf + +localsstackbuf VALUE localsstack + + +: fc-local@ ( n -- val ) + cells localsstack swap - @ +; + +: fc-local-1-@ 1 fc-local@ ; +: fc-local-2-@ 2 fc-local@ ; +: fc-local-3-@ 3 fc-local@ ; +: fc-local-4-@ 4 fc-local@ ; +: fc-local-5-@ 5 fc-local@ ; +: fc-local-6-@ 6 fc-local@ ; +: fc-local-7-@ 7 fc-local@ ; +: fc-local-8-@ 8 fc-local@ ; + + +: fc-local! ( val n -- ) + cells localsstack swap - ! +; + +: fc-local-1-! 1 fc-local! ; +: fc-local-2-! 2 fc-local! ; +: fc-local-3-! 3 fc-local! ; +: fc-local-4-! 4 fc-local! ; +: fc-local-5-! 5 fc-local! ; +: fc-local-6-! 6 fc-local! ; +: fc-local-7-! 7 fc-local! ; +: fc-local-8-! 8 fc-local! ; + + +0 VALUE uses-locals? + +\ Create space for the current function on the locals stack. +\ Pre-initialized the n first locals with the n top-most data stack items. +\ Note: Each function can use up to 8 (initialized or uninitialized) locals. +: (fc-push-locals) ( ... n -- ) + \ cr ." pushing " dup . ." locals" cr + 8 cells localsstack + TO localsstack + localsstack localsstackbuf - + LOCALS-STACK-SIZE > ABORT" Locals stack exceeded!" + ?dup IF + ( ... n ) 1 swap DO + i fc-local! \ Store pre-initialized locals + -1 +LOOP + THEN +; + +: fc-push-locals ( n -- ) + \ cr ." compiling push for " dup . ." locals" cr + uses-locals? ABORT" Definition pushes locals multiple times!" + true TO uses-locals? + ( n ) ['] literal execute + ['] (fc-push-locals) compile, +; + +: fc-push-0-locals 0 fc-push-locals ; +: fc-push-1-locals 1 fc-push-locals ; +: fc-push-2-locals 2 fc-push-locals ; +: fc-push-3-locals 3 fc-push-locals ; +: fc-push-4-locals 4 fc-push-locals ; +: fc-push-5-locals 5 fc-push-locals ; +: fc-push-6-locals 6 fc-push-locals ; +: fc-push-7-locals 7 fc-push-locals ; +: fc-push-8-locals 8 fc-push-locals ; + + +: fc-pop-locals ( -- ) + \ ." popping locals" cr + localsstack 8 cells - TO localsstack + localsstack localsstackbuf - 0 < ABORT" Locals stack undeflow!" +; + + +: fc-locals-exit + uses-locals? IF + \ ." compiling pop-locals for exit" cr + ['] fc-pop-locals compile, + THEN + ['] exit compile, +; + +: fc-locals-b(;) + uses-locals? IF + \ ." compiling pop-locals for b(;)" cr + ['] fc-pop-locals compile, + THEN + false TO uses-locals? + ['] b(;) execute +; + + +: fc-set-locals-tokens ( -- ) + ['] fc-push-0-locals 1 407 set-token + ['] fc-push-1-locals 1 408 set-token + ['] fc-push-2-locals 1 409 set-token + ['] fc-push-3-locals 1 40a set-token + ['] fc-push-4-locals 1 40b set-token + ['] fc-push-5-locals 1 40c set-token + ['] fc-push-6-locals 1 40d set-token + ['] fc-push-7-locals 1 40e set-token + ['] fc-push-8-locals 1 40f set-token + + ['] fc-local-1-@ 0 410 set-token + ['] fc-local-2-@ 0 411 set-token + ['] fc-local-3-@ 0 412 set-token + ['] fc-local-4-@ 0 413 set-token + ['] fc-local-5-@ 0 414 set-token + ['] fc-local-6-@ 0 415 set-token + ['] fc-local-7-@ 0 416 set-token + ['] fc-local-8-@ 0 417 set-token + + ['] fc-local-1-! 0 418 set-token + ['] fc-local-2-! 0 419 set-token + ['] fc-local-3-! 0 41a set-token + ['] fc-local-4-! 0 41b set-token + ['] fc-local-5-! 0 41c set-token + ['] fc-local-6-! 0 41d set-token + ['] fc-local-7-! 0 41e set-token + ['] fc-local-8-! 0 41f set-token + + ['] fc-locals-exit 1 33 set-token + ['] fc-locals-b(;) 1 c2 set-token +; +fc-set-locals-tokens diff --git a/qemu/roms/SLOF/slof/fs/fcode/tokens.fs b/qemu/roms/SLOF/slof/fs/fcode/tokens.fs new file mode 100644 index 000000000..3efc17e06 --- /dev/null +++ b/qemu/roms/SLOF/slof/fs/fcode/tokens.fs @@ -0,0 +1,480 @@ +\ ***************************************************************************** +\ * Copyright (c) 2004, 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 +\ ****************************************************************************/ + +: fc-abort ." FCode called abort: IP " get-ip . ( ." STACK: " .s ) depth dup 0< IF abort THEN . rdepth . cr abort ; +: fc-0 ." 0(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 0 ; +: fc-1 ." 1(lit): STACK ( S: " depth . ." R: " rdepth . ." ): " depth 0> IF .s THEN 1 ; + +: parse-1hex 1 hex-decode-unit ; + +\ Adjust functions for accessing MMIO registers. According to IEEE 1275, +\ a bus device can substitute bus-specific implementations of r*@ and r*! +\ for use by its children, e.g. with respect to byte-order. Since PCI is +\ little endian by default, we've got to use the little endian accessor +\ functions for the PCI bus (some FCODE programs are expecting this behavior). +: fc-set-pci-mmio-tokens ( -- ) + ['] rw@-le 0 232 set-token + ['] rw!-le 0 233 set-token + ['] rl@-le 0 234 set-token + ['] rl!-le 0 235 set-token + ['] rx@-le 0 22E set-token + ['] rx!-le 0 22F set-token +; + +\ Set normal MMIO access token behavior: +: fc-set-normal-mmio-tokens ( -- ) + ['] rw@ 0 232 set-token + ['] rw! 0 233 set-token + ['] rl@ 0 234 set-token + ['] rl! 0 235 set-token + ['] rx@ 0 22E set-token + ['] rx! 0 22F set-token +; + +: reset-token-table + FFF 0 DO ['] ferror 0 i set-token LOOP + ; + +reset-token-table + +' end0 0 00 set-token + +\ 01...0F beginning code of 2-byte FCode sequences + +' b(lit) 1 10 set-token + +' b(') 1 11 set-token +' b(") 1 12 set-token +' bbranch 1 13 set-token +' b?branch 1 14 set-token +' b(loop) 1 15 set-token +' b(+loop) 1 16 set-token +' b(do) 1 17 set-token +' b(?do) 1 18 set-token +' i 0 19 set-token +' j 0 1A set-token +' b(leave) 1 1B set-token +' b(of) 1 1C set-token +' execute 0 1D set-token +' + 0 1E set-token +' - 0 1F set-token +' * 0 20 set-token +' / 0 21 set-token +' mod 0 22 set-token +' and 0 23 set-token +' or 0 24 set-token +' xor 0 25 set-token +' invert 0 26 set-token +' lshift 0 27 set-token +' rshift 0 28 set-token +' >>a 0 29 set-token +' /mod 0 2A set-token +' u/mod 0 2B set-token +' negate 0 2C set-token +' abs 0 2D set-token +' min 0 2E set-token +' max 0 2F set-token +' >r 0 30 set-token +' r> 0 31 set-token +' r@ 0 32 set-token +' exit 0 33 set-token +' 0= 0 34 set-token +' 0<> 0 35 set-token +' 0< 0 36 set-token +' 0<= 0 37 set-token +' 0> 0 38 set-token +' 0>= 0 39 set-token +' < 0 3A set-token +' > 0 3B set-token +' = 0 3C set-token +' <> 0 3D set-token +' u> 0 3E set-token +' u<= 0 3F set-token +' u< 0 40 set-token +' u>= 0 41 set-token +' >= 0 42 set-token +' <= 0 43 set-token +' between 0 44 set-token +' within 0 45 set-token +' DROP 0 46 set-token +' DUP 0 47 set-token +' OVER 0 48 set-token +' SWAP 0 49 set-token +' ROT 0 4A set-token +' -ROT 0 4B set-token +' TUCK 0 4C set-token +' nip 0 4D set-token +' pick 0 4E set-token +' roll 0 4F set-token +' ?dup 0 50 set-token +' depth 0 51 set-token +' 2drop 0 52 set-token +' 2dup 0 53 set-token +' 2over 0 54 set-token +' 2swap 0 55 set-token +' 2rot 0 56 set-token +' 2/ 0 57 set-token +' u2/ 0 58 set-token +' 2* 0 59 set-token +' /c 0 5A set-token +' /w 0 5B set-token +' /l 0 5C set-token +' /n 0 5D set-token +' ca+ 0 5E set-token +' wa+ 0 5F set-token +' la+ 0 60 set-token +' na+ 0 61 set-token +' char+ 0 62 set-token +' wa1+ 0 63 set-token +' la1+ 0 64 set-token +' cell+ 0 65 set-token +' chars 0 66 set-token +' /w* 0 67 set-token +' /l* 0 68 set-token +' cells 0 69 set-token +' on 0 6A set-token +' off 0 6B set-token +' +! 0 6C set-token +' @ 0 6D set-token +' fc-l@ 0 6E set-token +' fc-w@ 0 6F set-token +' fc-<w@ 0 70 set-token +' fc-c@ 0 71 set-token +' ! 0 72 set-token +' fc-l! 0 73 set-token +' fc-w! 0 74 set-token +' fc-c! 0 75 set-token +' 2@ 0 76 set-token +' 2! 0 77 set-token +' fc-move 0 78 set-token +' fc-fill 0 79 set-token +' comp 0 7A set-token +' noop 0 7B set-token +' lwsplit 0 7C set-token +' wljoin 0 7D set-token +' lbsplit 0 7E set-token +' bljoin 0 7F set-token +' wbflip 0 80 set-token +' upc 0 81 set-token +' lcc 0 82 set-token +' pack 0 83 set-token +' count 0 84 set-token +' body> 0 85 set-token +' >body 0 86 set-token +' fcode-revision 0 87 set-token +' span 0 88 set-token +' unloop 0 89 set-token +' expect 0 8A set-token +' alloc-mem 0 8B set-token +' free-mem 0 8C set-token +' key? 0 8D set-token +' key 0 8E set-token +' emit 0 8F set-token +' type 0 90 set-token +' (cr 0 91 set-token +' cr 0 92 set-token +' #out 0 93 set-token +' #line 0 94 set-token +' hold 0 95 set-token +' <# 0 96 set-token +' u#> 0 97 set-token +' sign 0 98 set-token +' u# 0 99 set-token +' u#s 0 9A set-token +' u. 0 9B set-token +' u.r 0 9C set-token +' . 0 9D set-token +' .r 0 9E set-token +' .s 0 9F set-token +' base 0 A0 set-token +\ ' convert 0 A1 set-token \ historical, not supported +' $number 0 A2 set-token +' digit 0 A3 set-token +' -1 0 A4 set-token +' 0 0 A5 set-token +' 1 0 A6 set-token +' 2 0 A7 set-token +' 3 0 A8 set-token +' bl 0 A9 set-token +' bs 0 AA set-token +' bell 0 AB set-token +' bounds 0 AC set-token +' here 0 AD set-token +' aligned 0 AE set-token +' wbsplit 0 AF set-token +' bwjoin 0 B0 set-token +' b(<mark) 1 B1 set-token +' b(>resolve) 1 B2 set-token +\ ' set-token-table 0 B3 set-token \ historical, not supported +\ ' set-table 0 B4 set-token \ historical, not supported +' new-token 0 B5 set-token +' named-token 0 B6 set-token +' b(:) 1 B7 set-token +' b(value) 1 B8 set-token +' b(variable) 1 B9 set-token +' b(constant) 1 BA set-token +' b(create) 1 BB set-token +' b(defer) 1 BC set-token +' b(buffer:) 1 BD set-token +' b(field) 1 BE set-token +\ ' b(code) 0 BF set-token \ historical, not supported +' fc-instance 1 C0 set-token +\ ' ferror 0 C1 set-token \ Reserved +' b(;) 1 C2 set-token +' b(to) 1 C3 set-token +' b(case) 1 C4 set-token +' b(endcase) 1 C5 set-token +' b(endof) 1 C6 set-token +' # 0 C7 set-token +' #s 0 C8 set-token +' #> 0 C9 set-token +' external-token 0 CA set-token +' $find 0 CB set-token +' offset16 0 CC set-token +' evaluate 0 CD set-token +\ 0 CE reserved +\ 0 CF reserved +' c, 0 D0 set-token +' w, 0 D1 set-token +' l, 0 D2 set-token +' , 0 D3 set-token +' um* 0 D4 set-token +' um/mod 0 D5 set-token +\ 0 D6 reserved +\ 0 D7 reserved +' d+ 0 D8 set-token +' d- 0 D9 set-token +' get-token 0 DA set-token +' set-token 0 DB set-token +' state 0 DC set-token \ possibly broken +' compile, 0 DD set-token +' behavior 0 DE set-token + +\ Tokens 0xDF to 0xEF are reserved + +' start0 0 F0 set-token +' start1 0 F1 set-token +' start2 0 F2 set-token +' start4 0 F3 set-token + +\ Tokens 0xF4 to 0xFB are reserved + +' ferror 0 FC set-token +' version1 0 FD set-token + +\ ' 4-byte-id 0 FE set-token \ Historical, not supported +' end1 0 FF set-token + +\ 0 100 set-token \ reserved +' dma-alloc 0 101 set-token \ Obsolete +' my-address 0 102 set-token +' my-space 0 103 set-token +\ ' memmap 0 104 set-token \ Obsolete +' free-virtual 0 105 set-token +\ ' >physical 0 106 set-token \ Obsolete + +\ Tokens 0x107 to 0x10e are reserved + +' my-params 0 10f set-token \ Obsolete +' property 0 110 set-token +' encode-int 0 111 set-token +' encode+ 0 112 set-token +' encode-phys 0 113 set-token +' encode-string 0 114 set-token +' encode-bytes 0 115 set-token +' reg 0 116 set-token +' intr 0 117 set-token \ Obsolete +' driver 0 118 set-token \ Obsolete +' model 0 119 set-token +' device-type 0 11A set-token +' parse-2int 0 11B set-token +\ ' is-install 0 11C set-token \ Will be set by framebuffer code +\ ' is-remove 0 11D set-token \ Will be set by framebuffer code +\ ' is-selftest 0 11E set-token \ Will be set by framebuffer code +' new-device 0 11F set-token +' diagnostic-mode? 0 120 set-token +' display-status 0 121 set-token \ Maybe obsolete +' memory-test-suite 0 122 set-token +' group-code 0 123 set-token \ Obsolete +' mask 0 124 set-token +' get-msecs 0 125 set-token +' ms 0 126 set-token +' finish-device 0 127 set-token +' decode-phys 0 128 set-token +\ ' push-package 0 129 set-token \ TODO - from proposal 215 +\ ' pop-package 0 12A set-token \ TODO - from proposal 215 +' interpose 0 12B set-token \ Recommended practice: Interposition + +\ Tokens 0x12C to 0x12F are reserved + +' map-low 0 130 set-token +' sbus-intr>cpu 0 131 set-token \ Obsolete + +\ Tokens 0x132 to 0x14f are reserved + +\ The following tokens will be set by the framebuffer code: +\ ' #lines 0 150 set-token +\ ' #columns 0 151 set-token +\ ' line# 0 152 set-token +\ ' column# 0 153 set-token +\ ' inverse? 0 154 set-token +\ ' inverse-screen? 0 155 set-token +\ ' frame-buffer-busy 0 156 set-token \ Historical, not supported +\ ' draw-character 0 157 set-token +\ ' reset-screen 0 158 set-token +\ ' toggle-cursor 0 159 set-token +\ ' erase-screen 0 15A set-token +\ ' blink-screen 0 15B set-token +\ ' invert-screen 0 15C set-token +\ ' insert-characters 0 15D set-token +\ ' delete-characters 0 15E set-token +\ ' insert-lines 0 15F set-token +\ ' delete-lines 0 160 set-token +\ ' draw-logo 0 161 set-token +\ ' frame-buffer-adr 0 162 set-token +\ ' screen-height 0 163 set-token +\ ' screen-width 0 164 set-token +\ ' window-top 0 165 set-token +\ ' window-left 0 166 set-token +\ ' 0 167 set-token \ Reserved +\ ' foreground-color 0 168 set-token \ From 16-color recommended practice +\ ' background-color 0 169 set-token \ From 16-color recommended practice +\ ' default-font 0 16A set-token +\ ' set-font 0 16B set-token +\ ' char-height 0 16C set-token +\ ' char-width 0 16D set-token +\ ' >font 0 16E set-token +\ ' fontbytes 0 16F set-token + +\ Tokens 0x170 to 0x17C are obsolete fb1 functions +\ Tokens 0x17D to 0x17F are reserved + +\ The following tokens will be set by the framebuffer code, too: +\ ' fb8-draw-character 0 180 set-token +\ ' fb8-reset-screen 0 181 set-token +\ ' fb8-toggle-cursor 0 182 set-token +\ ' fb8-erase-screen 0 183 set-token +\ ' fb8-blink-screen 0 184 set-token +\ ' fb8-invert-screen 0 185 set-token +\ ' fb8-insert-characters 0 186 set-token +\ ' fb8-delete-characters 0 187 set-token +\ ' fb8-insert-lines 0 188 set-token +\ ' fb8-delete-lines 0 189 set-token +\ ' fb8-draw-logo 0 18A set-token +\ ' fb8-install 0 18B set-token + +\ Tokens 0x18C to 0x18F are reserved +\ Tokens 0x190 to 0x196 are obsolete VMEbus tokens +\ Tokens 0x197 to 0x19F are reserved + +\ ' return-buffer 0 1A0 set-token \ Historical, not supported +\ ' xmit-packet 0 1A1 set-token \ Historical, not supported +\ ' poll-packet 0 1A2 set-token \ Historical, not supported +\ 0 1A3 set-token \ reserved +' mac-address 0 1A4 set-token + +\ Tokens 0x1A5 to 0x200 are reserved + +' device-name 0 201 set-token +' my-args 0 202 set-token +' my-self 0 203 set-token +' find-package 0 204 set-token +' open-package 0 205 set-token +' close-package 0 206 set-token +' find-method 0 207 set-token +' call-package 0 208 set-token +' $call-parent 0 209 set-token +' my-parent 0 20A set-token +' ihandle>phandle 0 20B set-token +\ 0 20C set-token \ reserved +' my-unit 0 20D set-token +' $call-method 0 20E set-token +' $open-package 0 20F set-token +' processor-type 0 210 set-token \ Obsolete +' firmware-version 0 211 set-token \ Obsolete +' fcode-version 0 212 set-token \ Obsolete +\ ' alarm 0 213 set-token \ TODO +' (is-user-word) 0 214 set-token +' suspend-fcode 0 215 set-token +' fc-abort 0 216 set-token +' catch 0 217 set-token +' throw 0 218 set-token +\ ' user-abort 0 219 set-token \ TODO +' get-my-property 0 21A set-token +' decode-int 0 21B set-token +' decode-string 0 21C set-token +' get-inherited-property 0 21D set-token +' delete-property 0 21E set-token +' get-package-property 0 21F set-token +' cpeek 0 220 set-token +' wpeek 0 221 set-token +' lpeek 0 222 set-token +' cpoke 0 223 set-token +' wpoke 0 224 set-token +' lpoke 0 225 set-token +' lwflip 0 226 set-token +' lbflip 0 227 set-token +' lbflips 0 228 set-token +\ ' adr-mask 0 229 set-token \ Historical, not supported + +\ Tokens 0x22A to 0x22F are reserved + +' rb@ 0 230 set-token +' rb! 0 231 set-token +fc-set-normal-mmio-tokens \ Set rw@, rw!, rl@, rl!, rx@ and rx! + +' wbflips 0 236 set-token +' lwflips 0 237 set-token +\ ' probe 0 238 set-token \ Obsolete +\ ' probe-virtual 0 239 set-token \ Obsolete +\ 0 23A reserved +' child 0 23B set-token +' peer 0 23C set-token +' next-property 0 23D set-token +' byte-load 0 23E set-token +' set-args 0 23F set-token +' left-parse-string 0 240 set-token + +\ 64-bit extension tokens: +' bxjoin 0 241 set-token +' fc-<l@ 0 242 set-token +' lxjoin 0 243 set-token +' wxjoin 0 244 set-token +' x, 0 245 set-token +' fc-x@ 0 246 set-token +' fc-x! 0 247 set-token +' /x 0 248 set-token +' /x* 0 249 set-token +' xa+ 0 24A set-token +' xa1+ 0 24B set-token +' xbflip 0 24C set-token +' xbflips 0 24D set-token +' xbsplit 0 24E set-token +' xlflip 0 24F set-token +' xlflips 0 250 set-token +' xlsplit 0 251 set-token +' xwflip 0 252 set-token +' xwflips 0 253 set-token +' xwsplit 0 254 set-token + +\ 0 255 RESERVED FCODES +\ ... +\ 0 5FF RESERVED FCODES + +\ 0 600 VENDOR FCODES +\ ... +\ 0 7FF VENDOR FCODES + +\ 0 800 LOCAL FCODES +\ ... +\ 0 FFF LOCAL FCODES + |