gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.123 and 1.142

-version 1.123, Fri Dec 27 15:51:28 2002 UTC
+version 1.142, Sun Aug 24 09:56:09 2003 UTC
  Line 1
  Line 1
  Line 1
  \ converts primitives to, e.g., C code
- \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
+ \ Copyright (C) 1995,1996,1997,1998,2000,2003 Free Software Foundation, Inc.
  \ This file is part of Gforth.
  Line 51
  Line 51
  Line 51
  \ (stack-in-index-xt and a test for stack==instruction-stream); there
  \ should be only one.
+ \ for backwards compatibility, jaw
+ require compat/strcomp.fs
  warnings off
+ \ redefinitions of kernel words not present in gforth-0.6.1
+ : latestxt lastcfa @ ;
+ : latest last @ ;
  [IFUNDEF] try
  include startup.fs
  [THEN]
- Line 63
+ Line 70
  Line 63
  Line 70
  \ warnings on
  include ./gray.fs
 constant max-effect \ number of things on one side of a stack effect
 constant max-stacks  \ the max. number of stacks (including inst-stream).
 constant maxchar
  maxchar 1+ constant eof-char
- Line 162
+ Line 169
  Line 162
  Line 169
      cell% 2* field stack-pointer \ stackpointer name
      cell%    field stack-type \ name for default type of stack items
      cell%    field stack-in-index-xt \ ( in-size item -- in-index )
+     cell%    field stack-access-transform \ ( nitem -- index )
  end-struct stack%
  struct%
- Line 197
+ Line 205
  Line 197
  Line 205
 next-stack-number +!
      r@ stack-type !
      save-mem r@ stack-pointer 2!
