--- gforth/prims2x.fs 2003/10/09 20:25:59 1.145 +++ gforth/prims2x.fs 2005/01/26 21:24:15 1.155 @@ -1,6 +1,6 @@ \ 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. @@ -267,6 +267,7 @@ struct% cell% 2* field prim-name cell% 2* field prim-wordset 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-c-code cell% 2* field prim-forth-code @@ -302,6 +303,9 @@ variable in-part \ true if processing a r> to prim throw ; +: prim-c-name-2! ( c-addr u -- ) + 2dup prim prim-c-name 2! prim prim-c-name-orig 2! ; + 1000 constant max-combined create combined-prims max-combined cells allot variable num-combined @@ -531,8 +535,8 @@ defer inst-stream-f ( -- stack ) : store-single { item -- } item item-stack @ { stack } 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-out-index stack state-out stack-reg 0= and \ out in memory? + item item-in-index stack state-in stack-reg \ in reg/mem + item item-out-index stack state-out stack-reg = and \ out reg/mem 0= if item really-store-single cr endif ; @@ -712,6 +716,9 @@ stack inst-stream IP Cell default-ss s state-sss i th ! loop ; +: .state ( state -- ) + 0 >body - >name .name ; + : set-ss ( ss stack state -- ) state-sss swap stack-number @ th ! ; @@ -906,7 +913,9 @@ variable tail-nextp2 \ xt to execute for : output-label2 ( -- ) ." LABEL2(" prim prim-c-name 2@ type ." )" cr - ." NEXT_P2;" cr ; + ." NEXT_P1_5;" cr + ." LABEL3(" prim prim-c-name 2@ type ." )" cr + ." DO_GOTO;" cr ; : output-c-tail1 { xt -- } \ the final part of the generated C code, with xt printing LABEL2 or not. @@ -917,6 +926,16 @@ variable tail-nextp2 \ xt to execute for fill-state xt execute ; +: output-c-vm-jump-tail ( -- ) + \ !! this functionality not yet implemented for superinstructions + output-super-end + print-debug-results + stores + fill-state + ." LABEL2(" prim prim-c-name 2@ type ." )" cr + ." LABEL3(" prim prim-c-name 2@ type ." )" cr + ." DO_GOTO;" cr ; + : output-c-tail1-no-stores { xt -- } \ the final part of the generated C code for combinations output-super-end @@ -928,7 +947,11 @@ variable tail-nextp2 \ xt to execute for tail-nextp2 @ output-c-tail1 ; : output-c-tail2 ( -- ) - ['] output-label2 output-c-tail1 ; + prim prim-c-code 2@ s" VM_JUMP(" search nip nip if + output-c-vm-jump-tail + else + ['] output-label2 output-c-tail1 + endif ; : output-c-tail-no-stores ( -- ) tail-nextp2 @ output-c-tail1-no-stores ; @@ -955,9 +978,17 @@ variable tail-nextp2 \ xt to execute for : print-entry ( -- ) ." LABEL(" prim prim-c-name 2@ type ." )" ; - + +: prim-type ( addr u -- ) + \ print out a primitive, but avoid "*/" + 2dup s" */" search nip nip IF + bounds ?DO I c@ dup '* = IF drop 'x THEN emit LOOP + ELSE type THEN ; + : output-c ( -- ) - print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr + print-entry ." /* " prim prim-name 2@ prim-type + ." ( " prim prim-stack-string 2@ type ." ) " + state-in .state ." -- " state-out .state ." */" cr ." /* " prim prim-doc 2@ type ." */" cr ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging ." {" cr @@ -1035,7 +1066,7 @@ variable tail-nextp2 \ xt to execute for prim prim-branch? prim prim-c-code 2@ s" SUPER_END" search nip nip 0<> or prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and - negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ; + negate 0 .r ." , /* " prim prim-name 2@ prim-type ." */" cr ; : gen-arg-parm { item -- } item item-stack @ inst-stream = if @@ -1106,8 +1137,11 @@ variable tail-nextp2 \ xt to execute for : output-alias ( -- ) ( 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 ; +is output-c-prim-num : output-forth ( -- ) prim prim-forth-code @ 0= @@ -1438,7 +1472,7 @@ variable reprocessed-num 0 reprocessed-n : output-part ( p -- ) to prim - ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr + ." /* " prim prim-name 2@ prim-type ." ( " prim prim-stack-string 2@ type ." ) */" cr ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging ." {" cr print-declarations @@ -1505,11 +1539,14 @@ variable reprocessed-num 0 reprocessed-n \ This is intended as initializer for a structure like this \ struct cost { -\ 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 */ +\ char loads; /* number of stack loads */ +\ char stores; /* number of stack stores */ +\ char updates; /* number of stack pointer updates */ +\ char branch; /* is it a branch (SET_IP) */ +\ 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 @@ -1539,11 +1576,11 @@ variable reprocessed-num 0 reprocessed-n loop ; : output-num-part ( p -- ) - ." N_" prim-c-name 2@ type ." ," ; + ." N_" prim-c-name-orig 2@ type ." ," ; \ prim-num @ 4 .r ." ," ; : output-name-comment ( -- ) - ." /* " prim prim-name 2@ type ." */" ; + ." /* " prim prim-name 2@ prim-type ." */" ; variable offset-super2 0 offset-super2 ! \ offset into the super2 table @@ -1552,7 +1589,9 @@ variable offset-super2 0 offset-super2 rot 2 .r ." ," swap 2 .r ." ," 2 .r ." , " prim prim-branch? negate . ." ," 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-prefix @@ -1568,22 +1607,25 @@ variable offset-super2 0 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-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 +! +\ inst-stream stack-in @ 1 .r ." }," +\ output-name-comment +\ cr ; -: output-super2 ( -- ) - \ table of superinstructions without requirement for existing prefixes - combined if - ['] output-num-part map-combined - else +: output-super2-simple ( -- ) + prim prim-c-name 2@ prim prim-c-name-orig 2@ d= if prim output-num-part - endif + output-name-comment + cr + endif ; + +: output-super2-combined ( -- ) + ['] output-num-part map-combined output-name-comment cr ; @@ -1744,7 +1786,7 @@ Variable c-flag (( {{ prim create-prim }} ` ( white ** {{ start }} stack-effect {{ end prim prim-stack-string 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 (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nleof )) ?? {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} @@ -1766,8 +1808,8 @@ Variable c-flag line @ name-line ! filename 2@ name-filename 2! function-number @ prim prim-num ! 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 ** )) ?? + 2dup prim prim-name 2! prim-c-name-2! }} white ** + (( ` / white ** {{ start }} c-ident {{ end prim-c-name-2! }} white ** )) ?? (( simple-primitive || combined-primitive )) {{ 1 function-number +! }} )) <- primitive ( -- )