--- gforth/prims2x0.6.2.fs 2009/01/18 18:41:55 1.3 +++ gforth/prims2x0.6.2.fs 2009/12/31 15:32:35 1.9 @@ -1,6 +1,6 @@ \ converts primitives to, e.g., C code -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2008 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2008,2009 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -54,6 +54,10 @@ \ for backwards compatibility, jaw require compat/strcomp.fs +[undefined] endtry-iferror [if] + : endtry-iferror postpone recover ; immediate compile-only +[then] + warnings off \ redefinitions of kernel words not present in gforth-0.6.1 @@ -71,7 +75,7 @@ warnings off include ./gray.fs 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). +9 constant max-stacks \ the max. number of stacks (including inst-stream). 255 constant maxchar maxchar 1+ constant eof-char #tab constant tab-char @@ -302,7 +306,9 @@ create sp-update-in max-stacks cells all create max-depths max-stacks max-combined 1+ * cells allot \ maximum depth at start of each part: array[parts] of array[stack] create max-back-depths max-stacks max-combined 1+ * cells allot -\ maximun depth from end of the combination to the start of the each part +\ maximum depth from end of the combination to the start of the each part +create depths max-stacks max-combined 1+ * cells allot +\ depth at the start of each part: array[parts] of array[stack] : s-c-max-depth ( nstack ncomponent -- addr ) max-stacks * + cells max-depths + ; @@ -310,6 +316,25 @@ create max-back-depths max-stacks max-co : s-c-max-back-depth ( nstack ncomponent -- addr ) max-stacks * + cells max-back-depths + ; +: s-c-depth ( nstack ncomponent -- addr ) + max-stacks * + cells depths + ; + +: print-depths1 { stack# xt -- } + num-combined @ 1+ 0 +do + stack# i xt execute @ 3 .r + loop ; + +: print-depths { stack# -- } + \ for debugging + cr ." depths: " stack# ['] s-c-depth print-depths1 + cr ." max-depths: " stack# ['] s-c-max-depth print-depths1 + cr ." max-back-depths: " stack# ['] s-c-max-back-depth print-depths1 ; + +: final-max-depth? { nstack ncomponent -- flag } + \ does the stack reach its final maxdepth before the component? + nstack ncomponent s-c-max-depth @ + nstack num-combined @ s-c-max-depth @ = ; + wordlist constant primitives : create-prim ( prim -- ) @@ -669,12 +694,14 @@ stack inst-stream IP Cell : flush-tos ( -- ) ['] flush-a-tos map-stacks1 ; -: fill-a-tos { stack -- } - stack stack-out @ 0= stack stack-in @ 0<> and - if - ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" - 2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr +: ?really-fill-a-tos { f stack -- } + f if + ." IF_" stack stack-pointer 2@ 2dup type ." TOS(" + 2dup type ." TOS = " type 0 stack normal-stack-access0 ." );" cr endif ; + +: fill-a-tos { stack -- } + stack stack-out @ 0= stack stack-in @ 0<> and stack ?really-fill-a-tos ; : fill-tos ( -- ) \ !! inst-stream for prefetching? @@ -692,18 +719,21 @@ stack inst-stream IP Cell stack-access-transform @ dup >r execute 0 r> execute - ; -: stack-pointer-update { stack -- } - \ stacks grow downwards - stack stack-diff - ?dup-if \ this check is not necessary, gcc would do this for us +: n-stack-pointer-update { n stack -- } + \ stack pointer update by n + n if \ this check is not necessary, gcc would do this for us stack inst-stream = if - ." INC_IP(" 0 .r ." );" cr + ." INC_IP(" n 0 .r ." );" cr else stack stack-pointer 2@ type ." += " - stack stack-update-transform 0 .r ." ;" cr + n stack stack-update-transform 0 .r ." ;" cr endif endif ; +: stack-pointer-update { stack -- } + \ stacks grow downwards + stack stack-diff stack n-stack-pointer-update ; + : stack-pointer-updates ( -- ) ['] stack-pointer-update map-stacks ; @@ -781,9 +811,6 @@ variable tail-nextp2 \ xt to execute for : output-c-tail2 ( -- ) ['] output-label2 output-c-tail1 ; -: output-c-tail-no-stores ( -- ) - tail-nextp2 @ output-c-tail1-no-stores ; - : output-c-tail2-no-stores ( -- ) ['] output-label2 output-c-tail1-no-stores ; @@ -1094,8 +1121,10 @@ variable tail-nextp2 \ xt to execute for current-depth i th ! loop ; -: copy-maxdepths ( n -- ) - max-depth max-depths rot max-stacks * th max-stacks cells move ; +: copy-maxdepths { n -- } + \ transfer current-depth to depths and max-depth to max-depths + max-depth max-depths n max-stacks * th max-stacks cells move + current-depth depths n max-stacks * th max-stacks cells move ; : add-prim ( addr u -- ) \ add primitive given by "addr u" to combined-prims @@ -1190,18 +1219,83 @@ variable tail-nextp2 \ xt to execute for print-debug-results stores ; +: stack-combined-tail-stores-limits { stack -- nupper nlower } + stack stack-number @ part-num @ 2dup 2>r s-c-max-depth @ + 2r> s-c-max-back-depth @ min + stack stack-depth - + stack stack-out @ ; + +: stack-combined-tail-stores { stack -- } + \ the top stack-out items of this part are stored elsewhere; so + \ this store everything between max-depth and stack-out, unless it + \ was stored previously (below back-max-depth) + stack stack-combined-tail-stores-limits +do + i stack normal-stack-access ." = " + i stack part-stack-access ." ;" cr + loop ; + +: combined-tail-stores ( -- ) + \ All the stores we have yet to do on an INST_TAIL that are the + \ result of earlier parts (and will be consumed by other parts in + \ the fallthrough path, and thus have not been stored in the + \ earlier part). + ['] stack-combined-tail-stores map-stacks ; + +: combined-tail-stack-pointer-update-n { stack -- } + stack stack-number @ { nstack } + nstack part-num @ 1+ s-c-depth @ ( nupdate-raw ) + \ correct for possible earlier update + nstack part-num @ 1+ final-max-depth? if + stack combined ['] stack-diff prim-context - + endif ; + +: combined-tail-stack-pointer-update { stack -- } + stack combined-tail-stack-pointer-update-n stack n-stack-pointer-update ; + +: combined-tail-stack-pointer-updates ( -- ) + ['] combined-tail-stack-pointer-update map-stacks ; + +: stack-combined-tail-stores-limits { stack -- nupper nlower } + stack stack-number @ part-num @ 2dup 2>r s-c-max-depth @ + 2r> s-c-max-back-depth @ min + stack stack-depth - + stack stack-out @ ; + +: tail-fill-a-tos { stack -- } + \ 1 print-depths + stack stack-number @ part-num @ 2dup s-c-max-depth @ { scmde } + 1+ 2dup s-c-max-depth @ { scmd } s-c-depth @ { scd } + scmd scd = scmd 0<> and \ normal fill (TOS consumed) + \ or it was stored to (what's now) sp[0] by an earlier part: + stack stack-combined-tail-stores-limits <= \ no stores in this tail + scmde 0= and \ there were stores to this stack earlier + stack combined-tail-stack-pointer-update-n 0<> and \ but not to spTOS + or stack ?really-fill-a-tos ; + +: tail-fill-tos ( -- ) + \ fill tos in INST_TAIL + ['] tail-fill-a-tos map-stacks1 ; + +: output-c-tail-no-stores ( -- ) + \ the final part of INST_TAIL + output-super-end + ." NEXT_P1;" cr + tail-fill-tos + tail-nextp2 perform ; + : output-combined-tail ( -- ) in-part @ >r in-part off + combined-tail-stack-pointer-updates part-output-c-tail + combined-tail-stores combined ['] output-c-tail-no-stores prim-context r> in-part ! ; : part-stack-pointer-updates ( -- ) next-stack-number @ 0 +do - i part-num @ 1+ s-c-max-depth @ dup - i num-combined @ s-c-max-depth @ = \ final depth - swap i part-num @ s-c-max-depth @ <> \ just reached now - part-num @ 0= \ first part + i part-num @ 1+ final-max-depth? \ reached afterwards + i part-num @ final-max-depth? 0= \ but not before + part-num @ 0= \ exception: first part or and if stacks i th @ stack-pointer-update endif @@ -1216,9 +1310,9 @@ variable tail-nextp2 \ xt to execute for part-fetches print-debug-args combined ['] part-stack-pointer-updates prim-context - 1 part-num +! prim add-depths \ !! right place? prim prim-c-code 2@ ['] output-combined-tail type-c-code + 1 part-num +! part-output-c-tail ." }" cr ;