From 7a389ce308ae2da9cd03cd2950204fd17bef9e7e Mon Sep 17 00:00:00 2001 From: ketmar Date: Thu, 2 Nov 2023 18:12:28 +0000 Subject: [PATCH] sinopt: various bugfixes FossilOrigin-Name: 19a1a567a9edbaca97438d916dd2de764cdd9e3063d3856ded34131aa4e9de62 --- src/liburforth/urforth.c | 22 +++++++--- urflibs/sinopt-peephole/sinopt.f | 80 ++++++++++++++++++++++++------------ urflibs/tests/test-sinopt-cell-01.f | 3 ++ urflibs/tests/test-sinopt-stack-00.f | 8 ++++ urflibs/tests/test-sinopt-to-00.f | 33 +++++++++++++++ urflibs/tests/test-sinopt-to-01.f | 28 +++++++++++++ 6 files changed, 141 insertions(+), 33 deletions(-) create mode 100644 urflibs/tests/test-sinopt-stack-00.f create mode 100644 urflibs/tests/test-sinopt-to-01.f diff --git a/src/liburforth/urforth.c b/src/liburforth/urforth.c index 0f3502d..efe8b6c 100644 --- a/src/liburforth/urforth.c +++ b/src/liburforth/urforth.c @@ -8899,6 +8899,7 @@ static void ufoFixLabelChainHere (UfoLabel *lbl) { } +#define UFO_MII_WORD_X_COMPILE (-5) #define UFO_MII_WORD_COMPILE_IMM (-4) #define UFO_MII_WORD_CFA_LIT (-3) #define UFO_MII_WORD_COMPILE (-2) @@ -8955,7 +8956,8 @@ UFO_DISABLE_INLINE void ufoInterpretLine (const char *line) { line += 1; } else if (ufoMinInterpState == UFO_MII_WORD_CFA_LIT || ufoMinInterpState == UFO_MII_WORD_COMPILE || - ufoMinInterpState == UFO_MII_WORD_COMPILE_IMM) + ufoMinInterpState == UFO_MII_WORD_COMPILE_IMM || + ufoMinInterpState == UFO_MII_WORD_X_COMPILE) { // "[']"/"COMPILE"/"[COMPILE]" argument wlen = 1; @@ -8966,6 +8968,7 @@ UFO_DISABLE_INLINE void ufoInterpretLine (const char *line) { switch (ufoMinInterpState) { case UFO_MII_WORD_CFA_LIT: UFC("FORTH:(LITCFA)"); break; case UFO_MII_WORD_COMPILE: UFC("FORTH:(LITCFA)"); break; + case UFO_MII_WORD_X_COMPILE: UFC("FORTH:(LITCFA)"); break; case UFO_MII_WORD_COMPILE_IMM: break; default: ufo_assert(0); } @@ -8984,6 +8987,7 @@ UFO_DISABLE_INLINE void ufoInterpretLine (const char *line) { switch (ufoMinInterpState) { case UFO_MII_WORD_CFA_LIT: break; case UFO_MII_WORD_COMPILE: UFC("FORTH:COMPILE,"); break; + case UFO_MII_WORD_X_COMPILE: UFC("FORTH:,"); break; case UFO_MII_WORD_COMPILE_IMM: break; default: ufo_assert(0); } @@ -9068,6 +9072,11 @@ UFO_DISABLE_INLINE void ufoInterpretLine (const char *line) { if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick"); ufoMinInterpState = UFO_MII_WORD_COMPILE; line += wlen; + } else if (wlen == 9 && ufoXStrEquCI("X-COMPILE", line, wlen)) { + // "COMPILE" + if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick"); + ufoMinInterpState = UFO_MII_WORD_X_COMPILE; + line += wlen; } else if (wlen == 9 && ufoXStrEquCI("[COMPILE]", line, wlen)) { // "[COMPILE]" if (ufoMinInterpState != UFO_MII_IN_WORD) ufoFatal("unexpected immediate tick"); @@ -10026,8 +10035,8 @@ UFO_DISABLE_INLINE void ufoInitBasicCompilerWords (void) { ufoInterpretLine( ": COMPILE-END, ( n -- ) " - " , (COMPILE-START-HERE) COMPILER:(AFTER-COMPILE-WORD) " - " (COMPILE-START-HERE) 0! " + " , (COMPILE-START-HERE) @ (COMPILE-START-HERE) 0! " + " COMPILER:(AFTER-COMPILE-WORD) " ";"); // LITERAL @@ -10035,17 +10044,18 @@ UFO_DISABLE_INLINE void ufoInitBasicCompilerWords (void) { ufoInterpretLine( ": LITERAL ( C:n -- ) ( E:n -- n ) " " COMPILER:COMP? FORTH:(0BRANCH) $literal_exit " - " HERE >R COMPILE FORTH:(LIT) , " + " HERE >R X-COMPILE FORTH:(LIT) , " " R> COMPILER:(AFTER-COMPILE-LIT) " "$literal_exit: " ";"); + //ufoDecompileWord(ufoFindWordChecked("LITERAL")); // CFALITERAL // ( C:cfa -- ) ( E:cfa -- cfa ) ufoInterpretLine( ": CFALITERAL ( C:cfa -- ) ( E:cfa -- cfa ) " " COMPILER:COMP? FORTH:(0BRANCH) $cfa_literal_exit " - " HERE >R COMPILE FORTH:(LITCFA) , " + " HERE >R X-COMPILE FORTH:(LITCFA) , " " R> COMPILER:(AFTER-COMPILE-LIT) " "$cfa_literal_exit: " ";"); @@ -10055,7 +10065,7 @@ UFO_DISABLE_INLINE void ufoInitBasicCompilerWords (void) { ufoInterpretLine( ": PFALITERAL ( C:pfa -- ) ( E:pfa -- pfa ) " " COMPILER:COMP? FORTH:(0BRANCH) $pfa_literal_exit " - " HERE >R COMPILE FORTH:(LITPFA) , " + " HERE >R X-COMPILE FORTH:(LITPFA) , " " R> COMPILER:(AFTER-COMPILE-LIT) " "$pfa_literal_exit: " ";"); diff --git a/urflibs/sinopt-peephole/sinopt.f b/urflibs/sinopt-peephole/sinopt.f index 0ceb64c..ef6b5cd 100644 --- a/urflibs/sinopt-peephole/sinopt.f +++ b/urflibs/sinopt-peephole/sinopt.f @@ -26,6 +26,8 @@ vocabulary (sinopt-peephole) (hidden) also-defs: (sinopt-peephole) +\ $DEFINE DEBUG-SINOPT-DUMP-PUSHES + \ $DEFINE DEBUG-SINOPT $DEFINE DEBUG-SINOPT-SIMPLE-BITWISE @@ -89,23 +91,35 @@ buffer buffer-size cells erase buffer-tail buffer + 0! ; +;; rollback one instruction +: buffer-rollback-one ( -- ) buffer-tail cell- buffer-pos-mask and to buffer-tail ; + +: buffer+@ ( ofs -- ) buffer + @ ; + +: buffer-tail@ ( -- ) buffer-tail buffer+@ ; +: buffer-prev@ ( -- ) buffer-tail cell- buffer-pos-mask and buffer+@ ; +: buffer-third@ ( -- ) buffer-tail 8- buffer-pos-mask and buffer+@ ; + : (put-addr) ( addr newofs -- ) buffer + ! ; : (advance-buf) ( -- newofs ) buffer-tail cell+ buffer-pos-mask and dup to buffer-tail ; : lit-reset ( -- ) -1 to buffer-lit-pos ; ;; called when new literal compiled -: push-literal ( addr -- ) (advance-buf) dup to buffer-lit-pos (put-addr) ; +: push-literal ( addr -- ) + (advance-buf) dup to buffer-lit-pos (put-addr) + $IF $DEBUG-SINOPT-DUMP-PUSHES + ." 3LIT(" buffer-tail 0 u.r ." ): " buffer-tail@ 0 u.r space buffer-prev@ 0 u.r space buffer-third@ 0 u.r cr + $ENDIF +; ;; push last compiled word address to the ring buffer. ;; this will reset "lit-pos" if necessary. -: push-last-instr ( addr -- ) (advance-buf) dup buffer-lit-pos = if lit-reset endif (put-addr) ; - -;; rollback one instruction -: buffer-rollback-one ( -- ) buffer-tail cell- buffer-pos-mask and to buffer-tail ; - -: buffer-tail@ ( -- ) buffer-tail buffer + @ ; -: buffer-prev@ ( -- ) buffer-tail cell- buffer-pos-mask and buffer + @ ; -: buffer-third@ ( -- ) buffer-tail 8- buffer-pos-mask and buffer + @ ; +: push-last-instr ( addr -- ) + (advance-buf) dup buffer-lit-pos = if lit-reset endif (put-addr) + $IF $DEBUG-SINOPT-DUMP-PUSHES + ." 3BUF(" buffer-tail 0 u.r ." ): " buffer-tail@ 0 u.r space buffer-prev@ 0 u.r space buffer-third@ 0 u.r cr + $ENDIF +; ;; set by checker, for speed 0 value lit-instr-addr @@ -124,7 +138,7 @@ buffer buffer-size cells erase ;; explicit "exit" used for slight speedup. sorry. : lit-and-instr? ( -- bool ) buffer-lit-pos dup -if drop false exit endif - buffer + @ dup prev-lit-cw = ifnot drop false exit endif ( lit-instr-addr ) + buffer+@ dup prev-lit-cw = ifnot drop false exit endif ( lit-instr-addr ) buffer-tail@ dup last-cw = ifnot 2drop false exit endif ( lit-instr-addr last-instr-addr ) prepare-globals true ; @@ -140,6 +154,10 @@ buffer buffer-size cells erase ;; replace last "(LIT)" value, replace last instruction. : set-lit-value-instr ( value cfa -- ) + ;; fix those, because the only place where this is used is "+cells" optimisation, + ;; and that optimisation rely on further optimisers. + over to lit-value + dup to last-instr-cfa last-instr-addr compile! lit-arg-addr ! ; @@ -153,6 +171,12 @@ buffer buffer-size cells erase ;; replace last "(LIT)" with simple instruction without operands. : replace-lit ( cfa -- ) + $IF 0 + ." REPLACE LIT! " + buffer-tail@ 0 u.r space buffer-prev@ 0 u.r space buffer-third@ 0 u.r + 4 spaces buffer-lit-pos 0 u.r space buffer-tail 0 u.r + cr + $ENDIF lit-instr-addr compile! buffer-lit-pos to buffer-tail lit-reset lit-arg-addr dp! @@ -170,7 +194,7 @@ buffer buffer-size cells erase ;; explicit "exit" used for slight speedup. sorry. : lit-and-one-arg? ( -- bool ) buffer-lit-pos dup -if drop false exit endif - buffer + @ dup here [ 4 cells ] imm-literal - = ifnot drop false exit endif ( lit-instr-addr ) + buffer+@ dup here [ 4 cells ] imm-literal - = ifnot drop false exit endif ( lit-instr-addr ) buffer-tail@ dup here 8- = ifnot 2drop false exit endif ( lit-instr-addr last-instr-addr ) prepare-globals true ; @@ -205,9 +229,10 @@ buffer buffer-size cells erase ;; last instruction must be a direct poke. : replace-prev-with-direct ( cfa -- ) prev-instr-addr compile! - last-instr-addr cell+ @ prev-instr-addr cell+ ! ;; copy argument - prev-instr-addr cell+ dp! - buffer-reset ;; don't bother + ;; copy argument + last-instr-addr cell+ @ prev-instr-addr cell+ dup cell+ dp! ! + \ buffer-reset ;; don't bother + buffer-rollback-one ; : remove-prev-and-direct ( -- ) @@ -472,9 +497,9 @@ create; lit-value last-instr-cfa case ['] forth:lsh of 3 + lit-lsh-tbl endof ['] forth:ash of 3 + lit-ash-tbl endof - ['] forth:lshift of dup -if drop false exit endif lit-lsh-tbl endof - ['] forth:rshift of dup -if drop false exit endif negate lit-lsh-tbl endof - ['] forth:arshift of dup -if drop false exit endif negate lit-ash-tbl endof + ['] forth:lshift of dup -if drop false exit endif 3 + lit-lsh-tbl endof + ['] forth:rshift of dup -if drop false exit endif negate 3 + lit-lsh-tbl endof + ['] forth:arshift of dup -if drop false exit endif negate 3 + lit-ash-tbl endof otherwise 2drop false exit endcase swap simple-replace-from-table $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-MULS @@ -580,7 +605,7 @@ create; ;; : optimise-direct-poke-bool ( -- done? ) - prev-instr-addr @ ['] (direct:!) = ifnot false exit endif + last-instr-cfa ['] (direct:!) = ifnot false exit endif $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-DIRECT-POKES " direct-poke-bool" .optim lit-value 0 .r cr $ENDIF @@ -601,7 +626,7 @@ create; ;; : optimise-direct-poke-inc-bool ( -- done? ) - prev-instr-addr @ case + last-instr-cfa case ['] (direct:+!) of t/f-value ifnot remove-prev-and-direct true exit endif t/f-value @@ -614,7 +639,7 @@ create; $IF $DEBUG-SINOPT AND $DEBUG-SINOPT-SIMPLE-DIRECT-POKES " direct-poke-inc-bool" .optim dup 0 .r cr $ENDIF - t/f-value case + case -1 of ['] forth:(direct:1-!) endof 1 of ['] forth:(direct:1+!) endof otherwise " wuta?!" error endcase -- assertion @@ -710,13 +735,14 @@ create; : instr-compiled ( addr -- ) push-last-instr lit-and-instr? if ;; we just compiled a literal - optimise-direct-bitwise if exit endif - optimise-cells-inc-dec drop -- keep optimising, inc/dec might do more - optimise-inc-dec if exit endif - optimise-mul if exit endif - optimise-div if exit endif - optimise-cells if exit endif - optimise-shifts if exit endif + optimise-direct-bitwise + dup ifnot drop optimise-cells endif + dup ifnot drop optimise-cells-inc-dec drop false endif -- keep optimising, inc/dec might do more + dup ifnot drop optimise-inc-dec endif + dup ifnot drop optimise-mul endif + dup ifnot drop optimise-div endif + dup ifnot drop optimise-shifts endif + drop endif prev-var/const-and-instr? if optimise-vars drop \ if exit endif -- direct optimisers below will do more this way diff --git a/urflibs/tests/test-sinopt-cell-01.f b/urflibs/tests/test-sinopt-cell-01.f index 1fd65a9..d4c9eb4 100644 --- a/urflibs/tests/test-sinopt-cell-01.f +++ b/urflibs/tests/test-sinopt-cell-01.f @@ -1,10 +1,13 @@ : testit-0 ( n -- n ) 0 +cells ; +.( 0 +cells\n) debug:decompile testit-0 : testit-1 ( n -- n ) 1 +cells ; +.( 1 +cells\n) debug:decompile testit-1 : testit-2 ( n -- n ) 2 +cells ; +.( 2 +cells\n) debug:decompile testit-2 debug:dump-stack diff --git a/urflibs/tests/test-sinopt-stack-00.f b/urflibs/tests/test-sinopt-stack-00.f new file mode 100644 index 0000000..aaac1d7 --- /dev/null +++ b/urflibs/tests/test-sinopt-stack-00.f @@ -0,0 +1,8 @@ +0 value val + +: test-0 ( n -- n ) noop swap drop noop ; +.( swap drop \n) +debug:decompile test-0 + + +debug:dump-stack diff --git a/urflibs/tests/test-sinopt-to-00.f b/urflibs/tests/test-sinopt-to-00.f index e3ad3c0..2fe737d 100644 --- a/urflibs/tests/test-sinopt-to-00.f +++ b/urflibs/tests/test-sinopt-to-00.f @@ -52,4 +52,37 @@ debug:decompile testto-b .( 2 -to to val\n) debug:decompile testto-c +: testto-d ( n -- n ) 3 +to val ; +.( 3 +to to val\n) +debug:decompile testto-d + +: testto-e ( n -- n ) 3 -to val ; +.( 3 -to to val\n) +debug:decompile testto-e + +: testto-f ( n -- n ) 3 +to val ; +.( 3 +to to val\n) +debug:decompile testto-f + +: testto-g ( n -- n ) 3 -to val ; +.( 3 -to to val\n) +debug:decompile testto-g + +: testto-h ( n -- n ) 4 +to val ; +.( 4 +to to val\n) +debug:decompile testto-h + +: testto-i ( n -- n ) 4 -to val ; +.( 4 -to to val\n) +debug:decompile testto-i + +: testto-j ( n -- n ) 4 +to val ; +.( 4 +to to val\n) +debug:decompile testto-j + +: testto-k ( n -- n ) 4 -to val ; +.( 4 -to to val\n) +debug:decompile testto-k + + debug:dump-stack diff --git a/urflibs/tests/test-sinopt-to-01.f b/urflibs/tests/test-sinopt-to-01.f new file mode 100644 index 0000000..bccd613 --- /dev/null +++ b/urflibs/tests/test-sinopt-to-01.f @@ -0,0 +1,28 @@ +0 value val + +: testto-0 ( n -- n ) false to val ; +.( false to val\n) +debug:decompile testto-0 + +: testto-1 ( n -- n ) true to val ; +.( true to val\n) +debug:decompile testto-1 + +: testto-2 ( n -- n ) false +to val ; +.( false +to val\n) +debug:decompile testto-2 + +: testto-3 ( n -- n ) true +to val ; +.( true +to val\n) +debug:decompile testto-3 + +: testto-4 ( n -- n ) false -to val ; +.( false -to val\n) +debug:decompile testto-4 + +: testto-5 ( n -- n ) true -to val ; +.( true -to val\n) +debug:decompile testto-5 + + +debug:dump-stack -- 2.11.4.GIT