-     ['] stack-in-index r> stack-in-index-xt ! ;
+     ['] stack-in-index r@ stack-in-index-xt !
+     ['] noop r@ stack-access-transform !
+     rdrop ;
  : map-stacks { xt -- }
      \ perform xt for all stacks
- Line 319
+ Line 329
  Line 319
  Line 329
 variable name-filename
 variable last-name-filename
  Variable function-number 0 function-number !
+ Variable function-old 0 function-old !
+ : function-diff ( n -- )
+     ." GROUPADD(" function-number @ function-old @ - 0 .r ." )" cr
+     function-number @ function-old ! ;
+ : forth-fdiff ( -- )
+     function-number @ function-old @ - 0 .r ."  groupadd" cr
+     function-number @ function-old ! ;
  \ a few more set ops
- Line 333
+ Line 350
  Line 333
  Line 350
  \ stack access stuff
- : normal-stack-access1 ( n stack -- )
+ : normal-stack-access0 { n stack -- }
-     stack-pointer 2@ type
+     n stack stack-access-transform @ execute ." [" 0 .r ." ]" ;
-     dup
-     if
+ : normal-stack-access1 { n stack -- }
-         ." [" 0 .r ." ]"
+     stack stack-pointer 2@ type
+     n if
+         n stack normal-stack-access0
      else
-         drop ." TOS"
+         ." TOS"
      endif ;
  : normal-stack-access ( n stack -- )
- Line 603
+ Line 622
  Line 603
  Line 622
      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-pointer latestxt >body stack-name nextname make-stack ;
  stack inst-stream IP Cell
  ' inst-in-index inst-stream stack-in-index-xt !
- Line 626
+ Line 645
  Line 626
  Line 645
  : compute-offset-out ( addr1 addr2 -- )
      ['] stack-out compute-offset ;
- : clear-stack ( stack -- )
-     dup stack-in off stack-out off ;
  : compute-offsets ( -- )
-     ['] clear-stack map-stacks
+     prim prim-stacks-in  max-stacks cells erase
+     prim prim-stacks-out max-stacks cells erase
      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
      inst-stream stack-out @ 0= s" # can only be on the input side" ?print-error ;
- Line 645
+ Line 662
  Line 645
  Line 662
      stack stack-out @ 0<> stack stack-in @ 0= and
      if
          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
-dup type ." [0] = " type ." TOS);" cr
+dup type 0 stack normal-stack-access0 ."  = " type ." TOS);" cr
      endif ;
  : flush-tos ( -- )
- Line 655
+ Line 672
  Line 655
  Line 672
      stack stack-out @ 0= stack stack-in @ 0<> and
      if
          ." IF_" stack stack-pointer 2@ 2dup type ." TOS("
-dup type ." TOS = " type ." [0]);" cr
+dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr
      endif ;
  : fill-tos ( -- )
- Line 668
+ Line 685
  Line 668
  Line 685
  : fetches ( -- )
      prim prim-effect-in prim prim-effect-in-end @ ['] fetch map-items ;
+ : stack-update-transform ( n1 stack -- n2 )
+     \ n2 is the number by which the stack pointer should be
+     \ incremented to pop n1 items
+     stack-access-transform @ dup >r execute
+r> execute - ;
  : stack-pointer-update { stack -- }
      \ stacks grow downwards
      stack stack-diff
- Line 675
+ Line 698
  Line 675
  Line 698
          stack inst-stream = if
              ." INC_IP(" 0 .r ." );" cr
          else
-             stack stack-pointer 2@ type ."  += " 0 .r ." ;" cr
+             stack stack-pointer 2@ type ."  += "
+             stack stack-update-transform 0 .r ." ;" cr
          endif
      endif ;
- Line 724
+ Line 748
  Line 724
  Line 748
      endif
 drop ;
+ : output-nextp2 ( -- )
+     ." NEXT_P2;" cr ;
+ variable tail-nextp2 \ xt to execute for printing NEXT_P2 in INST_TAIL
+ ' output-nextp2 tail-nextp2 !
  : output-label2 ( -- )
      ." LABEL2(" prim prim-c-name 2@ type ." )" cr
      ." NEXT_P2;" cr ;
- Line 745
+ Line 775
  Line 745
  Line 775
      xt execute ;
  : output-c-tail ( -- )
-     ['] noop output-c-tail1 ;
+     tail-nextp2 @ output-c-tail1 ;
  : output-c-tail2 ( -- )
      ['] output-label2 output-c-tail1 ;
  : output-c-tail-no-stores ( -- )
-     ['] noop output-c-tail1-no-stores ;
+     tail-nextp2 @ output-c-tail1-no-stores ;
  : output-c-tail2-no-stores ( -- )
      ['] output-label2 output-c-tail1-no-stores ;
- Line 923
+ Line 953
  Line 923
  Line 953
      ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ;
  : output-c-prim-num ( -- )
-     ." #define N_" prim prim-c-name 2@ type prim prim-num @ 8 + 4 .r cr ;
+     ." N_" prim prim-c-name 2@ type ." ," cr ;
  : output-forth ( -- )
      prim prim-forth-code @ 0=
- Line 1143
+ Line 1173
  Line 1143
  Line 1173
  : print-item { n stack -- }
      \ print nth stack item name
      stack stack-type @ type-c-name 2@ type space
-     ." _" stack stack-pointer 2@ type n 0 .r ;
+     ." MAYBE_UNUSED _" stack stack-pointer 2@ type n 0 .r ;
  : print-declarations-combined ( -- )
      max-stacks 0 ?do
- Line 1248
+ Line 1278
  Line 1248
  Line 1278
  \    int loads;       /* number of stack loads */
  \    int stores;      /* number of stack stores */
  \    int updates;     /* number of stack pointer updates */
+ \    int offset;      /* offset into super2 table */
  \    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.
+ : super2-length ( -- n )
+     combined if
+         num-combined @
+     else
+     endif ;
  : 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
+     \ caching into account
-     \ other stuff
 max-stacks 0 +do
          p prim-stacks-in i th @ +
      loop
+     super2-length 1- - \ don't count instruction fetches of subsumed insts
 max-stacks 0 +do
          p prim-stacks-out i th @ +
      loop
-max-stacks 0 +do
+max-stacks 1 +do \ don't count ip updates, therefore "1 +do"
          p prim-stacks-in i th @ p prim-stacks-out i th @ <> -
      loop ;
  : output-num-part ( p -- )
-     prim-num @ 4 .r ." ," ;
+     ." N_" prim-c-name 2@ type ." ," ;
+     \ prim-num @ 4 .r ." ," ;
+ : output-name-comment ( -- )
+     ."  /* " prim prim-name 2@ type ."  */" ;
+ variable offset-super2  0 offset-super2 ! \ offset into the super2 table
+ : output-costs-gforth-simple ( -- )
+      ." {" prim compute-costs
+     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
+     prim output-num-part
+2 .r ." },"
+     output-name-comment
+     cr ;
+ : output-costs-gforth-combined ( -- )
+     ." {" prim compute-costs
+     rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , "
+     ." N_START_SUPER+" offset-super2 @ 5 .r ." ,"
+     super2-length dup 2 .r ." }," offset-super2 +!
+     output-name-comment
+     cr ;
  : output-costs ( -- )
+     \ description of superinstructions and simple instructions
      ." {" prim compute-costs
      rot 2 .r ." ," swap 2 .r ." ," 2 .r ." ,"
+     offset-super2 @ 5 .r ." ,"
+     super2-length dup 2 .r ." }," offset-super2 +!
+     output-name-comment
+     cr ;
+ : output-super2 ( -- )
+     \ table of superinstructions without requirement for existing prefixes
      combined if
-         num-combined @ 2 .r
+         ['] output-num-part map-combined
-         ." , ((int []){" ['] output-num-part map-combined ." })}, /* "
      else
-         ."  1, ((int []){" prim prim-num @ 4 .r ." })}, /* "
+         prim output-num-part
      endif
-     prim prim-name 2@ type ."  */"
+     output-name-comment
      cr ;
  \ the parser
- Line 1310
+ Line 1376
  Line 1310
  Line 1376
   getinput member? ;
  ' testchar? test-vector !
- : checksyncline ( -- )
+ : checksynclines ( -- )
      \ when input points to a newline, check if the next line is a
      \ sync line.  If it is, perform the appropriate actions.
-     rawinput @ >r
+     rawinput @ begin >r
      s" #line " r@ over compare if
          rdrop 1 line +! EXIT
      endif
- Line 1325
+ Line 1391
  Line 1325
  Line 1391
      endif
      dup c@ nl-char <> 0= s" sync line syntax" ?print-error
      skipsynclines @ if
-         dup char+ rawinput !
+             char+ dup rawinput !
          rawinput @ c@ cookedinput @ c!
      endif
-     drop ;
+     again ;
  : ?nextchar ( f -- )
      s" syntax error, wrong char" ?print-error
- Line 1337
+ Line 1403
  Line 1337
  Line 1403
 chars rawinput +!
 chars cookedinput +!
          nl-char = if
-             checksyncline
+             checksynclines
              rawinput @ line-start !
          endif
-         rawinput @ c@ cookedinput @ c!
+         rawinput @ c@
+         cookedinput @ c!
      endif ;
  : charclass ( set "name" -- )
- Line 1398
+ Line 1465
  Line 1398
  Line 1465
  )) <- c-comment ( -- )
  (( ` - nonl ** {{
-         forth-flag @ IF ." [ELSE]" cr THEN
+         forth-flag @ IF forth-fdiff ." [ELSE]" cr THEN
-         c-flag @ IF ." #else" cr THEN }}
+         c-flag @ IF
+             function-diff
+             ." #else /* " function-number @ 0 .r ."  */" cr THEN }}
  )) <- else-comment
  (( ` + {{ start }} nonl ** {{ end
          dup
          IF      c-flag @
-                 IF    ." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr
+             IF
+                 function-diff
+                 ." #ifdef HAS_" bounds ?DO  I c@ toupper emit  LOOP cr
                  THEN
                  forth-flag @
-                 IF  ." has? " type ."  [IF]"  cr THEN
+                 IF  forth-fdiff  ." has? " type ."  [IF]"  cr THEN
          ELSE    2drop
-             c-flag @      IF  ." #endif"  cr THEN
+             c-flag @      IF
-             forth-flag @  IF  ." [THEN]"  cr THEN
+                 function-diff  ." #endif" cr THEN
+             forth-flag @  IF  forth-fdiff  ." [THEN]"  cr THEN
          THEN }}
  )) <- if-comment
  (( (( ` g || ` G )) {{ start }} nonl **
     {{ end
-       forth-flag @ IF  ." group " type cr  THEN
+       forth-flag @ IF  forth-fdiff  ." group " type cr  THEN
-       c-flag @     IF  ." GROUP(" type ." )" cr  THEN }}
+       c-flag @     IF  function-diff
+           ." GROUP(" type ." , " function-number @ 0 .r ." )" cr  THEN }}
  )) <- group-comment
  (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body
- Line 1460
+ Line 1533
  Line 1460
  Line 1533
        start }} [ifdef] vmgen c-ident [else] forth-ident [then] {{ end
 dup 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 ( -- )
  (( (( comment || primitive || nl white ** )) ** eof ))
- Line 1485
+ Line 1559
  Line 1485
  Line 1559
      \ process the string at addr u
      over dup rawinput ! dup line-start ! cookedinput !
      + endrawinput !
-     checksyncline
+     checksynclines
      primitives2something ;
+ : unixify ( c-addr u1 -- c-addr u2 )
+     \ delete crs from the string
+     bounds tuck tuck ?do ( c-addr1 )
+         i c@ dup #cr <> if
+             over c! char+
+         else
+             drop
+         endif
+     loop
+     over - ;
  : process-file ( addr u xt-simple x-combined -- )
      output-combined ! output !
      save-mem 2dup filename 2!
-     slurp-file
+     slurp-file unixify
      warnings @ if
          ." ------------ CUT HERE -------------" cr  endif
      primfilter ;

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



Removed from v.1.123
 


changed lines


 
Added in v.1.142
 Legend:



Removed from v.1.123
 


changed lines


 
Added in v.1.142
-Removed from v.1.123
+Added in v.1.142

CVS Admin

gforth: gforth/prims2x.fs

Diff for /gforth/prims2x.fs between version 1.123 and 1.142

ViewCVS and CVS Help