Diff for /gforth/prims2x.fs between versions 1.91 and 1.116

version 1.91, 2001/03/18 10:33:25 version 1.116, 2002/09/22 14:21:30
Line 41 Line 41
 \ regarding problem 1 above: It would be better (for over) to implement  \ regarding problem 1 above: It would be better (for over) to implement
 \       the alternative  \       the alternative
 \ store optimization for combined instructions.  \ store optimization for combined instructions.
 \ eliminate stack-cast (no longer used)  
   
 \ Design Uglyness:  \ Design Uglyness:
   
Line 54 Line 53
   
 warnings off  warnings off
   
 [IFUNDEF] vocabulary    \ we are executed just with kernel image  [IFUNDEF] try
                         \ load the rest that is needed  include startup.fs
                         \ (require fails because this file is needed from a  
                         \ different directory with the wordlibraries)  
 include ./search.fs                       
 include ./extend.fs  
 include ./stuff.fs  
 [THEN]  
   
 [IFUNDEF] environment?  
 include ./environ.fs  
 [THEN]  [THEN]
   
 : struct% struct ; \ struct is redefined in gray  : struct% struct ; \ struct is redefined in gray
   
 include ./gray.fs  warnings off
   \ warnings on
   
   include ./gray.fs
 32 constant max-effect \ number of things on one side of a stack effect  32 constant max-effect \ number of things on one side of a stack effect
 4 constant max-stacks  \ the max. number of stacks (including inst-stream).  4 constant max-stacks  \ the max. number of stacks (including inst-stream).
 255 constant maxchar  255 constant maxchar
Line 86  variable line-start \ pointer to start o Line 78  variable line-start \ pointer to start o
 0 line !  0 line !
 2variable filename \ filename of original input file  2variable filename \ filename of original input file
 0 0 filename 2!  0 0 filename 2!
   2variable out-filename \ filename of the output file (for sync lines)
   0 0 out-filename 2!
 2variable f-comment  2variable f-comment
 0 0 f-comment 2!  0 0 f-comment 2!
 variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?  variable skipsynclines \ are sync lines ("#line ...") invisible to the parser?
 skipsynclines on   skipsynclines on
   variable out-nls \ newlines in output (for output sync lines)
   0 out-nls !
   variable store-optimization \ use store optimization?
   store-optimization off
   
   variable include-skipped-insts
   \ does the threaded code for a combined instruction include the cells
   \ for the component instructions (true) or only the cells for the
   \ inline arguments (false)
   include-skipped-insts off
   
 : th ( addr1 n -- addr2 )  : th ( addr1 n -- addr2 )
     cells + ;      cells + ;
Line 129  skipsynclines on Line 133  skipsynclines on
             0              0
         recover endtry          recover endtry
         r> to outfile-id throw          r> to outfile-id throw
         abort          1 (bye) \ abort
     endif ;      endif ;
   
 : quote ( -- )  : quote ( -- )
     [char] " emit ;      [char] " emit ;
   
   \ count output lines to generate sync lines for output
   
   : count-nls ( addr u -- )
       bounds u+do
           i c@ nl-char = negate out-nls +!
       loop ;
   
   :noname ( addr u -- )
       2dup count-nls
       defers type ;
   is type
   
 variable output          \ xt ( -- ) of output word for simple primitives  variable output          \ xt ( -- ) of output word for simple primitives
 variable output-combined \ xt ( -- ) of output word for combined primitives  variable output-combined \ xt ( -- ) of output word for combined primitives
   
Line 142  struct% Line 158  struct%
     cell%    field stack-number \ the number of this stack      cell%    field stack-number \ the number of this stack
     cell% 2* field stack-pointer \ stackpointer name      cell% 2* field stack-pointer \ stackpointer name
     cell%    field stack-type \ name for default type of stack items      cell%    field stack-type \ name for default type of stack items
     cell% 2* field stack-cast \ cast string for assignments to stack elements  
     cell%    field stack-in-index-xt \ ( in-size item -- in-index )      cell%    field stack-in-index-xt \ ( in-size item -- in-index )
 end-struct stack%  end-struct stack%
   
