--- gforth/prims2x.fs 2001/04/30 13:48:56 1.95 +++ gforth/prims2x.fs 2002/08/20 07:59:01 1.110 @@ -53,23 +53,16 @@ warnings off -[IFUNDEF] vocabulary \ we are executed just with kernel image - \ load the rest that is needed - \ (require fails because this file is needed from a - \ different directory with the wordlibraries) -include ./search.fs -include ./extend.fs -include ./stuff.fs -[THEN] - -[IFUNDEF] environment? -include ./environ.fs +[IFUNDEF] try +include startup.fs [THEN] : struct% struct ; \ struct is redefined in gray -include ./gray.fs +warnings off +\ warnings on +include ./gray.fs 32 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 @@ -319,26 +312,26 @@ defer inst-stream-f ( -- stack ) item-stack @ stack-type @ type-c-name 2@ ; : fetch-single ( item -- ) - \ fetch a single stack item from its stack - >r - r@ item-name 2@ type - ." = vm_" r@ item-stack-type-name type - ." 2" r@ item-type @ print-type-prefix ." (" - r@ item-in-index r@ item-stack @ stack-access - ." );" cr - rdrop ; + \ fetch a single stack item from its stack + >r + ." vm_" r@ item-stack-type-name type + ." 2" r@ item-type @ print-type-prefix ." (" + r@ item-in-index r@ item-stack @ stack-access ." ," + r@ item-name 2@ type + ." );" cr + rdrop ; : fetch-double ( item -- ) - \ fetch a double stack item from its stack - >r - ." vm_two" - r@ item-stack-type-name type ." 2" - r@ item-type @ print-type-prefix ." (" - r@ item-name 2@ type ." , " - r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access - ." , " -1 under+ ." (Cell)" stack-access - ." );" cr - rdrop ; + \ fetch a double stack item from its stack + >r + ." vm_two" + r@ item-stack-type-name type ." 2" + r@ item-type @ print-type-prefix ." (" + r@ item-in-index r@ item-stack @ 2dup ." (Cell)" stack-access + ." , " -1 under+ ." (Cell)" stack-access + ." , " r@ item-name 2@ type + ." )" cr + rdrop ; : same-as-in? ( item -- f ) \ f is true iff the offset and stack of item is the same as on input @@ -362,12 +355,13 @@ defer inst-stream-f ( -- stack ) >r r@ item-stack @ stack-out @ r> item-offset @ - 1- ; : really-store-single ( item -- ) - >r - r@ item-out-index r@ item-stack @ stack-access ." = vm_" - r@ item-type @ print-type-prefix ." 2" - r@ item-stack-type-name type ." (" - r@ item-name 2@ type ." );" - rdrop ; + >r + ." vm_" + r@ item-type @ print-type-prefix ." 2" + r@ item-stack-type-name type ." (" + r@ item-name 2@ type ." ," + r@ item-out-index r@ item-stack @ stack-access ." );" + rdrop ; : store-single ( item -- ) >r @@ -392,7 +386,7 @@ defer inst-stream-f ( -- stack ) r@ item-name 2@ type ." , " r@ item-out-index r@ item-stack @ 2dup stack-access ." , " -1 under+ stack-access - ." );" cr + ." )" cr rdrop ; : single ( -- xt1 xt2 n ) @@ -430,7 +424,7 @@ wordlist constant prefixes stack r@ type-stack ! rdrop ; -: type-prefix ( xt1 xt2 n stack "prefix" -- ) +: type-prefix ( addr u xt1 xt2 n stack "prefix" -- ) get-current >r prefixes set-current create-type r> set-current does> ( item -- ) @@ -631,30 +625,40 @@ stack inst-stream IP Cell endif 2drop ; -: output-c-tail ( -- ) - \ the final part of the generated C code +: output-c-tail1 ( -- ) + \ the final part of the generated C code except LABEL2 and NEXT_P2 output-super-end print-debug-results ." NEXT_P1;" cr stores - fill-tos + fill-tos ; + +: output-c-tail ( -- ) + \ the final part of the generated C code, without LABEL2 + output-c-tail1 ." NEXT_P2;" ; +: output-c-tail2 ( -- ) + \ the final part of the generated C code, including LABEL2 + output-c-tail1 + ." LABEL2(" prim prim-c-name 2@ type ." )" cr + ." NEXT_P2;" cr ; + : type-c-code ( c-addr u xt -- ) - \ like TYPE, but replaces "TAIL;" with tail code produced by xt + \ like TYPE, but replaces "INST_TAIL;" with tail code produced by xt { xt } begin ( c-addr1 u1 ) - 2dup s" TAIL;" search + 2dup s" INST_TAIL;" search while ( c-addr1 u1 c-addr3 u3 ) 2dup 2>r drop nip over - type xt execute - 2r> 5 /string + 2r> 10 /string \ !! resync #line missing repeat 2drop type ; : print-entry ( -- ) - ." I_" prim prim-c-name 2@ type ." :" ; + ." LABEL(" prim prim-c-name 2@ type ." )" ; : output-c ( -- ) print-entry ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr @@ -672,17 +676,18 @@ stack inst-stream IP Cell ." #line " c-line @ . quote c-filename 2@ type quote cr prim prim-c-code 2@ ['] output-c-tail type-c-code ." }" cr - output-c-tail + output-c-tail2 ." }" cr cr ; : disasm-arg { item -- } item item-stack @ inst-stream = if - ." fputc(' ', vm_out); " - ." printarg_" item item-type @ print-type-prefix - ." ((" item item-type @ type-c-name 2@ type ." )" - ." ip[" item item-offset @ 1+ 0 .r ." ]);" cr + ." {" cr + item print-declaration + item fetch + item print-debug-arg + ." }" cr endif ; : disasm-args ( -- ) @@ -690,7 +695,7 @@ stack inst-stream IP Cell : output-disasm ( -- ) \ generate code for disassembling VM instructions - ." if (ip[0] == prim[" function-number @ 0 .r ." ]) {" cr + ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr ." fputs(" quote prim prim-name 2@ type quote ." , vm_out);" cr disasm-args ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr @@ -700,7 +705,7 @@ stack inst-stream IP Cell : output-profile ( -- ) \ generate code for postprocessing the VM block profile stuff ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr - ." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr + ." add_inst(b, " quote prim prim-name 2@ type quote ." );" cr ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr prim prim-c-code 2@ s" SET_IP" search nip nip prim prim-c-code 2@ s" SUPER_END" search nip nip or if @@ -710,6 +715,30 @@ stack inst-stream IP Cell endif ." }" cr ; +: output-profile-combined ( -- ) + \ generate code for postprocessing the VM block profile stuff + ." if (VM_IS_INST(*ip, " function-number @ 0 .r ." )) {" cr + num-combined @ 0 +do + ." add_inst(b, " quote + combined-prims i th @ prim-name 2@ type + quote ." );" cr + loop + ." ip += " inst-stream stack-in @ 1+ 0 .r ." ;" cr + combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SET_IP" search nip nip + combined-prims num-combined @ 1- th @ prim-c-code 2@ s" SUPER_END" search nip nip or if + ." return;" cr + else + ." goto _endif_;" cr + endif + ." }" cr ; + +: output-superend ( -- ) + \ output flag specifying whether the current word ends a dynamic superinst + prim prim-c-code 2@ s" SET_IP" search nip nip + prim prim-c-code 2@ s" SUPER_END" search nip nip or 0<> + prim prim-c-code 2@ s" SUPER_CONTINUE" search nip nip 0= and + negate 0 .r ." , /* " prim prim-name 2@ type ." */" cr ; + : gen-arg-parm { item -- } item item-stack @ inst-stream = if ." , " item item-type @ type-c-name 2@ type space @@ -774,7 +803,7 @@ stack inst-stream IP Cell \ cr ; : output-label ( -- ) - ." (Label)&&I_" prim prim-c-name 2@ type ." ," cr ; + ." INST_ADDR(" prim prim-c-name 2@ type ." )," cr ; : output-alias ( -- ) ( primitive-number @ . ." alias " ) ." Primitive " prim prim-name 2@ type cr ; @@ -806,6 +835,11 @@ stack inst-stream IP Cell name-line @ 0 .r ." ,0" cr ; +: output-vi-tag ( -- ) + name-filename 2@ type #tab emit + prim prim-name 2@ type #tab emit + ." /^" prim prim-name 2@ type ." *(/" cr ; + [IFDEF] documentation : register-doc ( -- ) prim prim-name 2@ documentation ['] create insert-wordlist @@ -875,9 +909,7 @@ stack inst-stream IP Cell \ #line 516 "./prim" \ n = n1+n2; \ } -\ NEXT_P1; \ _x_sp0 = (Cell)n; -\ NEXT_P2; \ } \ NEXT_P1; \ spTOS = (Cell)_x_sp0; @@ -1022,7 +1054,7 @@ stack inst-stream IP Cell \ print-debug-args stack-pointer-updates output-parts - output-c-tail + output-c-tail2 ." }" cr cr ; @@ -1133,6 +1165,8 @@ bl singleton tab-char over add-member nl-char singleton eof-char over add-member complement charclass nonl nl-char singleton eof-char over add-member char : over add-member complement charclass nocolonnl +nl-char singleton eof-char over add-member + char } over add-member complement charclass nobracenl bl 1+ maxchar .. char \ singleton complement intersection charclass nowhitebq bl 1+ maxchar .. charclass nowhite @@ -1144,7 +1178,7 @@ nl-char singleton eof-char over add-memb (( letter (( letter || digit )) ** )) <- c-ident ( -- ) -(( ` # ?? (( letter || digit || ` : )) ** +(( ` # ?? (( letter || digit || ` : )) ++ )) <- stack-ident ( -- ) (( nowhitebq nowhite ** )) @@ -1183,7 +1217,13 @@ Variable c-flag THEN }} )) <- if-comment -(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body +(( (( ` g || ` G )) {{ start }} nonl ** + {{ end + forth-flag @ IF ." group " type cr THEN + c-flag @ IF ." GROUP(" type ." )" cr THEN }} +)) <- group-comment + +(( (( eval-comment || forth-comment || c-comment || else-comment || if-comment || group-comment )) ?? nonl ** )) <- comment-body (( ` \ comment-body nleof )) <- comment ( -- ) @@ -1201,7 +1241,10 @@ Variable c-flag (( {{ start }} c-ident {{ end prim 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 }} (( nocolonnl nonl ** nleof white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }} + {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} + (( (( ` { nonl ** nleof (( (( nobracenl {{ line @ drop }} nonl ** )) ?? nleof )) ** ` } white ** nleof white ** )) + || (( nocolonnl nonl ** nleof white ** )) ** )) + {{ end prim prim-c-code 2! skipsynclines on }} (( ` : white ** nleof {{ start }} (( nonl ++ nleof white ** )) ++ {{ end prim prim-forth-code 2! }} )) ?? {{ process-simple }} @@ -1216,7 +1259,9 @@ Variable c-flag (( {{ make-prim to prim 0 to combined line @ name-line ! filename 2@ name-filename 2! function-number @ prim prim-num ! - start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }} white ++ + 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 +! }} )) <- primitive ( -- ) @@ -1227,7 +1272,7 @@ warnings @ [IF] [THEN] -\ run with out of box gforth 0.5.0 +\ run with gforth-0.5.0 (slurp-file is missing) [IFUNDEF] slurp-file : slurp-file ( c-addr1 u1 -- c-addr2 u2 ) \ c-addr1 u1 is the filename, c-addr2 u2 is the file's contents