[gforth] / gforth / prims2x.fs  

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.156 and 1.163

version 1.156, Wed Jul 27 19:44:20 2005 UTC version 1.163, Sun Dec 31 13:39:13 2006 UTC
Line 1 
Line 1 
 \ converts primitives to, e.g., C code  \ converts primitives to, e.g., C code
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 51 
Line 51 
 \ (stack-in-index-xt and a test for stack==instruction-stream); there  \ (stack-in-index-xt and a test for stack==instruction-stream); there
 \ should be only one.  \ should be only one.
   
   
 \ for backwards compatibility, jaw  \ for backwards compatibility, jaw
 require compat/strcomp.fs  require compat/strcomp.fs
   
Line 102 
Line 103 
 \ inline arguments (false)  \ inline arguments (false)
 include-skipped-insts off  include-skipped-insts off
   
   2variable threaded-code-pointer-type \ type used for geninst etc.
   s" Inst **" threaded-code-pointer-type 2!
   
 variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)  variable immarg \ values for immediate arguments (to be used in IMM_ARG macros)
 $12340000 immarg !  $12340000 immarg !
   
Line 201 
Line 205 
 end-struct ss% \ stack-state  end-struct ss% \ stack-state
   
 struct%  struct%
       cell%              field state-enabled
     cell%              field state-number      cell%              field state-number
     cell% max-stacks * field state-sss      cell% max-stacks * field state-sss
 end-struct state%  end-struct state%
Line 231 
Line 236 
     rdrop ;      rdrop ;
   
 : map-stacks { xt -- }  : map-stacks { xt -- }
     \ perform xt for all stacks      \ perform xt ( stack -- ) for all stacks
     next-stack-number @ 0 +do      next-stack-number @ 0 +do
         stacks i th @ xt execute          stacks i th @ xt execute
     loop ;      loop ;
   
 : map-stacks1 { xt -- }  : map-stacks1 { xt -- }
     \ perform xt for all stacks except inst-stream      \ perform xt ( stack -- ) for all stacks except inst-stream
     next-stack-number @ 1 +do      next-stack-number @ 1 +do
         stacks i th @ xt execute          stacks i th @ xt execute
     loop ;      loop ;
Line 351 
Line 356 
     \ address of number of stack items in effect out      \ address of number of stack items in effect out
     stack-number @ cells prim prim-stacks-out + ;      stack-number @ cells prim prim-stacks-out + ;
   
   : stack-prim-stacks-sync ( stack -- addr )
       prim prim-stacks-sync swap stack-number @ th ;
   
 \ global vars  \ global vars
 variable c-line  variable c-line
 2variable c-filename  2variable c-filename
Line 497 
Line 505 
     ." vm_two"      ." vm_two"
     r@ item-stack-type-name type ." 2"      r@ item-stack-type-name type ." 2"
     r@ item-type @ print-type-prefix ." ("      r@ item-type @ print-type-prefix ." ("
     r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-read      r@ item-in-index r@ item-stack @ 2dup stack-read
     ." , "                      -1 under+ ." (Cell)" stack-read      ." , "                      -1 under+ stack-read
     ." , " r@ item-name 2@ type      ." , " r@ item-name 2@ type
     ." )" cr      ." )" cr
     rdrop ;      rdrop ;
Line 506 
Line 514 
 : same-as-in? ( item -- f )  : same-as-in? ( item -- f )
  \ f is true iff the offset and stack of item is the same as on input   \ f is true iff the offset and stack of item is the same as on input
  >r   >r
       r@ item-stack @ stack-prim-stacks-sync @ if
           rdrop false exit
       endif
  r@ item-first @ if   r@ item-first @ if
      rdrop false exit       rdrop false exit
  endif   endif
Line 617 
Line 628 
         endif          endif
         -1 s+loop          -1 s+loop
     \ we did not find a type, abort      \ we did not find a type, abort
           abort
     false s" unknown prefix" ?print-error ;      false s" unknown prefix" ?print-error ;
   
 : declaration ( item -- )  : declaration ( item -- )
