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

version 1.110, 2002/08/20 07:59:01 version 1.116, 2002/09/22 14:21:30
Line 78  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 121  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 231  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 364  defer inst-stream-f ( -- stack ) Line 394  defer inst-stream-f ( -- stack )
     rdrop ;      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 647  stack inst-stream IP Cell Line 675  stack inst-stream IP Cell
 : type-c-code ( c-addr u xt -- )  : type-c-code ( c-addr u xt -- )
     \ like TYPE, but replaces "INST_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" INST_TAIL;" search          2dup s" INST_TAIL;" search
     while ( c-addr1 u1 c-addr3 u3 )      while ( c-addr1 u1 c-addr3 u3 )
Line 655  stack inst-stream IP Cell Line 685  stack inst-stream IP Cell
         2r> 10 /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 ( -- )
     ." LABEL(" 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-tail2  
  ." }" cr  
  cr  
 ;  ;
   
 : disasm-arg { item -- }  : disasm-arg { item -- }
Line 715  stack inst-stream IP Cell Line 744  stack inst-stream IP Cell
     endif      endif
     ." }" cr ;      ." }" cr ;
   
   : output-profile-part ( p )
       ."   add_inst(b, " quote
       prim-name 2@ type
       quote ." );" cr ;
       
 : output-profile-combined ( -- )  : output-profile-combined ( -- )
     \ 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
     num-combined @ 0 +do      ['] output-profile-part map-combined
         ."   add_inst(b, " quote  
         combined-prims i th @ prim-name 2@ type  
         quote ." );" cr  
     loop  
     ."   ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr      ."   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" SET_IP"    search nip nip
     combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SUPER_END" search nip nip or if      combined-prims num-combined @ 1- th @ prim-c-code 2@  s" SUPER_END" search nip nip or if
Line 808  stack inst-stream IP Cell Line 838  stack inst-stream IP Cell
 : 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 819  stack inst-stream IP Cell Line 852  stack inst-stream IP Cell
     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 919  stack inst-stream IP Cell Line 952  stack inst-stream IP Cell
     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 930  stack inst-stream IP Cell Line 964  stack inst-stream IP Cell
 : 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 1026  stack inst-stream IP Cell Line 1065  stack inst-stream IP Cell
     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 1064  stack inst-stream IP Cell Line 1098  stack inst-stream IP Cell
   
 \ 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 1078  stack inst-stream IP Cell Line 1115  stack inst-stream IP Cell
     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 1116  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 )

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


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