--- gforth/prims2x.fs 2003/03/22 10:04:07 1.135 +++ gforth/prims2x.fs 2003/08/24 09:56:09 1.142 @@ -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] @@ -322,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 @@ -939,7 +953,7 @@ variable tail-nextp2 \ xt to execute for ( 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= @@ -1159,7 +1173,7 @@ variable tail-nextp2 \ xt to execute for : 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 @@ -1264,43 +1278,79 @@ variable tail-nextp2 \ xt to execute for \ 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 @@ -1415,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 ." , " function-number @ 0 .r ." )" 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 @@ -1477,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 ))