kmx git

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: common.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 
\    conditions are met: 
\ 
\  - 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
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)common.fth 2.28 03/12/11 09:22:43
purpose: The basic FCode byte code interpreter loop
copyright: Copyright 1990-2002 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\  The basic FCode byte code interpreter loop


\ "Generic" byte code interpreter.  These words are used to interpret
\ byte code streams.  The action to be performed for each byte code
\ in the stream is defined externally, so the interpreter code in this
\ file may be used by several programs, such as the byte code recompiler
\ in the CPU boot PROM and the byte code display program.


headers

nuser interpreter-pointer	\ Points to next byte code in stream
nuser fcode-verbose?		\ Print out fcodes as they are encountered

headerless

[ifnexist] chdump
   also hidden
      : chdump ( addr len -- )  push-hex ['] c@ to dc@ d.2 pop-base ;
   previous
[then]

[ifnexist] char?
   : char?  ( byte -- flag )
      dup bl h# 7e between		( byte printable?)
      over carret = rot linefeed =	( printable? cr? nl?)
      or or				( printable?)
   ;
[then]


nuser more-bytes?		\ True when stream is not exhausted
\ nuser table#			\ Remembers table # of last code encountered
\ nuser code#			\ Remembers code # of last code encountered
nuser fc-spread			\ The distance between successive bytes in
				\ the code stream.  If the bytes are stored
				\ in an 8-bit PROM connected to one of the
				\ byte lanes of a 32-bit bus, spread is 4.
nuser offset16?			\ Are offsets 16 bits long?

\ Get the next byte code from the byte code stream
: get-byte  ( -- byte-code )
   interpreter-pointer @ c@  fc-spread @ interpreter-pointer +!  ( byte-code )
\  h# 100 0 do loop  \ Debug ONLY
;

d# 16 constant #token-tables		\ Maximum number of token tables

h# 100 constant tokens/table
tokens/table  /token *  constant /token-area
tokens/table  8 /       constant /immed-area   \ 1 bit for each token

/token-area /immed-area +  constant /token-table

\ 0 value token-table0
\ #token-tables /token-table *  buffer: token-table0

\ /stringbuf buffer: string-buf	\ buffer for collecting strings
d# 258 buffer: string-buf	\ buffer for collecting strings

variable token-tables-ptr	\ Token ptr to array of pointers to token tables
: token-tables  ( -- tables-pointer )  token-tables-ptr token@  ;

  8 constant local-table#	\ First table # for local codes


\ Terminate interpretation of the byte code stream.  This is invoked
\ by byte codes 0 and ff, so that the byte code interpreter will exit
\ when an unprogrammed section of the PROM is encountered.
headers
: end0  ( -- )  more-bytes? off  ;  immediate   \ For end value 0
: end1  ( -- )  [compile] end0   ;  immediate   \ For end value ff
: ferror  ( -- )
   ." Unimplemented FCode token before address " interpreter-pointer @ .h cr
   [compile] end0
;
: obsolete-fcode ( -- )  ferror  ;

headerless

: ttbl-align  ( -- )	\ like acf-align without 'lastacf side-effect
   begin  here #acf-align 1- and
   while  0 c,
   repeat
;

: init-tables  ( -- )
   ttbl-align  here
   #token-tables /token *  allot
   ( here )   token-tables-ptr token!
   token-tables   #token-tables /token *  bounds
   ?do  i !null-token  /token +loop
;

\ Return the address of the numbered token table.  If space for that
\ table hasn't yet been allocated, allocate it.
: >token-table  ( table# -- table-adr )
   token-tables  over ta+ get-token?  if      ( table# table-adr )
      nip                                     ( table-adr )
   else                                       ( table# )
      ttbl-align  here                        ( table# table-adr )
      /token-area /immed-area +   allot       ( table# table-adr )
      tokens/table 0  do                      ( table# table-adr )
         dup i ta+  ['] ferror  swap token!   ( table# table-adr )
      loop                                    ( table# table-adr )
      tuck  token-tables  rot ta+  token!     ( table-adr )
      dup /token-area +  /immed-area note-string erase    ( table-adr )
   then                                       ( table-adr )
;

\  Immediate bits for each token are at the end of the table,
\  starting at (table-addr + /token-area).  The bits are
\  addressed individually, without regard for their numeric
\  value within a byte, word, long or extended-cell.  This
\  means that the bit for token#0 is the highest-order bit
\  in the array.  This is not as confusing to implement as
\  it is to explain; the  bitset  bitclear  and  bittest 
\  functions handle the mechanics of it all.  This means
\  that the pair ( N array-addr ) points to the same bit
\  as ( {N mod 8}  {array-addr + N/8} )
\
\  While this is a change from previous versions, it has
\  no impact on compatibility:  the token-tables and their
\  associated "immediate" bits are local to a consolidation.
\     
: >offset  ( code# table-addr -- bitoffset byteaddr )
   /token-area +
;

: set-immed  ( code# table-addr -- )
    >offset  bitset
;

: clear-immed  ( code# table-addr -- )
    >offset  bitclear
;

: immed?  ( code# table-addr -- flag )
   >offset bittest
;

\ Gets a signed offset from the byte code stream.
: get-offset  ( -- n )
   fcode-verbose? @  if  interpreter-pointer @  then	( [? iptr ?] )
   get-byte
   offset16? @  if
      8 <<  get-byte +   d# 16
   else
      d# 24
   then 			( [? iptr ?] raw-offset shift-amount )
   tuck <<  l->n  swap >>a	( [? iptr ?] offset )

   \  For Verbose-mode, print the amount of the offset and the (target).
   fcode-verbose? @  if 				( iptr offset )
      push-hex tuck				 ( offset iptr offset )
      dup s. fc-spread @ * + fake-name .id	 ( offset )
      pop-base
   then
;

\ Gets a 16-bit word from the byte code stream.
: get-word  ( -- 16bit ) get-byte 8 <<  get-byte +  ;

\ Gets a longword from the byte code stream.
: get-long  ( -- long )  get-word  d# 16 <<  get-word +
   fcode-verbose? @  if dup .h then
;

\  Allow text strings only.  Not composites, and no null-byte separators.

: all-text?  ( adr len -- flag )
   false -rot  bounds ?do  drop			( -- )
      i c@ char? dup 0= ?leave
   loop 			   ( all-characters-printable? )
;

\  Types a string as bytes if it is not legitimately text.
: protected-type ( $addr,len -- )
   2dup all-text? if   type
   else       2dup
	    ." ""( "   chdump    ." )"""
      dup if  2dup
	    ."    \  "
	   [ also hidden ] emit.ln  [ previous ]
     then     2drop
   then
;

\ Gets a string from the byte code stream.
: get-bstring  ( -- adr len )
   get-byte  ( len )  dup string-buf  c!  ( len )
   string-buf 1+  swap  bounds  ?do  get-byte i c!  loop
   string-buf  count
   fcode-verbose? @  if  ??cr 8 to-column 2dup protected-type cr then
;

: token\immed  ( code# table-addr -- xt immediate? )
   2dup immed?  >r                                 ( code# table-addr )
   swap ta+  token@   r>
;
headers
\ Don't change fcode-find to return -1|0|1 like find, because
\ some people use it to "rehead" definitions.  If we need a function
\ that returns -1|0|1, give it a different name.
: fcode-find  ( code# table# -- xt immediate? )
   >token-table                                    ( code# table-addr )
   token\immed                                     ( xt immediate? )
;
headerless
\ Gets the address of a Forth word from the byte code stream.
\ The byte code stream contains a byte code.  The address of the
\ Forth word corresponding to that byte code is found and returned.

defer get-token-hook ' noop is get-token-hook

: next-fc-token  ( -- xt immediate? )
   fcode-verbose? @  if
      ??cr  interpreter-pointer @  u. ascii : emit 3 spaces
   then
   get-byte
   dup  #token-tables >=  over 0= or   ( byte table0? )
   if  0  else  get-byte swap  then    ( code# table# )
   fcode-verbose? @  if
      push-hex
      dup [ also hidden ] .2 over .2 [ previous ]
      pop-base
   then
   get-token-hook
   fcode-find                          ( xt immediate? )
   fcode-verbose? @  if
      over .name  dup if ['] immediate .name then
   then
;
headers
: get-token  ( fcode# -- xt immediate? )  wbsplit fcode-find  ;

: set-token  ( xt immediate? fcode# -- )
   wbsplit  >token-table             ( xt immediate? code# table-addr )
   rot  if			     ( xt immediate? code# table-addr )  
      2dup set-immed                 ( xt code# table-addr )   
   else                              ( xt code# table-addr )  
      2dup clear-immed               ( xt code# table-addr )  
   then                              ( xt code# table-addr )
   swap ta+ token!
;

headerless
\ The action performed for each token in the byte code stream.  Before
\ executing byte-interpret, an action routine must be installed in
\ do-byte-compile.
defer do-byte-compile  ( xt immediate? -- )
: verify-fcode-prom-checksum ( -- )
   get-byte  3  <  if				 (  )
      get-word drop   \ Checksum                 (  )
      get-long drop   \ Length                   (  )
   else                                          (  )
      get-word                                   ( cksum )
      0  get-long                                ( cksum 0 length )
      interpreter-pointer @ >r                   ( cksum 0 length ) ( r: ip )
      8 - 0 ?do  get-byte + loop                 ( cksum cksum' )   ( r: ip )
      r> interpreter-pointer !                   ( cksum cksum' )
      lwsplit + lwsplit +  h# 0ffff and  <>  if  (  )
	 ." Incorrect FCode PROM checksum "      (  )
      then                                       (  )
   then                                          (  )
;
headers
variable fcode-checksum?  fcode-checksum?  off
: version1  ( -- )
   offset16? off
   fcode-checksum? @  if
      verify-fcode-prom-checksum
   else
      get-byte drop    \ Pad byte
      get-word drop    \ Checksum,
      get-long drop    \ Length
   then
;
: offset16  ( -- )  offset16? on  ;
headerless
: (version2)  ( spread -- )
   fc-spread @ negate  interpreter-pointer +!      \ Undo previous increment
   fc-spread !
   fc-spread @        interpreter-pointer +!      \ Do new increment
   offset16
   fcode-checksum? @  fc-spread @  and  if
      verify-fcode-prom-checksum
   else
      get-byte drop   \ Pad byte
      get-word drop   \ Checksum,
      get-long drop   \ Length
   then
;
headers
: start0  ( -- )  0 (version2)  ;
: start1  ( -- )  1 (version2)  ;
: start2  ( -- )  2 (version2)  ;
: start4  ( -- )  4 (version2)  ;
headerless
\ The byte code interpreter loop.  adr is the starting address of
\ the byte code stream, and spread is the distance between successive
\ bytes in the stream.
: byte-interpret  ( adr spread -- )
   warning @ >r  warning off
   fc-spread @ >r  interpreter-pointer @ >r  more-bytes? @ >r  offset16? @ >r

   fc-spread !   interpreter-pointer !   more-bytes? on

   begin
      more-bytes? @
   while
      next-fc-token do-byte-compile
   repeat

   r> offset16? !  r> more-bytes? !  r> interpreter-pointer !  r> fc-spread !
   r> warning !
;
headers
openbios/openboot/obp/pkg/fcode/common.fth

Commit

obp/pkg/fcode/common.fth
