--- gforth/prims2x.fs 2001/02/07 09:58:46 1.78 +++ gforth/prims2x.fs 2001/02/09 20:15:31 1.80 @@ -40,6 +40,17 @@ \ add the store optimization for doubles \ regarding problem 1 above: It would be better (for over) to implement \ the alternative +\ store optimization for combined instructions. +\ eliminate stack-cast (no longer used) + +\ Design Uglyness: + +\ - global state (values, variables) in connection with combined instructions. + +\ - index computation is different for instruction-stream and the +\ stacks; there are two mechanisms for dealing with that +\ (stack-in-index-xt and a test for stack==instruction-stream); there +\ should be only one. warnings off @@ -208,7 +219,18 @@ end-struct prim% s" " p prim-doc 2! s" " p prim-forth-code 2! s" " p prim-wordset 2! p ; -0 value prim +0 value prim \ in combined prims either combined or a part +0 value combined \ in combined prims the combined prim +variable in-part \ true if processing a part + in-part off + +1000 constant max-combined +create combined-prims max-combined cells allot +variable num-combined + +create current-depth max-stacks cells allot +create max-depth max-stacks cells allot +create min-depth max-stacks cells allot wordlist constant primitives @@ -242,10 +264,9 @@ Variable function-number 0 function-numb : complement ( set1 -- set2 ) empty ['] bit-equivalent binary-set-operation ; -\ types +\ stack access stuff -: stack-access ( n stack -- ) - \ print a stack access at index n of stack +: normal-stack-access ( n stack -- ) stack-pointer 2@ type dup if @@ -254,6 +275,31 @@ Variable function-number 0 function-numb drop ." TOS" endif ; +\ forward declaration for inst-stream (breaks cycle in definitions) +defer inst-stream-f ( -- stack ) + +: part-stack-access { n stack -- } + \ print _, x=inst-stream? n : maxdepth-currentdepth-n-1 + ." _" stack stack-pointer 2@ type + stack stack-number @ { stack# } + current-depth stack# th @ n + { access-depth } + stack inst-stream-f = if + access-depth + else + combined prim-stacks-in stack# th @ + assert( dup max-depth stack# th @ = ) + access-depth - 1- + endif + 0 .r ; + +: stack-access ( n stack -- ) + \ print a stack access at index n of stack + in-part @ if + part-stack-access + else + normal-stack-access + endif ; + : item-in-index { item -- n } \ n is the index of item (in the in-effect) item item-stack @ dup >r stack-in @ ( in-size r:stack ) @@ -441,6 +487,7 @@ s" fp" save-mem float-type s" " ma s" rp" save-mem cell-type s" (Cell)" make-stack return-stack s" IP" save-mem cell-type s" error don't use # on results" make-stack inst-stream ' inst-in-index inst-stream stack-in-index-xt ! +' inst-stream inst-stream-f \ !! initialize stack-in and stack-out \ offset computation @@ -775,15 +822,8 @@ s" IP" save-mem cell-type s" error don' \ spTOS = (Cell)_x_sp0; \ NEXT_P2; -1000 constant max-combined -create combined-prims max-combined cells allot -variable num-combined - -create current-depth max-stacks cells allot -create max-depth max-stacks cells allot -create min-depth max-stacks cells allot - : init-combined ( -- ) + prim to combined 0 num-combined ! current-depth max-stacks cells erase max-depth max-stacks cells erase @@ -856,8 +896,8 @@ create min-depth max-stacks cells al : 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 ; + stack stack-type @ type-c-name 2@ type space + ." _" stack stack-pointer 2@ type n 0 .r ; : print-declarations-combined ( -- ) max-stacks 0 ?do @@ -865,13 +905,36 @@ create min-depth max-stacks cells al i stacks j th @ print-item ." ;" cr loop loop ; - + +: part-fetches ( -- ) + fetches ; + +: part-output-c-tail ( -- ) + output-c-tail ; + +: output-part ( p -- ) + to prim + ." /* " prim prim-name 2@ type ." ( " prim prim-stack-string 2@ type ." ) */" cr + ." NAME(" quote prim prim-name 2@ type quote ." )" cr \ debugging + ." {" cr + print-declarations + part-fetches + print-debug-args + prim add-depths \ !! right place? + ." {" cr + ." #line " c-line @ . quote c-filename 2@ type quote cr + prim prim-c-code 2@ type-c \ !! deal with TAIL + ." }" cr + part-output-c-tail + ." }" cr ; + : output-parts ( -- ) - prim >r + prim >r in-part on + current-depth max-stacks cells erase num-combined @ 0 +do - combined-prims i th @ to prim - output-c + combined-prims i th @ output-part loop + in-part off r> to prim ; : output-c-combined ( -- ) @@ -976,7 +1039,7 @@ bl 1+ maxchar .. char " singleton eof-char over add-member complement charclass noquote nl-char singleton charclass nl eof-char singleton charclass eof - +nl-char singleton eof-char over add-member charclass nleof (( letter (( letter || digit )) ** )) <- c-ident ( -- ) @@ -1022,7 +1085,7 @@ Variable c-flag (( (( eval-comment || forth-comment || c-comment || else-comment || if-comment )) ?? nonl ** )) <- comment-body -(( ` \ comment-body nl )) <- comment ( -- ) +(( ` \ comment-body nleof )) <- comment ( -- ) (( {{ start }} stack-ident {{ end 2 pick init-item item% %size + }} white ** )) ** <- stack-items @@ -1036,21 +1099,21 @@ Variable c-flag ` ( 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! }} )) ?? - )) ?? nl - (( ` " ` " {{ start }} (( noquote ++ ` " )) ++ {{ end 1- prim prim-doc 2! }} ` " white ** nl )) ?? - {{ skipsynclines off line @ c-line ! filename 2@ c-filename 2! start }} (( nocolonnl nonl ** nl white ** )) ** {{ end prim prim-c-code 2! skipsynclines on }} - (( ` : white ** nl - {{ start }} (( nonl ++ nl white ** )) ++ {{ end prim prim-forth-code 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 }} + (( ` : white ** nleof + {{ start }} (( nonl ++ nleof white ** )) ++ {{ end prim prim-forth-code 2! }} )) ?? {{ declarations compute-offsets printprim 1 function-number +! }} - (( nl || eof )) + nleof )) <- simple-primitive ( -- ) (( {{ init-combined }} ` = (( white ++ {{ start }} forth-ident {{ end add-prim }} )) ++ - (( nl || eof )) {{ process-combined }} + nleof {{ process-combined }} )) <- combined-primitive -(( {{ make-prim to prim +(( {{ make-prim to prim 0 to combined line @ name-line ! filename 2@ name-filename 2! start }} forth-ident {{ end 2dup prim prim-name 2! prim prim-c-name 2! }} white ++ (( simple-primitive || combined-primitive ))