Line 171  create stacks max-stacks cells allot \ a Line 186  create stacks max-stacks cells allot \ a
 : inst-in-index ( in-size item -- in-index )  : inst-in-index ( in-size item -- in-index )
     nip dup item-offset @ swap item-type @ type-size @ + 1- ;      nip dup item-offset @ swap item-type @ type-size @ + 1- ;
   
 : make-stack ( addr-ptr u1 type addr-cast u2 "stack-name" -- )  : make-stack ( addr-ptr u1 type "stack-name" -- )
       next-stack-number @ max-stacks < s" too many stacks" ?print-error
     create stack% %allot >r      create stack% %allot >r
     r@ stacks next-stack-number @ th !      r@ stacks next-stack-number @ th !
     next-stack-number @ r@ stack-number !  1 next-stack-number +!      next-stack-number @ r@ stack-number !
     save-mem r@ stack-cast 2!      1 next-stack-number +!
     r@ stack-type !      r@ stack-type !
     save-mem r@ stack-pointer 2!       save-mem r@ stack-pointer 2! 
     ['] stack-in-index r> stack-in-index-xt ! ;      ['] stack-in-index r> stack-in-index-xt ! ;
   
   : map-stacks { xt -- }
       \ perform xt for all stacks except inst-stream
       next-stack-number @ 1 +do
           stacks i th @ xt execute
       loop ;
   
 \ stack items  \ stack items
   
 : init-item ( addr u addr1 -- )  : init-item ( addr u addr1 -- )
Line 233  variable in-part \ true if processing a Line 255  variable in-part \ true if processing a
 create combined-prims max-combined cells allot  create combined-prims max-combined cells allot
 variable num-combined  variable num-combined
   
   : map-combined { xt -- }
       \ perform xt for all components of the current combined instruction
       num-combined @ 0 +do
           combined-prims i th @ xt execute
       loop ;
   
 table constant combinations  table constant combinations
   \ the keys are the sequences of pointers to primitives    \ the keys are the sequences of pointers to primitives
   
Line 314  defer inst-stream-f ( -- stack ) Line 342  defer inst-stream-f ( -- stack )
     item-stack @ stack-type @ type-c-name 2@ ;      item-stack @ stack-type @ type-c-name 2@ ;
   
 : fetch-single ( item -- )  : fetch-single ( item -- )
  \ fetch a single stack item from its stack      \ fetch a single stack item from its stack
  >r      >r
  r@ item-name 2@ type      ." vm_" r@ item-stack-type-name type
  ."  = vm_" r@ item-stack-type-name type      ." 2" r@ item-type @ print-type-prefix ." ("
  ." 2" r@ item-type @ print-type-prefix ." ("      r@ item-in-index r@ item-stack @ stack-access ." ,"
  r@ item-in-index r@ item-stack @ stack-access      r@ item-name 2@ type
  ." );" cr      ." );" cr
  rdrop ;       rdrop ; 
   
 : fetch-double ( item -- )  : fetch-double ( item -- )
  \ fetch a double stack item from its stack      \ fetch a double stack item from its stack
  >r      >r
  ." 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-name 2@ type ." , "      r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access
  r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access      ." , "                      -1 under+ ." (Cell)" stack-access
  ." , "                      -1 under+ ." (Cell)" stack-access      ." , " r@ item-name 2@ type
  ." );" cr      ." )" cr
  rdrop ;      rdrop ;
   
 : 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
Line 357  defer inst-stream-f ( -- stack ) Line 385  defer inst-stream-f ( -- stack )
     >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;      >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ;
   
 : really-store-single ( item -- )  : really-store-single ( item -- )
  >r      >r
  r@ item-out-index r@ item-stack @ stack-access ."  = vm_"      ." vm_"
  r@ item-type @ print-type-prefix ." 2"      r@ item-type @ print-type-prefix ." 2"
  r@ item-stack-type-name type ." ("      r@ item-stack-type-name type ." ("
  r@ item-name 2@ type ." );"      r@ item-name 2@ type ." ,"
  rdrop ;      r@ item-out-index r@ item-stack @ stack-access ." );"
       rdrop ;
   
 : store-single ( item -- )  : store-single ( item -- )
  >r      >r
  r@ same-as-in?      store-optimization @ r@ same-as-in? and if
  if          r@ item-in-index 0= r@ item-out-index 0= xor if
    r@ item-in-index 0= r@ item-out-index 0= xor              ." IF_" r@ item-stack @ stack-pointer 2@ type
    if              ." TOS(" r@ really-store-single ." );" cr
        ." IF_" r@ item-stack @ stack-pointer 2@ type          endif
        ." TOS(" r@ really-store-single ." );" cr      else
    endif          r@ really-store-single cr
  else      endif
    r@ really-store-single cr      rdrop ;
  endif  
  rdrop ;  
   
 : store-double ( item -- )  : store-double ( item -- )
 \ !! store optimization is not performed, because it is not yet needed  \ !! store optimization is not performed, because it is not yet needed
