Diff for /gforth/prims2x.fs between versions 1.144 and 1.152

version 1.144, 2003/10/09 14:15:19 version 1.152, 2004/12/31 13:23:58
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 267  struct% Line 267  struct%
     cell% 2* field prim-name      cell% 2* field prim-name
     cell% 2* field prim-wordset      cell% 2* field prim-wordset
     cell% 2* field prim-c-name      cell% 2* field prim-c-name
       cell% 2* field prim-c-name-orig \ for reprocessed prims, the original name
     cell% 2* field prim-doc      cell% 2* field prim-doc
     cell% 2* field prim-c-code      cell% 2* field prim-c-code
     cell% 2* field prim-forth-code      cell% 2* field prim-forth-code
Line 302  variable in-part \ true if processing a Line 303  variable in-part \ true if processing a
     r> to prim      r> to prim
     throw ;      throw ;
   
   : prim-c-name-2! ( c-addr u -- )
       2dup prim prim-c-name 2! prim prim-c-name-orig 2! ;
   
 1000 constant max-combined  1000 constant max-combined
 create combined-prims max-combined cells allot  create combined-prims max-combined cells allot
 variable num-combined  variable num-combined
Line 531  defer inst-stream-f ( -- stack ) Line 535  defer inst-stream-f ( -- stack )
 : store-single { item -- }  : store-single { item -- }
     item item-stack @ { stack }      item item-stack @ { stack }
     store-optimization @ in-part @ 0= and item same-as-in? and      store-optimization @ in-part @ 0= and item same-as-in? and
     item item-in-index  stack state-in  stack-reg 0= and \  in in memory?      item item-in-index  stack state-in  stack-reg       \  in reg/mem
     item item-out-index stack state-out stack-reg 0= and \ out in memory?      item item-out-index stack state-out stack-reg = and \ out reg/mem
     0= if      0= if
         item really-store-single cr          item really-store-single cr
     endif ;      endif ;
Line 712  stack inst-stream IP Cell Line 716  stack inst-stream IP Cell
         default-ss s state-sss i th !          default-ss s state-sss i th !
     loop ;      loop ;
   
   : .state ( state -- )
       0 >body - >name .name ;
   
 : set-ss ( ss stack state -- )  : set-ss ( ss stack state -- )
     state-sss swap stack-number @ th ! ;      state-sss swap stack-number @ th ! ;
   
Line 887  stack inst-stream IP Cell Line 894  stack inst-stream IP Cell
     endif      endif
     2drop ;      2drop ;
   
   
   defer output-nextp0
   :noname ( -- )
       ." NEXT_P0;" cr ;
   is output-nextp0
   
   defer output-nextp1
   :noname ( -- )
       ." NEXT_P1;" cr ;
   is output-nextp1
   
 : output-nextp2 ( -- )  : output-nextp2 ( -- )
     ." NEXT_P2;" cr ;      ." NEXT_P2;" cr ;
   
Line 901  variable tail-nextp2 \ xt to execute for Line 919  variable tail-nextp2 \ xt to execute for
     \ 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
     ." NEXT_P1;" cr      output-nextp1
     stores      stores
     fill-state       fill-state 
     xt execute ;      xt execute ;
Line 909  variable tail-nextp2 \ xt to execute for Line 927  variable tail-nextp2 \ xt to execute for
 : 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
     ." NEXT_P1;" cr      output-nextp1
     fill-state       fill-state 
     xt execute ;      xt execute ;
   
Line 946  variable tail-nextp2 \ xt to execute for Line 964  variable tail-nextp2 \ xt to execute for
     ." 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 ." ) "
       state-in .state ." -- " state-out .state ."  */" 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      output-nextp0
     spill-state      spill-state
     fetches      fetches
     print-debug-args      print-debug-args
Line 1095  variable tail-nextp2 \ xt to execute for Line 1115  variable tail-nextp2 \ xt to execute for
 : 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-c-prim-num ( -- )  defer output-c-prim-num ( -- )
   
   :noname ( -- )
     ." N_" prim prim-c-name 2@ type ." ," cr ;      ." N_" prim prim-c-name 2@ type ." ," cr ;
   is output-c-prim-num
   
 : output-forth ( -- )    : output-forth ( -- )  
     prim prim-forth-code @ 0=      prim prim-forth-code @ 0=
Line 1454  variable reprocessed-num 0 reprocessed-n Line 1477  variable reprocessed-num 0 reprocessed-n
     ." {" cr      ." {" cr
     ." DEF_CA" cr      ." DEF_CA" cr
     print-declarations-combined      print-declarations-combined
     ." NEXT_P0;" cr      output-nextp0
     spill-state      spill-state
     \ fetches \ now in parts      \ fetches \ now in parts
     \ print-debug-args      \ print-debug-args
