\ ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» \ º º \ º REORDER for F-PC Last Revision: 16-FEB-1991 KDM º \ º ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ º \ º º \ º Author: Idea and DOS-special words: º \ º Klaus M”dinger Ulrich Paul º \ º Aspernstr.33 Erlenweg 18 º \ º 8900 Augsburg 8901 Leitershofen º \ º Germany Germany º \ º º \ ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ \ *************************************************************************** \ Version for win32for mai 29, 2001 \ bug fixed, some modifications and improvements \ and test program for interpret and compile modes \ by Heinrich Moeller \ email: hmoeller@data-al.de \ *************************************************************************** 0 [IF] Do you like FORTH because you can solve tasks rather fast and easy? Are you annoyed by all the SWAP, DUP, FLUP, OVER, UNDER, PICK, PUCK, SICK, SUCK? If you answered yes to both of the questions you can get a good deal of relief by using REORDER. It does exactly what you tell it to do with your parameters on the stack. The usage of REORDER is straightforward: REORDER ( fred bob joe bill gates -- bob joe fred ) This example drops the top 2 items ( bill gates ), and effectively picks the ( then ) 3.rd and puts it on TOS, just like the stack comment shows. Of course you can use an item more than once on the right side (but all items on the left must have unique names). So REORDER ( a b c d -- a b c d d c b a a a a b b b c c d ) is totally ok. But don't be afraid that REORDER will compile a lot of stack operations for this. The example above are only 71 bytes! And pure assembly code - fast! And try to do this fiddling with the parameters with your "normal" stack operations. You will end up (after 1001 crashes and hours later) with much more space consumed and with a much slower solution. The "secret" of REORDER is a simple optimizing algorithm: Scan the part between the opening bracket up to the double dashes and build a table with the names of the items and their order found ( the first after the bracket is assigned 0, the second 1 and so on - in the last example "a" gets 0 assigned, "b" 1, "c" 2 and "d" 3). Then subtract the biggest index from all of them (in the example this means subtracting 3 from them to get -3, -2, -1 and 0 for a b c d ). These indices now represent the locations relative to the TOS of the items. From now on these items are refered to only by the corresponding index. Now scan the right side from the hyphens to the closing bracket and build a byte string of indices according to the order of parameters found in the input stream. (For the above example this would result in the string -3 -2 -1 0 0 -1 -2 -3 -3 -3 -3 -2 -2 -2 -1 -1 0 because we wrote: "-- a b c d d c b a a a a b b b c c d on the right side.) Next check the change in size of the stack - does it grow, shrink or stay the same? If it will be bigger after the reorder then add the needed amount to the stack right now (i.e. subtract twice as many bytes from the SP) and subtract the number of additional items from all the indices (they lay now "deeper" in the - adjusted - stack). If the stack shrinks (some sort of DROPs in effect) just remember the number of items less on it afterwards, but do not change the SP right now. This was done because the same REORDER shall be usable on a multitasking OS and the stack never may be "unprotected" - i.e. there must never be any items that are referred that are not "on" the stack but beyond the SP. Do not modify the indices, too. If the stack's size does not change do nothing here. Scan the byte string (possibly modified by the previous step ) to check if there are items that get overwritten but are needed. Take the first that wanders to a save location, compile a load-store sequence to do this and correct the index of this parameter so that it reflects the new position on the stack. Do this for all endangered items. (In the above example there are none, but in ( a b c d -- d a b c d ) all are candidates for the above procedure. Here first the SP is advanced, then d is copied to the (new) TOS (and still held in one processor register!). Next we find that d is to be placed where a is right now. So compile a load of "a" to a second processor register and a store of the first register (containing still "d") to the location where we got "a" from. This frees this register, as "d" is no longer needed (both copies have been done). Now with "a" in the second register we find that it's destination is currently occupied by "b". So we compile a load to the first register for "b" and a store of the second to the location where we got the "b" from (this places "a" where it has to go to and frees the second register, as no more copies of "a" are needed. Next we load "c" and store "b" and finally we store "c". We do not have to load "d" as we made the copy in the first of our load-store sequences. This procedure works whether the stack grows, shrinks or stays the same. The only thing to care here is that we first make all copies (or moves) to items that are on the stack afterwards in the additional locations. (If that procedure reminds you of something but you do not know right now of what - think of a sort procedure: bubble sort. Our procedure is a derivate of it with the only difference that bubble sort always takes adjacent items and we choose the item to exchange according to the byte-string.) If the stack shrunk by the REORDER then adjust the SP now. Finish the procedure with a normal NEXT. One word about the speed of REORDER in comparison to the "normal" stack operations: For all but the most primitive words REORDER is significantly faster. Only the simple words DUP, DROP, SWAP, OVER are slightly faster than REORDER. But the increased readability of your source code outweighs this by far and wide. Good efficiency! [then] IN-SYSTEM \ *************************************************************************** \ variables used for collecting some statistical data \ about the number of load and store operations needed for reorder \ *************************************************************************** variable regloads \ count # load operations for statistics variable regsaves \ count # of store operations variable savesreq \ how many store operations are required? \ *************************************************************************** \ Deferred words for stack manipulations \ *************************************************************************** defer $adjust defer $load defer $store ( offset -- ) defer $prefix defer $suffix \ *************************************************************************** \ Variables \ *************************************************************************** $30 constant actiontable-size create reo-actiontable actiontable-size allot create reo-w1 $20 allot \ Buffers holding words in the create reo-w2 $20 allot \ REORDER-command variable which-cell \ indicates which help cell is used 2variable help-cell \ 2 adjacent! help cells \ used instead of registers in interpret mode variable reo-d \ Difference stack-depth d>0 => stack-depth increases variable reo-e# \ Needed to build up the actiontable variable reo-q# \ Count of values left of '--' variable reo-mp \ Mainpointer, index in actiontable variable reo-ts \ Offsets in input-buffer variable reo-te variable reo-tsav \ to save the >in-pointer variable reo-maxi variable reo-tbw 1 constant reorder1 \ Constants for error-handling 2 constant reorder2 3 constant reorder3 4 constant reorder4 255 constant register \ 254 and 255 are number for registers in reo-actiontable \ *************************************************************************** \ Words for REORDER in direct mode \ *************************************************************************** : -pick0 ( offset -- ) \ pick register/helpcell 0 from stack 1- pick help-cell ! ; \ offset is # of stack item, from tos : -pick1 ( offset -- ) \ ditto for register/helpcell 1 1- pick help-cell CELL+ ! ; : -pick ( offset -- ) which-cell c@ IF -pick1 ELSE -pick0 THEN ; : stick0 ( offset -- ) \ store register/helpcell 0 to stack CELLS sp@ + help-cell @ swap ! ; : stick1 ( offset -- ) \ ditto for register/helpcell 1 CELLS sp@ + help-cell CELL+ @ swap ! ; : stick ( offset -- ) which-cell c@ IF stick1 ELSE stick0 THEN ; : adjust-SP ( n -- ) \ adjust stack pointer, add n items 1- CELLS \ correct n to include its space sp@ swap - sp! ; \ *************************************************************************** \ Error handling \ *************************************************************************** : reo-error ( err-# -- ) cr dup reorder1 = abort" Reorder-Error! Missing (" dup reorder2 = abort" Reorder-Error! Missing --" dup reorder3 = abort" Reorder-Error! Unknown element" reorder4 = abort" Reorder-Error! Not enough parameters" abort" Unknown Error in REORDER !" ; \ *************************************************************************** \ REORDER-Init \ *************************************************************************** : init-reorder reo-actiontable actiontable-size erase reo-q# off reo-mp off ; \ *************************************************************************** \ Build up the actiontable \ This code builds the original actiontable. In this format the entries \ reference an item as an index into this table, not from the TOS. (These \ are converted into the right format before the table is acted upon.) \ This routine is called whenever an element (word) is isolated on the \ right side of "--". The code rescans the left side to find the matching \ element (i.e. the same word). It then appends the location where it was found \ to the actiontable, where the location offsets refer to the start of the \ left side sequence of words, starting with 0 for the leftmost one. To speed \ things up a little bit (string comparisons are "expensive") we first check, \ if this element stays at the same location. We can skip it then for further \ processing. Obviously this means, that the element is in the original \ stack. \ *************************************************************************** : word>w2 ( -- ) \ read next word from input to w2 $20 word dup c@ 1+ reo-w2 swap cmove ; : ?action-overflow ( -- ) \ too many parameters for actiontable? reo-mp @ actiontable-size < not abort" too many parameters" ; : build-actiontable ( -- ? ) 1 reo-e# ! >in @ reo-tsav ! \ save >in-pointer reo-ts @ >in ! \ and put it in ts reo-mp @ reo-q# @ < IF \ are there elements already positioned right? reo-mp @ 1+ 0 DO word>w2 LOOP reo-w1 count reo-w2 count compare 0= IF ?action-overflow \ too many parameters for actiontable? reo-tsav @ >in ! \ restore >in 0 reo-actiontable reo-mp @ + c! \ put a 0 in actiontable ( nothing to do ) reo-mp incr \ incr mainpointer 0 \ leave 0 ( = no error ) exit THEN reo-ts @ >in ! THEN BEGIN word>w2 \ scan words left of -- save found words in reo-w2 reo-w1 count reo-w2 count compare \ compare currently regarded entry right of -- \ with entries left of -- WHILE \ while no matches >in @ reo-te @ = \ looked up all entries ? IF reorder3 \ right entry without left equivalent exit THEN reo-e# incr \ increment reo-e# REPEAT \ reo-e# has stack index of inparms ?action-overflow \ too many parameters for actiontable? reo-tsav @ >in ! \ restore >in reo-e# @ reo-actiontable reo-mp @ + c! \ make entry in actiontable reo-mp incr \ increment mainpointer 0 ; \ leave a 0 ( = no error ) \ *************************************************************************** \ debugging \ some words which help for debugging \ *************************************************************************** (( : .actiontable ( -- ) S" actiontable:" _TYPE reo-mp @ . reo-actiontable $10 DUMP _CR ; : .reo-w1 ( -- ) reo-w1 $20 dump cr ; )) \ *************************************************************************** \ Correct action-indices \ This routine changes the indices so that they refer to the new stack \ configuration. All indices are from the top of the stack, either the \ current one (if the stack does not grow) or the final one (if the stack \ grows). Note: Even if the stack shrinks the indices are from the original \ top of stack! Example: reorder ( a b c d -- c d ). The actiontable after \ the adjustment by this routine is ( 2 1 ), which is correct only for the \ original stack. We adjust the SP at the very end in a case where the \ stack shrinks and adjust it at the very beginning if it grows. This is \ necessary to always protect our stack in case of concurrent actions like \ interrupt routines. \ *************************************************************************** : swap-action-indices ( -- ) reo-mp @ 0 ?DO reo-actiontable I + dup c@ dup 0= IF 2drop ELSE reo-maxi @ 1+ swap - swap c! THEN LOOP ; \ *************************************************************************** \ Actualize index in actiontable after stack-manipulation \ The actiontable at any time contains the offsets into the stack \ all items of the new stack (after reorder) must be loaded from. \ In order to keep track of the process, we also use register numbers 255 and \ 244 as 'pseudo-offsets' to indicate that a stack item has been loaded into \ one of the registers. This also means that all stack items which have to be loaded \ from this stack item, now have to be loaded from the register. \ Therefore, after loading a stack item into a register, we call 'act-index' \ to replace all occurrencies of the stack item's offset in the actiontable \ with the register number. \ When we store this register into the destination stack position, we clear \ the corresponding byte in the actiontable to indicate that this stack item \ has been written. Then, we check if we can safely write the register to any \ different stack positions. For this purpose, we have to check if the stack \ item in not needed in the further stack manipulation process ('write-unneeded'). \ We do this by scanning the actiontable ('needed?'). \ If there are still any stack positions which could not be written, the \ corresponding byte in the actiontable is set to the offset of the stack \ position which the register was written to. This is again done by 'act-index'. \ After this, there are no more references to the register, so it is free \ and can be reused. \ It seems that this algorithm can be extended to more than 2 registers, but \ with win32for, there are only registers eax and ecx available. \ *************************************************************************** : act-index ( old new -- ) \ substitute old by new in actiontable reo-actiontable reo-mp @ bounds ?DO over I c@ = IF \ found? dup I c! THEN LOOP 2drop ; \ *************************************************************************** \ Toggle-whichcell \ *************************************************************************** : toggle-whichcell ( -- ) which-cell 1 toggle ; : which-register ( -- n ) \ calculate a register number for register which-cell C@ - ; \ use in reo-actiontable \ *************************************************************************** \ Element needed further ? \ This routine checks whether an item on the stack that is going to be \ overwritten is needed in the future. \ *************************************************************************** : needed? ( tbw -- needed ? ) \ where needed? reo-maxi @ swap - reo-actiontable reo-mp @ rot scan ; \ look where needed? \ *************************************************************************** \ write to unneeded stack positions \ in addition to writing a register/helpcell to the target location on the \ stack, the register is also written to all its target positions which can \ be safely overwritten because their current contents is not required \ for any further stack operations. This saves some load operations. \ The test if some stack item is still needed would not be required \ for stack items outside the old stack depth, but as it is very fast \ (needed? uses 'scan' which is a code definition in win32for), \ we use the same algorithm for all stack items, regardless of their \ position in the old/new stack frame. \ *************************************************************************** : write-unneeded ( index -- ) \ write register to unneeded positions reo-mp @ 0 ?DO reo-actiontable I + c@ which-register = IF \ must store here? I needed? nip 0= IF \ this position not needed further? reo-maxi @ I - swap >r $store r> \ store it regsaves incr 0 ELSE dup THEN reo-actiontable I + c! THEN LOOP drop ; : store-item ( index -- ) \ store item to stack >r 0 reo-actiontable reo-maxi @ + r@ - c! r@ $store regsaves incr \ for statistics r> write-unneeded ; \ write also to unneeded positions : load-item ( index -- ) \ load stack item dup which-register act-index \ reference to source will be ref to register $load regloads incr ; \ for statistics : store-tbw ( -- ) \ toggle register and store toggle-whichcell reo-maxi @ reo-tbw @ - \ reo-TBW := reo-MAX - reo-TBW store-item ; \ write previous cell to destination \ *************************************************************************** \ Write element(s) \ This routine is called to put an element into the new position on the \ stack. But as it operates on the part of the stack where the original \ items are located, it saves the current element at the destination before \ putting the new one there. It then checks whether the saved one can be \ put to it's new location (if it is not discarded). So, this routine will \ move from 1 to many items on the stack around before terminating. \ So, a "reorder ( a b c d -- d c b a )" is handled in two calls \ to this routine. It proceeds as follows: \ Upon entrance the current element is the "d". This item is loaded into a \ register/help cell. Before storing it at location "a" the "a" element \ is saved to another register/help cell. This "a" is then stuck \ at the original location of "d" \ and the routine terminates. It gets called a second time to do the rest. \ *************************************************************************** : write-element ( from to -- ) \ write source element 'from' to destination 'to' reo-tbw ! \ to be written: reo-tbw load-item \ load from source toggle-whichcell BEGIN reo-tbw @ needed? \ reo-y:=pos of needed. WHILE \ if so reo-actiontable - >r reo-maxi @ reo-tbw @ - \ reo-TBW := reo-MAX - reo-TBW load-item \ load stack item which is to be overwritten store-tbw \ toggle register and store r> reo-tbw ! \ set tbw to check needed again REPEAT drop store-tbw ; \ toggle register and store \ *************************************************************************** \ set all elements of the new stack \ *************************************************************************** : do-stack ( -- ) BEGIN reo-mp @ while reo-mp decr reo-actiontable reo-mp @ + c@ \ which element should be loaded? ?dup IF reo-mp @ write-element THEN \ element already in right position ? REPEAT ; \ *************************************************************************** \ Interpret actiontable \ This routine works on the actiontable. It does the real work. After dealing \ with stack growth or shrinkage it calls the proper routines to do the \ real action. \ *************************************************************************** : interpret-actiontable ( -- ) reo-mp @ reo-q# @ 2dup max reo-maxi ! \ maximum stack value - reo-d ! \ reo-d=difference stack-depth swap-action-indices reo-d @ 0> IF \ stack increases? reo-d @ $adjust \ adjust stack THEN do-stack \ reorder complete stack reo-d @ 0< IF reo-d @ $adjust THEN ; \ *************************************************************************** \ Main routine \ reo-ts points to start of left sided elements, reo-te after last of them \ after the first loop. reo-q# is count of them, without "--" ! \ *************************************************************************** : reo-w1! ( ^string -- ) \ save counted string to reo-w1 reo-w1 over c@ 1+ cmove ; \ save it in reo-w1 : reorder ( -- ) init-reorder $20 word count S" (" COMPARE IF \ not found a "(" ? reorder1 reo-error exit THEN \ if not, syntax error >in @ reo-ts ! \ set ts BEGIN $20 word \ get next word dup c@ 0= IF \ no more words after "(" ? reorder4 reo-error exit THEN \ if so, error-exit reo-w1! \ save it in reo-w1 reo-w1 count S" --" compare \ word <> "--" ? WHILE reo-w1 count S" )" compare 0= IF \ word = ")"? reorder2 reo-error exit THEN \ if so, syntax error reo-q# incr \ and incr q# >in @ reo-te ! REPEAT BEGIN $20 word \ get word dup c@ 0= IF \ no more words after "(" ? reorder4 reo-error exit THEN \ if so, error-exit reo-w1! \ and save it in buffer reo-w1 reo-w1 count S" )" compare \ word is not ")"? WHILE build-actiontable \ searching left, building actiontable dup IF \ error in build-actiontable? reo-error exit ELSE drop THEN REPEAT $prefix interpret-actiontable \ start the action $suffix ; immediate : ro postpone reorder ; \ no need to type too much immediate \ *************************************************************************** \ Automatic test \ The test is based on some assumptions: \ 1.) The "stack comment" read by reorder is analysed correctly, and \ reo-actiontable is contructed properly. \ 2.) It is not important which numbers are on the stack, as long als \ the input parameters are all different. This test program always uses the \ values 1, ... n for input parameters (n=number of input parameters). \ \ There are 2 versions, for interpret mode and for compile mode \ the compile mode creates code for the reorder to be checked which is executed \ only once and then overwritten with the code for the next reorder. \ \ How it works: \ The test program creates for given numbers of input,output-Parameters n,m \ all possible stack manipulationens and checks reorder with the input \ parameters 1,..,n. \ For this purpose, it sets the input stack and the variables reo-mp and reo-q# \ and calls the funktion 'interpret-actiontable'. The result is verified \ and the stack is cleaned up. If there is an error encountered, the program \ displays the stack operation which caused the error. \ \ For n input and m output parameters, there are n power m possible stack \ manipulations, which correspond to all numbers of m digits to the base n \ To create all of them, we use a structure 'stacktable' similar to \ 'reo-actiontable' after 'build-actiontable', but before 'swap-action-indices'. \ The only difference is that we start counting stack positions with 0 instead of 1. \ We start with 0 and use the function 'incr-stacktable' to count up. \ (Thus we have a very simple implementation of arithmetics for big numbers \ of an arbitrary base up to 255, with the only operation of counting up. \ We don't use forth's arithmetic for this purpose because of the limitation \ to 16 or 32 bits, respectively.) \ Each number representation in 'stacktable' is used to build 'reo-actiontable' \ and to test the corresponding stack manipulation. \ *************************************************************************** 5 value #in-items \ stack input items 8 value #out-items \ stack output items variable reorder-errors \ count errors create stacktable \ a structure similar to the actiontable actiontable-size allot \ after construction by 'build-actiontable' : incr-stacktable ( -- ? ) \ increment stacktable -- return 1 if overflow 1 #out-items 0 ?DO \ add 1 to the least significant digit I stacktable + c@ + #in-items /mod swap I stacktable + c! dup 0= IF LEAVE THEN \ overflow 0 -- it's finished LOOP ; : init-stat ( -- ) \ initialize statistics about load/store ops 0 regloads ! \ how many load operations 0 regsaves ! \ how many save operations 0 savesreq ! ; \ minimum # save operations required : .statistic ( -- ) \ display statistics about load/store ops regloads @ . ." loads, " regsaves @ dup . ." saves" cr savesreq @ = not IF \ the real number of store ops should savesreq @ . ." required saves" cr \ not be bigger than what is required THEN ; \ *************************************************************************** \ 'copy-actiontable' creates a 'real' actiontable from the stacktable \ used to generate all possible stack manipulations \ *************************************************************************** : copy-actiontable ( n -- ) \ create a 'real' actiontable from stacktable reo-actiontable actiontable-size erase \ clear it first 0 ?DO i stacktable + c@ dup i <> IF \ this stack item will change? 1+ i reo-actiontable + c! \ actiontable stack count starts with 1 savesreq incr \ this will require one store operation ELSE drop THEN \ nothing to do LOOP ; : setup-instack ( n -- 1 2 .. n ) \ setup input stack with n parameters 1+ 1 DO i LOOP ; \ *************************************************************************** \ 'do-reorder' leaves a variable number of stack items (depending on the 'stacktable') \ which are consumed by 'check-stack'. Therefore, these words \ must always be used together. \ note: unlike the fpc version, here reo-q# is the number of stack input items \ without the '--'! \ *************************************************************************** : do-reorder ( -- ... ) \ perform 1 test #out-items copy-actiontable \ create reo-actiontable from stacktable #in-items reo-q# ! \ set # input paramters #out-items reo-mp ! \ set # output parameters #in-items setup-instack \ setup input stack interpret-actiontable ; \ run reorder : .stackitems ( n1 n2..nm m -- ) \ display and drop n top stack items dup 0 ?do dup i - roll . loop drop ; : .stackparm ( n -- ) \ display a stack parameter as a,b,c... 'a' + emit bl emit ; : .reo-error ( -- ) \ display information about erroneous #in-items 0 DO i 1+ . LOOP \ stack manipulation by reorder ." reorder ( " #in-items 0 DO i .stackparm LOOP ." -- " stacktable #out-items 0 ?DO dup c@ .stackparm 1+ LOOP drop ." ) returns " depth >r do-reorder r> depth swap - 1- 0 max .stackitems cr ; : .reorder-errors ( -- ) \ display # of errors if any reorder-errors @ ?dup IF . ." reorder-errors" cr THEN ; : check-stack ( ... -- ) \ check if the output stack after reorder stacktable #out-items + \ complies with the stacktable #out-items 0 ?DO 1- dup c@ 1+ rot <> IF reorder-errors incr .reo-error THEN LOOP drop ; : init-reotest ( -- ) \ some initialization for test init-stat \ initialize statistics reorder-errors off \ clear error count stacktable actiontable-size erase ; \ start with 0 : reo-test ( -- ) \ perform test for #in-items and #out-items init-reotest \ initialization for test BEGIN depth >r do-reorder \ perform 1 reorder in interpret mode check-stack \ check the reorder result depth r> <> abort" stack error" incr-stacktable UNTIL .reorder-errors ; \ display # of errors if any : .#inparms ( -- ) \ display current # of input parameters #in-items . ." input parameters" cr ; : .#outparms ( -- ) \ display current # of output parameters #out-items . ." output parameters" cr ; : testit ( -- ) \ test for different output stack depths .#inparms \ display current # of input parameters 8 3 DO \ test for these output items init-stat \ initialize statistics i to #out-items \ set stack output items .#outparms \ display current # of output parameters reo-test \ perform test, interpret mode .statistic \ display statistic results LOOP ; \ *************************************************************************** \ Assembler code generation \ The following test works similar to the above test, but \ compiles code for each stack reorder to be checked. \ The compiled code is executed only once and then overwritten with \ the instructions for the next test. \ *************************************************************************** : next, ( -- ) \ compile next $8b c, $06 c, \ mov eax, [esi] $83 c, $c6 c, $04 c, \ add esi, # 4 $8b c, $0c c, $38 c, \ mov ecx, [eax] [edi] $03 c, $cf c, \ add ecx, edi $ff c, $e1 c, ; \ jmp ecx 0 value save-here \ remember current dictionary size 0 value patchit \ address to be patched with code for reorder : reo-execute ( -- ) \ execute compiled reorder operation [ here to patchit ] noop ; \ this will be patched to execute reorder : compiled-reorder ( -- ...) \ compile reorder code and perform 1 test here to save-here \ remember current dictionary size here cell+ , \ indirect threaded state @ >r \ save current state state on \ switch to compile mode do-reorder \ compile code for reorder r> state ! \ restore state next, \ compile next save-here patchit ! \ patch reo-execute to execute reorder reo-execute \ execute compiled reorder operation save-here here - allot ; \ remove compiled assembler code : reo-ctest ( -- ) \ like reo-test, but with code compilation init-reotest \ initialization for test BEGIN depth >r compiled-reorder \ compile reorder code and perform 1 test check-stack \ check the reorder result depth r> <> abort" stack error" incr-stacktable UNTIL .reorder-errors ; \ display # of errors if any : ctestit ( -- ) \ test for different output stack depths .#inparms \ display current # of input parameters 8 3 DO \ test for these output items init-stat \ initialize statistics i to #out-items \ set stack output items .#outparms \ display current # of output parameters reo-ctest \ perform test, compile mode .statistic \ display statistic results LOOP ; \ *************************************************************************** \ runtime primitives for REORDER in compile mode \ these primitives implement stack operations (load, store and adjust stack) \ thus inline assembly is not required \ but inline assembly is usually faster and more compact \ this code is only included for completeness \ *************************************************************************** (( IN-APPLICATION CODE [adjust-SP] ( n -- ) \ n bytes! push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS sub esp, ebx pop ebx \ necessary for shinking stack! exec ;c CODE [-pick00] ( -- ) \ stack index is 0 nextip mov help-cell [edi], ebx exec ;c CODE [-pick01] ( -- ) \ stack index is 0 nextip mov help-cell CELL+ [edi], ebx exec ;c CODE [-pick0] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, [ebx*4] [esp] mov help-cell [edi], ecx pop ebx exec ;c CODE [-pick1] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, [ebx*4] [esp] mov help-cell CELL+ [edi], ecx pop ebx exec ;c CODE [stick00] ( -- ) nextip mov ebx, help-cell [edi] exec ;c CODE [stick01] ( -- ) nextip mov ebx, help-cell CELL+ [edi] exec ;c CODE [stick0] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, help-cell [edi] mov [ebx*4] [esp], ecx pop ebx exec ;c CODE [stick1] ( -- ) push ebx mov ebx, [esi] \ get inline parameter mov eax, CELL [esi] \ nextip to skip parameter add esi, # 2 CELLS mov ecx, help-cell CELL+ [edi] mov [ebx*4] [esp], ecx pop ebx exec ;c \ *************************************************************************** \ Words for REORDER in compiling mode \ *************************************************************************** IN-SYSTEM : win32$load ( offset -- ) state @ IF \ compiling or interpreting 1- ?DUP IF which-cell c@ IF COMPILE [-pick1] ELSE COMPILE [-pick0] THEN , ELSE which-cell c@ IF COMPILE [-pick01] ELSE COMPILE [-pick00] THEN THEN ELSE -pick THEN ; : win32$store ( offset -- ) state @ IF 1- ?DUP IF which-cell c@ IF COMPILE [stick1] ELSE COMPILE [stick0] THEN , ELSE which-cell c@ IF COMPILE [stick01] ELSE COMPILE [stick00] THEN THEN ELSE stick THEN ; : win32$adjust-sp ( n -- ) \ increment stack by n cells state @ IF COMPILE [adjust-sp] CELLS , ELSE adjust-sp THEN ; ' win32$load is $load ' win32$store is $store ' win32$adjust-sp is $adjust ' noop is $suffix ' noop is $prefix )) \ *************************************************************************** \ words for compiling inline assembler, indirect threaded forth model \ the few instructions used here are compiled directly, without \ a 'real' assembler \ it handles the special case tos (top of stack) in register ebx \ *************************************************************************** \ : verbose ; \ display assembler instructions \ uncomment this line if you want to see what is compiled : load-eax ( offset -- ) \ load register eax from stack $8B C, \ mov reg, mem ?DUP IF \+ verbose ." mov eax, " dup . ." [esp]" cr $44 C, $24 C, C, \ mov eax, nn [esp] ELSE \ a little shorter, without offset \+ verbose ." mov eax, [esp]" cr $04 C, $24 C, \ mov eax, [esp] THEN ; : load-ecx ( offset -- ) \ load register ecx from stack $8B C, \ mov reg, mem ?DUP IF \+ verbose ." mov ecx, " dup . ." [esp]" cr $4C C, $24 C, C, \ mov ecx, nn [esp] ELSE \ a little shorter, without offset \+ verbose ." mov ecx, [esp]" cr $0C C, $24 C, \ move ecx, [esp] THEN ; : load-tos ( -- ) \ load TOS to register $8B C, \ mov reg, reg which-cell c@ IF \+ verbose ." mov ecx, ebx" cr $CB C, \ mov ecx, ebx ELSE \+ verbose ." mov eax, ebx" cr $C3 C, \ mov eax, ebx THEN ; : asm$load, ( offset -- ) \ assemble load code 1- ?DUP IF 1- CELLS which-cell c@ IF load-ecx ELSE load-eax THEN ELSE load-tos \ TOS, directly load ebx THEN ; : asm$load ( offset -- ) state @ IF asm$load, \ compiling or interpreting ELSE -pick THEN ; : store-ecx ( offset -- ) $89 C, \ mov mem, reg ?DUP IF \+ verbose ." mov " dup . ." [esp], ecx" cr $4C C, $24 C, C, \ mov nn [esp], ecx ELSE \+ verbose ." mov [esp], ecx" cr $0C C, $24 C, \ mov [esp], ecx THEN ; : store-eax ( offset -- ) $89 C, \ mov mem, reg ?DUP IF \+ verbose ." mov " dup . ." [esp], eax" cr $44 C, $24 C, C, \ mov nn [esp], eax ELSE \+ verbose ." mov [esp], eax" cr $04 C, $24 C, \ mov [esp], eax THEN ; : store-tos ( -- ) $8B C, \ mov reg, reg which-cell c@ IF \+ verbose ." mov ebx, ecx" cr $D9 C, \ mov ebx, ecx ELSE \+ verbose ." mov ebx, eax" cr $D8 C, \ mov ebx, eax THEN ; : asm$store, ( offset -- ) 1- ?DUP IF 1- CELLS which-cell c@ IF store-ecx ELSE store-eax THEN ELSE store-tos \ TOS THEN ; : asm$store ( offset -- ) state @ IF asm$store, ELSE stick THEN ; : asm$adjust-sp, ( n -- ) \ increment stack by n cells \ S" $adjust-sp: " _TYPE DUP . _CR ?DUP IF CELLS DUP 0< IF \ add it to sp ABS CELL- ?DUP IF \ something to do? \+ verbose ." add esp, # " dup . cr $83 C, $C4 C, C, \ add esp, # nn THEN \+ verbose ." pop ebx" cr $5B C, \ pop ebx ELSE \ >0 \+ verbose ." push ebx" cr $53 C, \ push ebx CELL- ?DUP IF \+ verbose ." sub esp, # " dup . cr $83 C, $EC C, C, \ sub esp, # nn THEN THEN THEN ; : asm$adjust-sp ( n -- ) \ increment stack by n cells state @ IF asm$adjust-sp, ELSE adjust-sp THEN ; variable inline-addr \ remember starting address of inline code \ to calculate the offset to add to esi : inline ( -- ) \ compile inline code, indirect threaded here cell+ , \ requires 8 bytes here inline-addr ! \ save 'cfa' of inline code here cell+ , ; \ here the code starts : -inline ( -- ) \ end of inline code $81 c, $c6 c, \ add esi, #dword here >r \ here patch the value to be added to esi cell allot \ #dword to be added $8b c, $46 c, $fc c, \ mov eax, -4 [esi] esi already points to next cfa $8b c, $0c c, $38 c, \ mov ecx, [eax] [edi] $03 c, $cf c, \ add ecx, edi $ff c, $e1 c, \ jmp ecx align here inline-addr @ - cell+ r> ! \ patch #dword to be added to esi \+ verbose inline-addr @ (see) \ see what has been compiled ; : asm$prefix ( -- ) state @ IF inline THEN ; : asm$suffix ( -- ) state @ IF -inline THEN ; ' asm$load is $load ' asm$store is $store ' asm$adjust-sp is $adjust ' asm$suffix is $suffix ' asm$prefix is $prefix IN-APPLICATION