Diff for /gforth/prims2x.fs between versions 1.111 and 1.115

version 1.111, 2002/08/20 16:59:01 version 1.115, 2002/09/22 09:54:19
Line 86  variable skipsynclines \ are sync lines Line 86  variable skipsynclines \ are sync lines
 skipsynclines on  skipsynclines on
 variable out-nls \ newlines in output (for output sync lines)  variable out-nls \ newlines in output (for output sync lines)
 0 out-nls !  0 out-nls !
   variable store-optimization \ use store optimization?
   store-optimization off
   
   
 : th ( addr1 n -- addr2 )  : th ( addr1 n -- addr2 )
     cells + ;      cells + ;
Line 247  variable in-part \ true if processing a Line 250  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 380  defer inst-stream-f ( -- stack ) Line 389  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 732  stack inst-stream IP Cell Line 739  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 825  stack inst-stream IP Cell Line 833  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 836  stack inst-stream IP Cell Line 847  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 1050  stack inst-stream IP Cell Line 1061  stack inst-stream IP Cell
 : 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 1078  stack inst-stream IP Cell Line 1087  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 1092  stack inst-stream IP Cell Line 1104  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 super {
   \    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 1130  print-token ! Line 1180  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.111  
changed lines
  Added in v.1.115


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