Diff for /gforth/prims2x.fs between versions 1.151 and 1.157

version 1.151, 2004/08/26 15:29:57 version 1.157, 2005/07/28 14:12:33
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 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 231  variable next-state-number 0 next-state- Line 231  variable next-state-number 0 next-state-
     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 246  variable next-state-number 0 next-state- Line 246  variable next-state-number 0 next-state-
   
 : init-item ( addr u addr1 -- )  : init-item ( addr u addr1 -- )
     \ initialize item at addr1 with name addr u      \ initialize item at addr1 with name addr u
     \ !! remove stack prefix      \ the stack prefix is removed by the stack-prefix
     dup item% %size erase      dup item% %size erase
     item-name 2! ;      item-name 2! ;
   
Line 280  struct% Line 280  struct%
     cell%    field prim-effect-out-end      cell%    field prim-effect-out-end
     cell% max-stacks * field prim-stacks-in  \ number of in items per stack      cell% max-stacks * field prim-stacks-in  \ number of in items per stack
     cell% max-stacks * field prim-stacks-out \ number of out items per stack      cell% max-stacks * field prim-stacks-out \ number of out items per stack
       cell% max-stacks * field prim-stacks-sync \ sync flag per stack
 end-struct prim%  end-struct prim%
   
 : make-prim ( -- prim )  : make-prim ( -- prim )