Line 387  defer inst-stream-f ( -- stack ) Line 414  defer inst-stream-f ( -- stack )
  r@ item-name 2@ type ." , "   r@ item-name 2@ type ." , "
  r@ item-out-index r@ item-stack @ 2dup stack-access   r@ item-out-index r@ item-stack @ 2dup stack-access
  ." , "                       -1 under+ stack-access   ." , "                       -1 under+ stack-access
  ." );" cr   ." )" cr
  rdrop ;   rdrop ;
   
 : single ( -- xt1 xt2 n )  : single ( -- xt1 xt2 n )
Line 425  wordlist constant prefixes Line 452  wordlist constant prefixes
     stack r@ type-stack !      stack r@ type-stack !
     rdrop ;      rdrop ;
   
 : type-prefix ( xt1 xt2 n stack "prefix" -- )  : type-prefix ( addr u xt1 xt2 n stack "prefix" -- )
     create-type      get-current >r prefixes set-current
       create-type r> set-current
 does> ( item -- )  does> ( item -- )
     \ initialize item      \ initialize item
     { item typ }      { item typ }
Line 476  does> ( item -- ) Line 504  does> ( item -- )
     prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;      prim prim-effect-out prim prim-effect-out-end @ ['] print-declaration map-items ;
           
 : stack-prefix ( stack "prefix" -- )  : stack-prefix ( stack "prefix" -- )
       get-current >r prefixes set-current
     name tuck nextname create ( stack length ) 2,      name tuck nextname create ( stack length ) 2,
       r> set-current
 does> ( item -- )  does> ( item -- )
     2@ { item stack prefix-length }      2@ { item stack prefix-length }
     item item-name 2@ prefix-length /string item item-name 2!      item item-name 2@ prefix-length /string item item-name 2!
Line 485  does> ( item -- ) Line 515  does> ( item -- )
   
 \ 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!
 s" Cell"  single 0 create-type w  : stack-type-name ( addr u "name" -- )
 s" Float" single 0 create-type r      single 0 create-type ;
   
 s" sp" save-mem w s" (Cell)" make-stack data-stack   wordlist constant type-names \ this is here just to meet the requirement
 s" fp" save-mem r s" "       make-stack fp-stack                      \ that a type be a word; it is never used for lookup
 s" rp" save-mem w s" (Cell)" make-stack return-stack  
 s" IP" save-mem w s" error don't use # on results" make-stack inst-stream  : stack ( "name" "stack-pointer" "type" -- )
       \ define stack
       name { d: stack-name }
       name { d: stack-pointer }
       name { d: stack-type }
       get-current type-names set-current
       stack-type 2dup nextname stack-type-name
       set-current
       stack-pointer lastxt >body stack-name nextname make-stack ;
   
   stack inst-stream IP Cell
 ' inst-in-index inst-stream stack-in-index-xt !  ' inst-in-index inst-stream stack-in-index-xt !
 ' inst-stream <is> inst-stream-f  ' inst-stream <is> inst-stream-f
 \ !! initialize stack-in and stack-out  \ !! initialize stack-in and stack-out
Line 516  s" IP" save-mem w s" error don't use # o Line 556  s" IP" save-mem w s" error don't use # o
     dup stack-in off stack-out off ;      dup stack-in off stack-out off ;
   
 : compute-offsets ( -- )  : compute-offsets ( -- )
     data-stack clear-stack  fp-stack clear-stack return-stack clear-stack      ['] clear-stack map-stacks
     inst-stream clear-stack      inst-stream clear-stack
     prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items      prim prim-effect-in  prim prim-effect-in-end  @ ['] compute-offset-in  map-items
     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
Line 536  s" IP" save-mem w s" error don't use # o Line 576  s" IP" save-mem w s" error don't use # o
     endif ;      endif ;
   
 : flush-tos ( -- )  : flush-tos ( -- )
     data-stack   flush-a-tos      ['] flush-a-tos map-stacks ;
     fp-stack     flush-a-tos  
     return-stack flush-a-tos ;  
   
 : fill-a-tos { stack -- }  : fill-a-tos { stack -- }
     stack stack-out @ 0= stack stack-in @ 0<> and      stack stack-out @ 0= stack stack-in @ 0<> and
Line 549  s" IP" save-mem w s" error don't use # o Line 587  s" IP" save-mem w s" error don't use # o
   
 : fill-tos ( -- )  : fill-tos ( -- )
     \ !! inst-stream for prefetching?      \ !! inst-stream for prefetching?
     fp-stack     fill-a-tos      ['] fill-a-tos map-stacks ;
     data-stack   fill-a-tos  
     return-stack fill-a-tos ;  
   
 : fetch ( addr -- )  : fetch ( addr -- )
     dup item-type @ type-fetch @ execute ;      dup item-type @ type-fetch @ execute ;
Line 573  s" IP" save-mem w s" error don't use # o Line 609  s" IP" save-mem w s" error don't use # o
   
 : stack-pointer-updates ( -- )  : stack-pointer-updates ( -- )
     inst-pointer-update      inst-pointer-update
     data-stack   stack-pointer-update      ['] stack-pointer-update map-stacks ;
     fp-stack     stack-pointer-update  
     return-stack stack-pointer-update ;  
   
 : store ( item -- )  : store ( item -- )
 \ f is true if the item should be stored  \ f is true if the item should be stored
Line 619  s" IP" save-mem w s" error don't use # o Line 653  s" IP" save-mem w s" error don't use # o
     endif      endif
     2drop ;      2drop ;
   
 : output-c-tail ( -- )  : output-c-tail1 ( -- )
     \ the final part of the generated C code      \ the final part of the generated C code except LABEL2 and NEXT_P2
     output-super-end      output-super-end
     print-debug-results      print-debug-results
     ." NEXT_P1;" cr      ." NEXT_P1;" cr
     stores      stores
     fill-tos      fill-tos ;
   
   : output-c-tail ( -- )
       \ the final part of the generated C code, without LABEL2
       output-c-tail1
     ." NEXT_P2;" ;      ." NEXT_P2;" ;
   
   : output-c-tail2 ( -- )
       \ the final part of the generated C code, including LABEL2
       output-c-tail1
       ." LABEL2(" prim prim-c-name 2@ type ." )" cr
       ." NEXT_P2;" cr ;
   
 : type-c-code ( c-addr u xt -- )  : type-c-code ( c-addr u xt -- )
     \ like TYPE, but replaces "TAIL;" with tail code produced by xt      \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt
     { xt }      { xt }
       ." {" cr
       ." #line " c-line @ . quote c-filename 2@ type quote cr
     begin ( c-addr1 u1 )      begin ( c-addr1 u1 )
         2dup s" TAIL;" search          2dup s" INST_TAIL;" search
     while ( c-addr1 u1 c-addr3 u3 )      while ( c-addr1 u1 c-addr3 u3 )
         2dup 2>r drop nip over - type          2dup 2>r drop nip over - type
         xt execute          xt execute
         2r> 5 /string          2r> 10 /string
         \ !! resync #line missing          \ !! resync #line missing
     repeat      repeat
     2drop type ;      2drop type
       ." #line " out-nls @ 2 + . quote out-filename 2@ type quote cr
       ." }" cr ;
   
 : print-entry ( -- )  : print-entry ( -- )
     ." I_" prim prim-c-name 2@ type ." :" ;      ." LABEL(" prim prim-c-name 2@ type ." )" ;
           
 : output-c ( -- )   : output-c ( -- ) 
  print-entry ."  /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr      print-entry ."  /* " prim prim-name 2@ type ."  ( " prim prim-stack-string 2@ type ." ) */" cr
  ." /* " prim prim-doc 2@ type ."  */" cr      ." /* " prim prim-doc 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
  ." DEF_CA" cr      ." DEF_CA" cr
  print-declarations      print-declarations
  ." NEXT_P0;" cr      ." NEXT_P0;" cr
  flush-tos      flush-tos
  fetches      fetches
  print-debug-args      print-debug-args
  stack-pointer-updates      stack-pointer-updates
  ." {" cr      prim prim-c-code 2@ ['] output-c-tail type-c-code
  ." #line " c-line @ . quote c-filename 2@ type quote cr      output-c-tail2
  prim prim-c-code 2@ ['] output-c-tail type-c-code      ." }" cr
  ." }" cr      cr
  output-c-tail  
  ." }" cr  
  cr  
 ;  ;
   
 : disasm-arg { item -- }  : disasm-arg { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
         ."   fputc(' ', vm_out); "          ." {" cr
         ." printarg_" item item-type @ print-type-prefix          item print-declaration
         ." ((" item item-type @ type-c-name 2@ type ." )"          item fetch
         ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr          item print-debug-arg
           ." }" cr
     endif ;      endif ;
   
 : disasm-args ( -- )  : disasm-args ( -- )
Line 678  s" IP" save-mem w s" error don't use # o Line 724  s" IP" save-mem w s" error don't use # o
   
 : output-disasm ( -- )  : output-disasm ( -- )
     \ generate code for disassembling VM instructions      \ generate code for disassembling VM instructions
     ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr      ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
     ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr      ."   fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr
     disasm-args      disasm-args
     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr      ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
Line 688  s" IP" save-mem w s" error don't use # o Line 734  s" IP" save-mem w s" error don't use # o
 : output-profile ( -- )  : output-profile ( -- )
     \ generate code for postprocessing the VM block profile stuff      \ generate code for postprocessing the VM block profile stuff
     ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr      ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
     ."   add_inst(b, " quote  prim prim-name 2@ type quote ." );" cr      ."   add_inst(b, " quote prim prim-name 2@ type quote ." );" cr
     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr      ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
     prim prim-c-code 2@  s" SET_IP"    search nip nip      prim prim-c-code 2@  s" SET_IP"    search nip nip
     prim prim-c-code 2@  s" SUPER_END" search nip nip or if      prim prim-c-code 2@  s" SUPER_END" search nip nip or if
Line 698  s" IP" save-mem w s" error don't use # o Line 744  s" IP" save-mem w s" error don't use # o
     endif      endif
     ." }" cr ;      ." }" cr ;
   
   : output-profile-part ( p )
       ."   add_inst(b, " quote
       prim-name 2@ type
       quote ." );" cr ;
       
   : output-profile-combined ( -- )
       \ generate code for postprocessing the VM block profile stuff
       ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr
       ['] output-profile-part map-combined
       ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr
       combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SET_IP"    search nip nip
       combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SUPER_END" search nip nip or if
           ."   return;" cr
       else
           ."   goto _endif_;" cr
       endif
       ." }" cr ;
   
   : output-superend ( -- )
       \ output flag specifying whether the current word ends a dynamic superinst
       prim prim-c-code 2@  s" SET_IP"    search nip nip
       prim prim-c-code 2@  s" SUPER_END" search nip nip or 0<>
       prim prim-c-code 2@  s" SUPER_CONTINUE" search nip nip 0= and
       negate 0 .r ." , /* " prim prim-name 2@ type ."  */" cr ;
   
 : gen-arg-parm { item -- }  : gen-arg-parm { item -- }
     item item-stack @ inst-stream = if      item item-stack @ inst-stream = if
         ." , " item item-type @ type-c-name 2@ type space          ." , " item item-type @ type-c-name 2@ type space
Line 733  s" IP" save-mem w s" error don't use # o Line 804  s" IP" save-mem w s" error don't use # o
 : output-forthname ( -- )  : output-forthname ( -- )
   '" emit prim prim-name 2@ type '" emit ." ," cr ;    '" emit prim prim-name 2@ type '" emit ." ," cr ;
   
 : output-c-func ( -- )  \  : output-c-func ( -- )
 \ used for word libraries  \  \ used for word libraries
     ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP)      /* " prim prim-name 2@ type  \      ." Cell * I_" prim prim-c-name 2@ type ." (Cell *SP, Cell **FP)      /* " prim prim-name 2@ type
     ."  ( " prim prim-stack-string 2@ type ."  ) */" cr  \      ."  ( " prim prim-stack-string 2@ type ."  ) */" cr
     ." /* " prim prim-doc 2@ type ."  */" cr  \      ." /* " prim prim-doc 2@ type ."  */" cr
     ." NAME(" quote prim prim-name 2@ type quote ." )" cr  \      ." NAME(" quote prim prim-name 2@ type quote ." )" cr
     \ debugging  \      \ debugging
     ." {" cr  \      ." {" cr
     print-declarations  \      print-declarations
     inst-stream  stack-used? IF ." Cell *ip=IP;" cr THEN  \      \ !! don't know what to do about that
     data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN  \      inst-stream  stack-used? IF ." Cell *ip=IP;" cr THEN
     fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN  \      data-stack   stack-used? IF ." Cell *sp=SP;" cr THEN
     return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN  \      fp-stack     stack-used? IF ." Cell *fp=*FP;" cr THEN
     flush-tos  \      return-stack stack-used? IF ." Cell *rp=*RP;" cr THEN
     fetches  \      flush-tos
     stack-pointer-updates  \      fetches
     fp-stack   stack-used? IF ." *FP=fp;" cr THEN  \      stack-pointer-updates
     ." {" cr  \      fp-stack   stack-used? IF ." *FP=fp;" cr THEN
     ." #line " c-line @ . quote c-filename 2@ type quote cr  \      ." {" cr
     prim prim-c-code 2@ type  \      ." #line " c-line @ . quote c-filename 2@ type quote cr
     ." }" cr  \      prim prim-c-code 2@ type
     stores  \      ." }" cr
     fill-tos  \      stores
     ." return (sp);" cr  \      fill-tos
     ." }" cr  \      ." return (sp);" cr
     cr ;  \      ." }" cr
   \      cr ;
   
 : output-label ( -- )    : output-label ( -- )  
     ." (Label)&&I_" prim prim-c-name 2@ type ." ," cr ;      ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ;
   
 : output-alias ( -- )   : output-alias ( -- ) 
     ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;      ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
   
   : output-prim-num ( -- )
       prim prim-num @ 8 + 4 .r space prim prim-name 2@ type cr ;
   
 : output-forth ( -- )    : output-forth ( -- )  
     prim prim-forth-code @ 0=      prim prim-forth-code @ 0=
     IF          \ output-alias      IF          \ output-alias
Line 777  s" IP" save-mem w s" error don't use # o Line 852  s" IP" save-mem w s" error don't use # o
     THEN ;      THEN ;
   
 : output-tag-file ( -- )  : output-tag-file ( -- )
     name-filename 2@ last-name-filename 2@ compare if      name-filename 2@ last-name-filename 2@ str= 0= if
         name-filename 2@ last-name-filename 2!          name-filename 2@ last-name-filename 2!
         #ff emit cr          #ff emit cr
         name-filename 2@ type          name-filename 2@ type
Line 793  s" IP" save-mem w s" error don't use # o Line 868  s" IP" save-mem w s" error don't use # o
     name-line @ 0 .r      name-line @ 0 .r
     ." ,0" cr ;      ." ,0" cr ;
   
   : output-vi-tag ( -- )
       name-filename 2@ type #tab emit
       prim prim-name 2@ type #tab emit
       ." /^" prim prim-name 2@ type ."  *(/" cr ;
   
 [IFDEF] documentation  [IFDEF] documentation
 : register-doc ( -- )  : register-doc ( -- )
     prim prim-name 2@ documentation ['] create insert-wordlist      prim prim-name 2@ documentation ['] create insert-wordlist
Line 862  s" IP" save-mem w s" error don't use # o Line 942  s" IP" save-mem w s" error don't use # o
 \  #line 516 "./prim"  \  #line 516 "./prim"
 \  n = n1+n2;  \  n = n1+n2;
 \  }  \  }
 \  NEXT_P1;  
 \  _x_sp0 = (Cell)n;  \  _x_sp0 = (Cell)n;
 \  NEXT_P2;  
 \  }  \  }
 \  NEXT_P1;  \  NEXT_P1;
 \  spTOS = (Cell)_x_sp0;  \  spTOS = (Cell)_x_sp0;
Line 874  s" IP" save-mem w s" error don't use # o Line 952  s" IP" save-mem w s" error don't use # o
     prim to combined      prim to combined
     0 num-combined !      0 num-combined !
     current-depth max-stacks cells erase      current-depth max-stacks cells erase
       include-skipped-insts @ current-depth 0 th !
     max-depth     max-stacks cells erase      max-depth     max-stacks cells erase
     min-depth     max-stacks cells erase      min-depth     max-stacks cells erase
     prim prim-effect-in  prim prim-effect-in-end  !      prim prim-effect-in  prim prim-effect-in-end  !
Line 885  s" IP" save-mem w s" error don't use # o Line 964  s" IP" save-mem w s" error don't use # o
 : min! ( n addr -- )  : min! ( n addr -- )
     tuck @ min swap ! ;      tuck @ min swap ! ;
   
   : inst-stream-correction ( nin1 nstack -- nin2 )
       0= if
           include-skipped-insts @ -
       endif ;
   
 : add-depths { p -- }  : add-depths { p -- }
     \ combine stack effect of p with *-depths      \ combine stack effect of p with *-depths
     max-stacks 0 ?do      max-stacks 0 ?do
         current-depth i th @          current-depth i th @
         p prim-stacks-in  i th @ +          p prim-stacks-in  i th @ + i inst-stream-correction
         dup max-depth i th max!          dup max-depth i th max!
         p prim-stacks-out i th @ -          p prim-stacks-out i th @ -
         dup min-depth i th min!          dup min-depth i th min!
Line 981  s" IP" save-mem w s" error don't use # o Line 1065  s" IP" save-mem w s" error don't use # o
     part-fetches      part-fetches
     print-debug-args      print-debug-args
     prim add-depths \ !! right place?      prim add-depths \ !! right place?
     ." {" cr  
     ." #line " c-line @ . quote c-filename 2@ type quote cr  
     prim prim-c-code 2@ ['] output-combined-tail type-c-code      prim prim-c-code 2@ ['] output-combined-tail type-c-code
     ." }" cr  
     part-output-c-tail      part-output-c-tail
     ." }" cr ;      ." }" cr ;
   
 : output-parts ( -- )  : output-parts ( -- )
     prim >r in-part on      prim >r in-part on
     current-depth max-stacks cells erase      current-depth max-stacks cells erase
     num-combined @ 0 +do      ['] output-part map-combined
         combined-prims i th @ output-part  
     loop  
     in-part off      in-part off
     r> to prim ;      r> to prim ;
   
Line 1009  s" IP" save-mem w s" error don't use # o Line 1088  s" IP" save-mem w s" error don't use # o
     \ print-debug-args      \ print-debug-args
     stack-pointer-updates      stack-pointer-updates
     output-parts      output-parts
     output-c-tail      output-c-tail2
     ." }" cr      ." }" cr
     cr ;      cr ;
   
Line 1019  s" IP" save-mem w s" error don't use # o Line 1098  s" IP" save-mem w s" error don't use # o
   
 \ peephole optimization rules  \ peephole optimization rules
   
   \ data for a simple peephole optimizer that always tries to combine
   \ the currently compiled instruction with the last one.
   
 \ in order for this to work as intended, shorter combinations for each  \ in order for this to work as intended, shorter combinations for each
 \ length must be present, and the longer combinations must follow  \ length must be present, and the longer combinations must follow
 \ shorter ones (this restriction may go away in the future).  \ shorter ones (this restriction may go away in the future).
       
 : output-peephole ( -- )  : output-peephole ( -- )
     combined-prims num-combined @ 1- cells combinations search-wordlist      combined-prims num-combined @ 1- cells combinations search-wordlist
     s" the prefix for this combination must be defined earlier" ?print-error      s" the prefix for this superinstruction must be defined earlier" ?print-error
     ." {"      ." {"
     execute prim-num @ 5 .r ." ,"      execute prim-num @ 5 .r ." ,"
     combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"      combined-prims num-combined @ 1- th @ prim-num @ 5 .r ." ,"
Line 1033  s" IP" save-mem w s" error don't use # o Line 1115  s" IP" save-mem w s" error don't use # o
     combined prim-c-name 2@ type ."  */"      combined prim-c-name 2@ type ."  */"
     cr ;      cr ;
   
 : output-forth-peephole ( -- )  
     combined-prims num-combined @ 1- cells combinations search-wordlist  
     s" the prefix for this combination must be defined earlier" ?print-error  
     execute prim-num @ 5 .r  
     combined-prims num-combined @ 1- th @ prim-num @ 5 .r  
     combined prim-num @ 5 .r ."  prim, \ "  
     combined prim-c-name 2@ type  
     cr ;  
   
   \ cost and superinstruction data for a sophisticated combiner (e.g.,
   \ shortest path)
   
   \ This is intended as initializer for a structure like this
   
   \  struct cost {
   \    int loads;       /* number of stack loads */
   \    int stores;      /* number of stack stores */
   \    int updates;     /* number of stack pointer updates */
   \    int length;      /* number of components */
   \    int *components; /* array of vm_prim indexes of components */
   \  };
   
   \ How do you know which primitive or combined instruction this
   \ structure refers to?  By the order of cost structures, as in most
   \ other cases.
   
   : compute-costs { p -- nloads nstores nupdates }
       \ compute the number of loads, stores, and stack pointer updates
       \ of a primitive or combined instruction; does not take TOS
       \ caching into account, nor that IP updates are combined with
       \ other stuff
       0 max-stacks 0 +do
           p prim-stacks-in i th @ +
       loop
       0 max-stacks 0 +do
           p prim-stacks-out i th @ +
       loop
       0 max-stacks 0 +do
           p prim-stacks-in i th @ p prim-stacks-out i th @ <> -
       loop ;
   
   : output-num-part ( p -- )
       prim-num @ 4 .r ." ," ;
   
   : output-costs ( -- )
       ." {" prim compute-costs
       rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
       combined if
           num-combined @ 2 .r
           ." , ((int []){" ['] output-num-part map-combined ." })}, /* "
       else
           ."  1, ((int []){" prim prim-num @ 4 .r ." })}, /* "
       endif
       prim prim-name 2@ type ."  */"
       cr ;
   
 \ the parser  \ the parser
   
Line 1071  print-token ! Line 1191  print-token !
     \ when input points to a newline, check if the next line is a      \ when input points to a newline, check if the next line is a
     \ sync line.  If it is, perform the appropriate actions.      \ sync line.  If it is, perform the appropriate actions.
     rawinput @ >r      rawinput @ >r
     s" #line " r@ over compare 0<> if      s" #line " r@ over str= 0= if
         rdrop 1 line +! EXIT          rdrop 1 line +! EXIT
     endif      endif
     0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )      0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr )
Line 1120  bl singleton tab-char over add-member Line 1240  bl singleton tab-char over add-member
 nl-char singleton eof-char over add-member complement   charclass nonl  nl-char singleton eof-char over add-member complement   charclass nonl
 nl-char singleton eof-char over add-member  nl-char singleton eof-char over add-member
     char : over add-member complement                   charclass nocolonnl      char : over add-member complement                   charclass nocolonnl
   nl-char singleton eof-char over add-member
       char } over add-member complement                   charclass nobracenl
 bl 1+ maxchar .. char \ singleton complement intersection  bl 1+ maxchar .. char \ singleton complement intersection
                                                         charclass nowhitebq                                                          charclass nowhitebq
 bl 1+ maxchar ..                                        charclass nowhite  bl 1+ maxchar ..                                        charclass nowhite
Line 1131  nl-char singleton eof-char over add-memb Line 1253  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 1170  Variable c-flag Line 1292  Variable c-flag
         THEN }}          THEN }}
 )) <- if-comment  )) <- if-comment
   
 (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body  (( (( ` g || ` G )) {{ start }} nonl **
      {{ end
         forth-flag @ IF  ." group " type cr  THEN
         c-flag @     IF  ." GROUP(" type ." )" cr  THEN }}
   )) <- group-comment
   
   (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
   
 (( ` \ comment-body nleof )) <- comment ( -- )  (( ` \ comment-body nleof )) <- comment ( -- )
   
Line 1188  Variable c-flag Line 1316  Variable c-flag
       (( {{ start }}  c-ident {{ end prim prim-c-name 2! }} )) ??        (( {{ start }}  c-ident {{ end prim prim-c-name 2! }} )) ??
    )) ??  nleof     )) ??  nleof
    (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??     (( ` " ` "  {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ??
    {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl **  nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }}     {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}
      (( (( ` { nonl ** nleof (( (( nobracenl {{ line @ drop }} nonl ** )) ?? nleof )) ** ` } white ** nleof white ** ))
      || (( nocolonnl nonl **  nleof white ** )) ** ))
      {{ end prim prim-c-code 2! skipsynclines on }}
    (( ` :  white ** nleof     (( ` :  white ** nleof
       {{ start }} (( nonl ++  nleof white ** )) ++ {{ end prim prim-forth-code 2! }}        {{ start }} (( nonl ++  nleof white ** )) ++ {{ end prim prim-forth-code 2! }}
    )) ?? {{ process-simple }}     )) ?? {{ process-simple }}