Line 1494  variable reprocessed-num 0 reprocessed-n Line 1517  variable reprocessed-num 0 reprocessed-n
 \ This is intended as initializer for a structure like this  \ This is intended as initializer for a structure like this
   
 \  struct cost {  \  struct cost {
 \    int loads;       /* number of stack loads */  \    char loads;       /* number of stack loads */
 \    int stores;      /* number of stack stores */  \    char stores;      /* number of stack stores */
 \    int updates;     /* number of stack pointer updates */  \    char updates;     /* number of stack pointer updates */
 \    int offset;      /* offset into super2 table */  \    char branch;      /* is it a branch (SET_IP) */
 \    int length;      /* number of components */  \    char state_in;    /* state on entry */
   \    char state_out;   /* state on exit */
   \    short offset;     /* offset into super2 table */
   \    char length;      /* number of components */
 \  };  \  };
   
 \ How do you know which primitive or combined instruction this  \ How do you know which primitive or combined instruction this
Line 1528  variable reprocessed-num 0 reprocessed-n Line 1554  variable reprocessed-num 0 reprocessed-n
     loop ;      loop ;
   
 : output-num-part ( p -- )  : output-num-part ( p -- )
     ." N_" prim-c-name 2@ type ." ," ;      ." N_" prim-c-name-orig 2@ type ." ," ;
     \ prim-num @ 4 .r ." ," ;      \ prim-num @ 4 .r ." ," ;
   
 : output-name-comment ( -- )  : output-name-comment ( -- )
Line 1541  variable offset-super2  0 offset-super2 Line 1567  variable offset-super2  0 offset-super2
     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "      rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
     prim prim-branch? negate . ." ,"      prim prim-branch? negate . ." ,"
     state-in  state-number @ 2 .r ." ,"      state-in  state-number @ 2 .r ." ,"
     state-out state-number @ 2 .r ." ," ;      state-out state-number @ 2 .r ." ,"
       inst-stream stack-in @ 1 .r ." ,"
   ;
   
 : output-costs-gforth-simple ( -- )  : output-costs-gforth-simple ( -- )
     output-costs-prefix      output-costs-prefix
Line 1557  variable offset-super2  0 offset-super2 Line 1585  variable offset-super2  0 offset-super2
     output-name-comment      output-name-comment
     cr ;      cr ;
   
 : output-costs ( -- )  \  : output-costs ( -- )
     \ description of superinstructions and simple instructions  \      \ description of superinstructions and simple instructions
     ." {" prim compute-costs  \      ." {" prim compute-costs
     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"  \      rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
     offset-super2 @ 5 .r ." ,"  \      offset-super2 @ 5 .r ." ,"
     super2-length dup 2 .r ." }," offset-super2 +!  \      super2-length dup 2 .r ." ," offset-super2 +!
     output-name-comment  \      inst-stream stack-in @ 1 .r ." },"
     cr ;  \      output-name-comment
   \      cr ;
   
 : output-super2 ( -- )  : output-super2-simple ( -- )
     \ table of superinstructions without requirement for existing prefixes      prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if
     combined if  
         ['] output-num-part map-combined   
     else  
         prim output-num-part          prim output-num-part
     endif          output-name-comment
           cr
       endif ;   
     
   : output-super2-combined ( -- )
       ['] output-num-part map-combined 
     output-name-comment      output-name-comment
     cr ;         cr ;   
   
Line 1733  Variable c-flag Line 1764  Variable c-flag
 (( {{ prim create-prim }}  (( {{ prim create-prim }}
    ` ( 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 prim prim-c-name 2! }} )) ??        (( {{ start }}  c-ident {{ end 2dup 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 }}     {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }}
Line 1755  Variable c-flag Line 1786  Variable c-flag
       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 }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end        start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end
       2dup prim prim-name 2! prim prim-c-name 2! }}  white **        2dup prim prim-name 2! prim-c-name-2! }}  white **
    (( ` / white ** {{ start }} c-ident {{ end prim prim-c-name 2! }} white ** )) ??     (( ` / white ** {{ start }} c-ident {{ end prim-c-name-2! }} white ** )) ??
    (( simple-primitive || combined-primitive ))     (( simple-primitive || combined-primitive ))
    {{ 1 function-number +! }}     {{ 1 function-number +! }}
 )) <- primitive ( -- )  )) <- primitive ( -- )

Removed from v.1.144  
changed lines
  Added in v.1.152


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