Line 650 
Line 662 
     stack item item-stack !      stack item item-stack !
     item declaration ;      item declaration ;
   
   : set-prim-stacks-sync ( stack -- )
       stack-prim-stacks-sync on ;
   
   : clear-prim-stacks-sync ( stack -- )
       stack-prim-stacks-sync off ;
   
   
 get-current prefixes set-current  get-current prefixes set-current
 : ... ( item -- )  : ... ( item -- )
     \ this "prefix" ensures that the appropriate stack is synced with memory      \ this "prefix" ensures that the appropriate stack is synced with memory
     dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name"      dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name"
     item-stack @ dup if      item-stack @ dup if
         stack-number @ prim prim-stacks-sync swap th on          set-prim-stacks-sync
     else \ prefixless "..." syncs all stacks      else \ prefixless "..." syncs all stacks
         max-stacks 0 +do          drop ['] set-prim-stacks-sync map-stacks1
             prim prim-stacks-sync i th on  
         loop  
     endif ;      endif ;
 set-current  set-current
   
Line 739 
Line 756 
 : state ( "name" -- )  : state ( "name" -- )
     \ create a state initialized with default-sss      \ create a state initialized with default-sss
     create state% %allot { s }      create state% %allot { s }
       s state-enabled on
     next-state-number @ s state-number ! 1 next-state-number +!      next-state-number @ s state-number ! 1 next-state-number +!
     max-stacks 0 ?do      max-stacks 0 ?do
         default-ss s state-sss i th !          default-ss s state-sss i th !
     loop ;      loop ;
   
   : state-disable ( state -- )
       state-enabled off ;
   
   : state-enabled? ( state -- f )
       state-enabled @ ;
   
 : .state ( state -- )  : .state ( state -- )
     0 >body - >name .name ;      0 >body - >name .name ;
   
Line 775 
Line 799 
   
 : init-simple { prim -- }  : init-simple { prim -- }
     \ much of the initialization is elsewhere      \ much of the initialization is elsewhere
     max-stacks 0 +do      ['] clear-prim-stacks-sync map-stacks ;
         prim prim-stacks-sync i th off  
     loop ;  
   
 : process-simple ( -- )  : process-simple ( -- )
     prim init-simple  
     prim prim { W^ key } key cell      prim prim { W^ key } key cell
     combinations ['] constant insert-wordlist      combinations ['] constant insert-wordlist
     declarations compute-offsets      declarations compute-offsets
Line 795 
Line 816 
     stack state-in  stack-state-items stack stack-in  @ - 0 max      stack state-in  stack-state-items stack stack-in  @ - 0 max
     stack state-out stack-state-items stack stack-out @ - 0 max ;      stack state-out stack-state-items stack stack-out @ - 0 max ;
   
   : spill-stack-items { stack -- u }
       \ there are u items to spill in stack
       stack unused-stack-items
       stack stack-prim-stacks-sync @ if
           drop 0
       endif
       swap - ;
   
 : spill-stack { stack -- }  : spill-stack { stack -- }
     \ spill regs of state-in that are not used by prim and are not in state-out      \ spill regs of state-in that are not used by prim and are not in state-out
     stack state-in stack-offset { offset }      stack state-in stack-offset { offset }
     stack state-in stack-state-items ( items )      stack state-in stack-state-items ( items )
     dup stack unused-stack-items - - +do      dup stack spill-stack-items + +do
         \ loop through the bottom items          \ loop through the bottom items
         stack stack-pointer 2@ type          stack stack-pointer 2@ type
         i offset - stack normal-stack-access0 ."  = "          i offset - stack normal-stack-access0 ."  = "
Line 809 
Line 838 
 : spill-state ( -- )  : spill-state ( -- )
     ['] spill-stack map-stacks1 ;      ['] spill-stack map-stacks1 ;
   
   : fill-stack-items { stack -- u }
       \ there are u items to fill in stack
       stack unused-stack-items
       stack stack-prim-stacks-sync @ if
           swap drop 0 swap
       endif
       - ;
   
 : fill-stack { stack -- }  : fill-stack { stack -- }
     stack state-out stack-offset { offset }      stack state-out stack-offset { offset }
     stack state-out stack-state-items ( items )      stack state-out stack-state-items ( items )
     dup stack unused-stack-items - + +do      dup stack fill-stack-items + +do
         \ loop through the bottom items          \ loop through the bottom items
         i stack state-out normal-stack-access1 ."  = "          i stack state-out normal-stack-access1 ."  = "
         stack stack-pointer 2@ type          stack stack-pointer 2@ type
Line 868 
Line 905 
     stack-access-transform @ dup >r execute      stack-access-transform @ dup >r execute
     0 r> execute - ;      0 r> execute - ;
   
   : update-stack-pointer { stack n -- }
       n if \ this check is not necessary, gcc would do this for us
           stack inst-stream = if
               ." INC_IP(" n 0 .r ." );" cr
           else
               stack stack-pointer 2@ type ."  += "
               n stack stack-update-transform 0 .r ." ;" cr
           endif
       endif ;
   
 : stack-pointer-update { stack -- }  : stack-pointer-update { stack -- }
     \ and moves      \ and moves
     \ stacks grow downwards      \ stacks grow downwards
       stack stack-prim-stacks-sync @ if
           stack stack-in @
           stack state-in  stack-offset -
           stack swap update-stack-pointer
       else
     stack stack-diff ( in-out )      stack stack-diff ( in-out )
     stack state-in  stack-offset -      stack state-in  stack-offset -
     stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )      stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )
     ?dup-if \ this check is not necessary, gcc would do this for us          stack swap update-stack-pointer
         stack inst-stream = if          stack stack-moves
             ." INC_IP(" 0 .r ." );" cr      endif ;
         else  
             stack stack-pointer 2@ type ."  += "  
             stack stack-update-transform 0 .r ." ;" cr  
         endif  
     endif  
     stack stack-moves ;  
   
 : stack-pointer-updates ( -- )  : stack-pointer-updates ( -- )
     ['] stack-pointer-update map-stacks ;      ['] stack-pointer-update map-stacks ;
   
   : stack-pointer-update2 { stack -- }
       stack stack-prim-stacks-sync @ if
           stack state-out stack-offset
           stack stack-out @ -
           stack swap update-stack-pointer
       endif ;
   
   : stack-pointer-updates2 ( -- )
       \ update stack pointers after C code, where necessary
       ['] stack-pointer-update2 map-stacks ;
   
 : store ( item -- )  : store ( item -- )
 \ f is true if the item should be stored  \ f is true if the item should be stored
 \ f is false if the store is probably not necessary  \ f is false if the store is probably not necessary
Line 957 
Line 1014 
     output-super-end      output-super-end
     print-debug-results      print-debug-results
     output-nextp1      output-nextp1
       stack-pointer-updates2
     stores      stores
     fill-state      fill-state
     xt execute ;      xt execute ;
Line 1123 
Line 1181 
   
 : output-gen ( -- )  : output-gen ( -- )
     \ generate C code for generating VM instructions      \ generate C code for generating VM instructions
     ." void gen_" prim prim-c-name 2@ type ." (Inst **ctp" gen-args-parm ." )" cr      ." void gen_" prim prim-c-name 2@ type ." ("
       threaded-code-pointer-type 2@ type ." ctp" gen-args-parm ." )" cr
     ." {" cr      ." {" cr
     ."   gen_inst(ctp, vm_prim[" function-number @ 0 .r ." ]);" cr      ."   gen_inst(ctp, " function-number @ 0 .r ." );" cr
     gen-args-gen      gen-args-gen
     ." }" cr ;      ." }" cr ;
   
Line 1411 
Line 1470 
   
 : state-prim1 { in-state out-state prim -- }  : state-prim1 { in-state out-state prim -- }
     in-state out-state state-default dup d= ?EXIT      in-state out-state state-default dup d= ?EXIT
       in-state state-enabled? out-state state-enabled? and 0= ?EXIT
     in-state  to state-in      in-state  to state-in
     out-state to state-out      out-state to state-out
     prim reprocess-simple ;      prim reprocess-simple ;
Line 1429 
Line 1489 
 : compute-default-state-out ( n-in -- n-out )  : compute-default-state-out ( n-in -- n-out )
     \ for the current prim      \ for the current prim
     cache-stack stack-in @ - 0 max      cache-stack stack-in @ - 0 max
       cache-stack stack-prim-stacks-sync @ if
           drop 0
       endif
     cache-stack stack-out @ + cache-states 2@ nip 1- min ;      cache-stack stack-out @ + cache-states 2@ nip 1- min ;
   
 : gen-prim-states ( prim -- )  : gen-prim-states ( prim -- )
Line 1755 
Line 1818 
 (( letter (( letter || digit )) **  (( letter (( letter || digit )) **
 )) <- c-ident ( -- )  )) <- c-ident ( -- )
   
 (( ` # ?? (( letter || digit || ` : )) ++ (( ` . ` . ` . )) ??  (( ` . ` . ` .
   )) <- sync-stack ( -- )
   
   (( ` # ?? (( letter || digit || ` : )) ++ sync-stack ??
   || sync-stack
 )) <- stack-ident ( -- )  )) <- stack-ident ( -- )
   
 (( nowhitebq nowhite ** ))  (( nowhitebq nowhite ** ))
Line 1818 
Line 1885 
    {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}     {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
 )) <- stack-effect ( -- )  )) <- stack-effect ( -- )
   
 (( {{ prim create-prim }}  (( {{ prim create-prim prim init-simple }}
    ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **     ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
    (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **     (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
       (( {{ start }}  c-ident {{ end 2dup prim-c-name-2! }} )) ??        (( {{ start }}  c-ident {{ end 2dup prim-c-name-2! }} )) ??

Generate output suitable for use with a patch program
Legend:
Removed from v.1.156  
changed lines
  Added in v.1.163
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help