Line 1203  Variable c-flag Line 1334  Variable c-flag
 (( {{ make-prim to prim 0 to combined  (( {{ make-prim to prim 0 to combined
       line @ name-line ! filename 2@ name-filename 2!        line @ name-line ! filename 2@ name-filename 2!
       function-number @ prim prim-num !        function-number @ prim prim-num !
       start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }}  white ++        start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end
         2dup prim prim-name 2! prim prim-c-name 2! }}  white **
      (( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ??
    (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}     (( simple-primitive || combined-primitive )) {{ 1 function-number +! }}
 )) <- primitive ( -- )  )) <- primitive ( -- )
   
Line 1213  warnings @ [IF] Line 1346  warnings @ [IF]
 .( parser generated ok ) cr  .( parser generated ok ) cr
 [THEN]  [THEN]
   
   
   \ run with gforth-0.5.0 (slurp-file is missing)
   [IFUNDEF] slurp-file
   : slurp-file ( c-addr1 u1 -- c-addr2 u2 )
       \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents
       r/o bin open-file throw >r
       r@ file-size throw abort" file too large"
       dup allocate throw swap
       2dup r@ read-file throw over <> abort" could not read whole file"
       r> close-file throw ;
   [THEN]
   
 : primfilter ( addr u -- )  : primfilter ( addr u -- )
     \ process the string at addr u      \ process the string at addr u
     over dup rawinput ! dup line-start ! cookedinput !      over dup rawinput ! dup line-start ! cookedinput !

Removed from v.1.91  
changed lines
  Added in v.1.116


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