gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.154 and 1.158

-version 1.154, Tue Jan 25 22:16:29 2005 UTC
+version 1.158, Thu Jul 28 19:15:00 2005 UTC
  Line 231
  Line 231
  Line 231
      rdrop ;
  : map-stacks { xt -- }
-     \ perform xt for all stacks
+     \ perform xt ( stack -- ) for all stacks
      next-stack-number @ 0 +do
          stacks i th @ xt execute
      loop ;
  : 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
          stacks i th @ xt execute
      loop ;
  Line 246
  Line 246
  Line 246
  : init-item ( addr u addr1 -- )
      \ initialize item at addr1 with name addr u
-     \ !! remove stack prefix
+     \ the stack prefix is removed by the stack-prefix
      dup item% %size erase
      item-name 2! ;
  Line 280
  Line 280
  Line 280
      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-out \ number of out items per stack
+     cell% max-stacks * field prim-stacks-sync \ sync flag per stack
  end-struct prim%
  : make-prim ( -- prim )
- Line 350
+ Line 351
  Line 350
  Line 351
      \ address of number of stack items in effect out
      stack-number @ cells prim prim-stacks-out + ;
+ : stack-prim-stacks-sync ( stack -- addr )
+     prim prim-stacks-sync swap stack-number @ th ;
  \ global vars
  variable c-line
 variable c-filename
- Line 505
+ Line 509
  Line 505
  Line 509
  : same-as-in? ( item -- f )
   \ f is true iff the offset and stack of item is the same as on input
   >r
+     r@ item-stack @ stack-prim-stacks-sync @ if
+         rdrop false exit
+     endif
   r@ item-first @ if
       rdrop false exit
   endif
- Line 616
+ Line 623
  Line 616
  Line 623
          endif
          -1 s+loop
      \ we did not find a type, abort
+         abort
      false s" unknown prefix" ?print-error ;
  : declaration ( item -- )
- Line 649
+ Line 657
  Line 649
  Line 657
      stack item item-stack !
      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
+ : ... ( 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
+         drop ['] 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
+dup s" ..." search nip nip if ( addr1 addr u )
+...-item item-stack ! \ initialize to prefixless
+dup ...-item item-name 2!
+         ...-item rot rot execute-prefix ( addr1 )
+     else
+pick init-item item% %size +
+     endif ;
  \ types pointed to by stacks for use in combined prims
  \ !! output-c-combined shouldn't use these names!
  : stack-type-name ( addr u "name" -- )
- Line 745
+ Line 785
  Line 745
  Line 785
      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 ;
+ : init-simple { prim -- }
+     \ much of the initialization is elsewhere
+     ['] clear-prim-stacks-sync map-stacks ;
  : process-simple ( -- )
      prim prim { W^ key } key cell
      combinations ['] constant insert-wordlist
- Line 760
+ Line 804
  Line 760
  Line 804
      stack state-in  stack-state-items stack stack-in  @ - 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 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-state-items ( items )
-     dup stack unused-stack-items - - +do
+     dup stack spill-stack-items + +do
          \ loop through the bottom items
          stack stack-pointer 2@ type
          i offset - stack normal-stack-access0 ."  = "
- Line 774
+ Line 826
  Line 774
  Line 826
  : spill-state ( -- )
      ['] 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 -- }
      stack state-out stack-offset { offset }
      stack state-out stack-state-items ( items )
-     dup stack unused-stack-items - + +do
+     dup stack fill-stack-items + +do
          \ loop through the bottom items
          i stack state-out normal-stack-access1 ."  = "
          stack stack-pointer 2@ type
- Line 833
+ Line 893
  Line 833
  Line 893
      stack-access-transform @ dup >r execute
 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 -- }
      \ 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] )
-     ?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-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 -- )
  \ f is true if the item should be stored
  \ f is false if the store is probably not necessary
- Line 922
+ Line 1002
  Line 922
  Line 1002
      output-super-end
      print-debug-results
      output-nextp1
+     stack-pointer-updates2
      stores
      fill-state
      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 -- }
      \ the final part of the generated C code for combinations
      output-super-end
- Line 937
+ Line 1028
  Line 937
  Line 1028
      tail-nextp2 @ output-c-tail1 ;
  : 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 ( -- )
      tail-nextp2 @ output-c-tail1-no-stores ;
- Line 1380
+ Line 1475
  Line 1380
  Line 1475
  : compute-default-state-out ( n-in -- n-out )
      \ for the current prim
      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 ;
  : gen-prim-states ( prim -- )
- Line 1706
+ Line 1804
  Line 1706
  Line 1804
  (( letter (( letter || digit )) **
  )) <- c-ident ( -- )
- (( ` # ?? (( letter || digit || ` : )) ++
+ (( ` . ` . ` .
+ )) <- sync-stack ( -- )
+ (( ` # ?? (( letter || digit || ` : )) ++ sync-stack ??
+ || sync-stack
  )) <- stack-ident ( -- )
  (( nowhitebq nowhite ** ))
- Line 1761
+ Line 1863
  Line 1761
  Line 1863
  (( ` \ 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 ! }}
     ` - ` - white **
     {{ prim prim-effect-out }} stack-items {{ prim prim-effect-out-end ! }}
  )) <- stack-effect ( -- )
- (( {{ prim create-prim }}
+ (( {{ prim create-prim prim init-simple }}
     ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 2! }} ` ) white **
     (( {{ start }} forth-ident {{ end prim prim-wordset 2! }} white **
        (( {{ start }}  c-ident {{ end 2dup prim-c-name-2! }} )) ??

-Generate output suitable for use with a patch program
+Legend:



Removed from v.1.154
 


changed lines


 
Added in v.1.158
 Legend:



Removed from v.1.154
 


changed lines


 
Added in v.1.158
-Removed from v.1.154
+Added in v.1.158

CVS Admin

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.154 and 1.158

ViewCVS and CVS Help