--- gforth/prims2x.fs 2002/12/27 15:51:28 1.123 +++ gforth/prims2x.fs 2003/08/15 14:07:04 1.141 @@ -1,6 +1,6 @@ \ 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. @@ -51,8 +51,15 @@ \ (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] @@ -63,7 +70,7 @@ warnings off \ warnings on include ./gray.fs -32 constant max-effect \ number of things on one side of a stack effect +128 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). 255 constant maxchar maxchar 1+ constant eof-char @@ -162,6 +169,7 @@ struct% 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% @@ -197,7 +205,9 @@ create stacks max-stacks cells allot \ a 1 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 @@ -319,6 +329,13 @@ variable name-line 2variable name-filename 2variable 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 @@ -333,13 +350,15 @@ defer inst-stream-f ( -- stack ) \ stack access stuff -: normal-stack-access1 ( n stack -- ) - stack-pointer 2@ type - dup - if - ." [" 0 .r ." ]" +: normal-stack-access0 { n stack -- } + n stack stack-access-transform @ execute ." [" 0 .r ." ]" ; + +: normal-stack-access1 { n stack -- } + stack stack-pointer 2@ type + n if + n stack normal-stack-access0 else - drop ." TOS" + ." TOS" endif ; : normal-stack-access ( n stack -- ) @@ -603,7 +622,7 @@ wordlist constant type-names \ this is h 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 ! @@ -626,11 +645,9 @@ stack inst-stream IP Cell : 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 ; @@ -645,7 +662,7 @@ stack inst-stream IP Cell stack stack-out @ 0<> stack stack-in @ 0= and if ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" - 2dup type ." [0] = " type ." TOS);" cr + 2dup type 0 stack normal-stack-access0 ." = " type ." TOS);" cr endif ; : flush-tos ( -- ) @@ -655,7 +672,7 @@ stack inst-stream IP Cell stack stack-out @ 0= stack stack-in @ 0<> and if ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" - 2dup type ." TOS = " type ." [0]);" cr + 2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr endif ; : fill-tos ( -- ) @@ -668,6 +685,12 @@ stack inst-stream IP Cell : 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 + 0 r> execute - ; + : stack-pointer-update { stack -- } \ stacks grow downwards stack stack-diff @@ -675,7 +698,8 @@ stack inst-stream IP Cell 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 ; @@ -724,6 +748,12 @@ stack inst-stream IP Cell endif 2drop ; +: 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 ; @@ -745,13 +775,13 @@ stack inst-stream IP Cell 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 ; @@ -923,7 +953,7 @@ stack inst-stream IP Cell ( 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= @@ -1248,43 +1278,79 @@ stack inst-stream IP Cell \ 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 + 1 + 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 - \ other stuff + \ caching into account 0 max-stacks 0 +do p prim-stacks-in i th @ + loop + super2-length 1- - \ don't count instruction fetches of subsumed insts 0 max-stacks 0 +do p prim-stacks-out i th @ + loop - 0 max-stacks 0 +do + 0 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 + 1 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 - ." , ((int []){" ['] output-num-part map-combined ." })}, /* " + ['] output-num-part map-combined else - ." 1, ((int []){" prim prim-num @ 4 .r ." })}, /* " + prim output-num-part endif - prim prim-name 2@ type ." */" - cr ; + output-name-comment + cr ; \ the parser @@ -1310,25 +1376,25 @@ print-token ! 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 - s" #line " r@ over compare if - rdrop 1 line +! EXIT - endif - 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) - dup c@ bl = if - char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error - char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! - char+ - endif - dup c@ nl-char <> 0= s" sync line syntax" ?print-error - skipsynclines @ if - dup char+ rawinput ! - rawinput @ c@ cookedinput @ c! - endif - drop ; + rawinput @ begin >r + s" #line " r@ over compare if + rdrop 1 line +! EXIT + endif + 0. r> 6 chars + 20 >number drop >r drop line ! r> ( c-addr ) + dup c@ bl = if + char+ dup c@ [char] " <> 0= s" sync line syntax" ?print-error + char+ dup 100 [char] " scan drop swap 2dup - save-mem filename 2! + char+ + endif + dup c@ nl-char <> 0= s" sync line syntax" ?print-error + skipsynclines @ if + char+ dup rawinput ! + rawinput @ c@ cookedinput @ c! + endif + again ; : ?nextchar ( f -- ) s" syntax error, wrong char" ?print-error @@ -1337,10 +1403,11 @@ print-token ! 1 chars rawinput +! 1 chars cookedinput +! nl-char = if - checksyncline + checksynclines rawinput @ line-start ! endif - rawinput @ c@ cookedinput @ c! + rawinput @ c@ + cookedinput @ c! endif ; : charclass ( set "name" -- ) @@ -1398,27 +1465,33 @@ Variable c-flag )) <- c-comment ( -- ) (( ` - nonl ** {{ - forth-flag @ IF ." [ELSE]" cr THEN - c-flag @ IF ." #else" cr THEN }} + forth-flag @ IF forth-fdiff ." [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 - forth-flag @ IF ." [THEN]" cr THEN + c-flag @ IF + 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 - c-flag @ IF ." GROUP(" type ." )" cr THEN }} + forth-flag @ IF forth-fdiff ." 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 @@ -1460,7 +1533,8 @@ Variable c-flag 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 ( -- ) (( (( comment || primitive || nl white ** )) ** eof )) @@ -1485,13 +1559,24 @@ warnings @ [IF] \ 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 ;