Line 649  does> ( item -- ) Line 650  does> ( item -- )
     stack item item-stack !      stack item item-stack !
     item declaration ;      item declaration ;
   
   : stack-prim-stacks-sync ( stack -- addr )
       prim prim-stacks-sync swap stack-number @ th ;
   
   : 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
   : ... ( item -- )
       \ this "prefix" ensures that the appropriate stack is synced with memory
       dup item-name 2@ s" ..." str= 0= abort" '...' must end the item name"
       item-stack @ dup if
           set-prim-stacks-sync
       else \ prefixless "..." syncs all stacks
           ['] set-prim-stacks-sync map-stacks1
       endif ;
   set-current
   
   create ...-item ( -- addr ) \ just used for letting stack-prefixes work on it
   item% %allot                \ stores the stack temporarily until used by ...
   
   : init-item1 ( addr1 addr u -- addr2 )
       \ initialize item at addr1 with name addr u, next item is at addr2
       \ !! make sure that any mention of "..." is only stack-prefixed
       2dup s" ..." search nip nip if ( addr1 addr u )
           0 ...-item item-stack ! \ initialize to prefixless
           2dup ...-item item-name 2!
           ...-item rot rot execute-prefix ( addr1 )
       else
           2 pick init-item item% %size +
       endif ;
   
 \ types pointed to by stacks for use in combined prims  \ types pointed to by stacks for use in combined prims
 \ !! output-c-combined shouldn't use these names!  \ !! output-c-combined shouldn't use these names!
 : stack-type-name ( addr u "name" -- )  : stack-type-name ( addr u "name" -- )
Line 745  stack inst-stream IP Cell Line 781  stack inst-stream IP Cell
     prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items      prim prim-effect-out prim prim-effect-out-end @ ['] compute-offset-out map-items
     inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;      inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
   
   : init-simple { prim -- }
       \ much of the initialization is elsewhere
       ['] clear-prim-stacks-sync map-stacks ;
   
 : process-simple ( -- )  : process-simple ( -- )
     prim prim { W^ key } key cell      prim prim { W^ key } key cell
     combinations ['] constant insert-wordlist      combinations ['] constant insert-wordlist
Line 760  stack inst-stream IP Cell Line 800  stack inst-stream IP Cell
     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 774  stack inst-stream IP Cell Line 822  stack inst-stream IP Cell
 : 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 833  stack inst-stream IP Cell Line 889  stack inst-stream IP Cell
     stack-access-transform @ dup >r execute      stack-access-transform @ dup >r execute
     0 r> execute - ;      0 r> execute - ;
   
 : stack-pointer-update { stack -- }  : update-stack-pointer { stack n -- }
     \ and moves      n if \ this check is not necessary, gcc would do this for us
     \ stacks grow downwards  
     stack stack-diff ( in-out )  
     stack state-in  stack-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 inst-stream = if          stack inst-stream = if
             ." INC_IP(" 0 .r ." );" cr              ." INC_IP(" n 0 .r ." );" cr
         else          else
             stack stack-pointer 2@ type ."  += "              stack stack-pointer 2@ type ."  += "
             stack stack-update-transform 0 .r ." ;" cr              n stack stack-update-transform 0 .r ." ;" cr
         endif          endif
     endif      endif ;
     stack stack-moves ;  
   : stack-pointer-update { stack -- }
       \ and moves
       \ 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 state-in  stack-offset -
           stack state-out stack-offset + ( [in-in_offset]-[out-out_offset] )
           stack swap update-stack-pointer
           stack stack-moves
       endif ;
   
 : 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 913  variable tail-nextp2 \ xt to execute for Line 989  variable tail-nextp2 \ xt to execute for
   
 : output-label2 ( -- )  : output-label2 ( -- )
     ." LABEL2(" prim prim-c-name 2@ type ." )" cr      ." LABEL2(" prim prim-c-name 2@ type ." )" cr
     ." NEXT_P2;" cr ;      ." NEXT_P1_5;" cr
       ." LABEL3(" prim prim-c-name 2@ type ." )" cr
       ." DO_GOTO;" cr ;
   
 : output-c-tail1 { xt -- }  : output-c-tail1 { xt -- }
     \ the final part of the generated C code, with xt printing LABEL2 or not.      \ the final part of the generated C code, with xt printing LABEL2 or not.
     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 ;
   
   : output-c-vm-jump-tail ( -- )
       \ !! this functionality not yet implemented for superinstructions
       output-super-end
       print-debug-results
       stores
       fill-state 
       ." LABEL2(" prim prim-c-name 2@ type ." )" cr
       ." LABEL3(" prim prim-c-name 2@ type ." )" cr
       ." DO_GOTO;" cr ;
   
 : output-c-tail1-no-stores { xt -- }  : output-c-tail1-no-stores { xt -- }
     \ the final part of the generated C code for combinations      \ the final part of the generated C code for combinations
     output-super-end      output-super-end
Line 935  variable tail-nextp2 \ xt to execute for Line 1024  variable tail-nextp2 \ xt to execute for
     tail-nextp2 @ output-c-tail1 ;      tail-nextp2 @ output-c-tail1 ;
   
 : output-c-tail2 ( -- )  : output-c-tail2 ( -- )
     ['] output-label2 output-c-tail1 ;      prim prim-c-code 2@ s" VM_JUMP(" search nip nip if
           output-c-vm-jump-tail
       else
           ['] output-label2 output-c-tail1
       endif ;
   
 : output-c-tail-no-stores ( -- )  : output-c-tail-no-stores ( -- )
     tail-nextp2 @ output-c-tail1-no-stores ;      tail-nextp2 @ output-c-tail1-no-stores ;
Line 962  variable tail-nextp2 \ xt to execute for Line 1055  variable tail-nextp2 \ xt to execute for
   
 : print-entry ( -- )  : print-entry ( -- )
     ." LABEL(" prim prim-c-name 2@ type ." )" ;      ." LABEL(" prim prim-c-name 2@ type ." )" ;
       
 : output-c ( -- )   : prim-type ( addr u -- )
     print-entry ."  /* " prim prim-name 2@ type      \ print out a primitive, but avoid "*/"
       2dup s" */" search  nip nip  IF
           bounds ?DO  I c@ dup '* = IF  drop 'x  THEN  emit  LOOP
       ELSE  type  THEN ;
   
   : output-c ( -- )
       print-entry ."  /* " prim prim-name 2@ prim-type
     ."  ( " prim prim-stack-string 2@ type ." ) "      ."  ( " prim prim-stack-string 2@ type ." ) "
     state-in .state ." -- " state-out .state ."  */" cr      state-in .state ." -- " state-out .state ."  */" cr
     ." /* " prim prim-doc 2@ type ."  */" cr      ." /* " prim prim-doc 2@ type ."  */" cr
Line 1044  variable tail-nextp2 \ xt to execute for Line 1143  variable tail-nextp2 \ xt to execute for
     prim prim-branch?      prim prim-branch?
     prim prim-c-code 2@  s" SUPER_END" search nip nip 0<> or      prim prim-c-code 2@  s" SUPER_END" search nip nip 0<> or
     prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and      prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and
     negate 0 .r ." , /* " prim prim-name 2@ type ."  */" cr ;      negate 0 .r ." , /* " prim prim-name 2@ prim-type ."  */" cr ;
   
 : gen-arg-parm { item -- }  : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
Line 1372  variable reprocessed-num 0 reprocessed-n Line 1471  variable reprocessed-num 0 reprocessed-n
 : 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 1450  variable reprocessed-num 0 reprocessed-n Line 1552  variable reprocessed-num 0 reprocessed-n
   
 : output-part ( p -- )  : output-part ( p -- )
     to prim      to prim
     ." /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr      ." /* " prim prim-name 2@ prim-type ."  ( " prim prim-stack-string 2@ type ." ) */" cr
     ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging      ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging
     ." {" cr      ." {" cr
     print-declarations      print-declarations
Line 1558  variable reprocessed-num 0 reprocessed-n Line 1660  variable reprocessed-num 0 reprocessed-n
     \ prim-num @ 4 .r ." ," ;      \ prim-num @ 4 .r ." ," ;
   
 : output-name-comment ( -- )  : output-name-comment ( -- )
     ."  /* " prim prim-name 2@ type ."  */" ;      ."  /* " prim prim-name 2@ prim-type ."  */" ;
   
 variable offset-super2  0 offset-super2 ! \ offset into the super2 table  variable offset-super2  0 offset-super2 ! \ offset into the super2 table
   
Line 1698  nl-char singleton eof-char over add-memb Line 1800  nl-char singleton eof-char over add-memb
 (( letter (( letter || digit )) **  (( letter (( letter || digit )) **
 )) <- c-ident ( -- )  )) <- c-ident ( -- )
   
 (( ` # ?? (( letter || digit || ` : )) ++  (( ` # ?? (( letter || digit || ` : )) ++ (( ` . ` . ` . )) ??
 )) <- stack-ident ( -- )  )) <- stack-ident ( -- )
   
 (( nowhitebq nowhite ** ))  (( nowhitebq nowhite ** ))
Line 1753  Variable c-flag Line 1855  Variable c-flag
   
 (( ` \ comment-body nleof )) <- comment ( -- )  (( ` \ comment-body nleof )) <- comment ( -- )
   
 (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) **  (( {{ start }} stack-ident {{ end init-item1 }} white ** )) **
 <- stack-items  <- stack-items ( addr1 -- addr2 )
   
 (( {{ prim prim-effect-in }}  stack-items {{ prim prim-effect-in-end ! }}  (( {{ prim prim-effect-in }}  stack-items {{ prim prim-effect-in-end ! }}
    ` - ` - white **     ` - ` - white **
    {{ 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! }} )) ??

Removed from v.1.151  
changed lines
  Added in v.1.157


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>