From 25bb4c7651323b6879064cfdfb74d1771f56abca Mon Sep 17 00:00:00 2001 From: Irene Knapp Date: Wed, 20 May 2026 00:34:28 -0700 Subject: add a really powerful stack depth tracking feature for transforms to use also said feature seems to work, which is flatly astonishing just a little more now... Force-Push: yes Change-Id: I1bda7e99e524ac73a761859e86e01251e7d17525 --- transform.e | 950 ++++++++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 856 insertions(+), 94 deletions(-) (limited to 'transform.e') diff --git a/transform.e b/transform.e index 2516e53..7af668b 100644 --- a/transform.e +++ b/transform.e @@ -245,11 +245,13 @@ : transform-state-saved-here ; : transform-state-saved-latest 8 + ; : transform-state-output-buffer-start 2 8 * + ; +: transform-state-user-stack-depth 3 8 * + ; : allocate-transform-state - 3 8 * allocate + 4 8 * allocate dup transform-state-saved-here 0 swap ! dup transform-state-saved-latest 0 swap ! - dup transform-state-output-buffer-start 0 swap ! ; + dup transform-state-output-buffer-start 0 swap ! + dup transform-state-user-stack-depth 0 swap ! ; allocate-transform-state s" transform-state" variable @@ -318,6 +320,399 @@ allocate-transform-state s" transform-state" variable @ .hex64 newline ; +~ User stack depth tracking helper +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The transformation facility offers a feature which specific transforms can +~ use, or not, as they prefer, called user stack depth tracking. The log-load +~ transform uses it; the label transform does not. The most difficult part of +~ the tracking is the heler word below; it also relies on the user-stack-depth +~ field of the transform-state variable. +~ +~ What does user stack depth mean? Well, for every transform there's some +~ notion of running a word "immediately"; for the log-load transform, it means +~ that the word runs at the time the generated log-load routine executes. Each +~ time a word runs, it interacts with the value stack in some way. Some words +~ are neutral; others result in a net increase or decrease in its depth, which +~ we call the delta. The running total of these deltas is what we call the +~ user stack depth. By "user" we mean that these are values which were created +~ by and for the code being transformed, which the code doing the transforming +~ must be careful not to interfere with. +~ +~ Why do we need to do this? Recall that the log-load routine is given the +~ log address as the only value on the stack when it begins, and any time it +~ does something that requires looking at the log, it needs to be able to find +~ that address. The log-load routine runs as part of the warm-start routine +~ (see execution.e), whose overall job is to get Evocation into a state where +~ it can freely work with dynamically-allocated data on the log whose address +~ isn't known at compile time. Therefore, necessarily, the log-load routine +~ itself cannot assume access to any scratch space; the value stack is the +~ only place it can store anything it needs, most crucially including the log +~ address. +~ +~ Fortunately, it is possible for the transform's own generated code to +~ cooperate with the transformed code so that they can both share the stack, +~ as long as the log transform knows what the transformed code is doing with +~ it. Unfortunately, there's no general way to know that. We achieve it by +~ hard-coding a delta value for every single possible word, and looking up +~ that delta at transform-time, based on the word's name. Yes, that is quite a +~ thing to have to do, but it does mean we don't have to think about this +~ while writing the code we're transforming. +~ +~ It's worth noticing that the delta only applies to things that happen +~ immediately. It does not apply to compiled words because they run later, and +~ it does not apply to alternates because they run too soon. Feel free to +~ contemplate how confusing it is that transformation-time is sooner than +~ "immediate". +~ +~ (name pointer -- delta value) +: transform-get-stack-delta + ~ From core.e. + dup s" docol" stringcmp 0 = { drop 1 exit } if + dup s" exit" stringcmp 0 = { drop 0 exit } if + dup s" swap" stringcmp 0 = { drop 0 exit } if + dup s" drop" stringcmp 0 = { drop -1 exit } if + dup s" 2drop" stringcmp 0 = { drop -2 exit } if + ~ The following are deliberate omissions: roll, unroll. + dup s" 3roll" stringcmp 0 = { drop 0 exit } if + dup s" 3unroll" stringcmp 0 = { drop 0 exit } if + dup s" dup" stringcmp 0 = { drop 1 exit } if + dup s" 2dup" stringcmp 0 = { drop 2 exit } if + dup s" +" stringcmp 0 = { drop -1 exit } if + dup s" -" stringcmp 0 = { drop -1 exit } if + dup s" *" stringcmp 0 = { drop -1 exit } if + dup s" /%" stringcmp 0 = { drop 0 exit } if + dup s" =" stringcmp 0 = { drop -1 exit } if + dup s" !=" stringcmp 0 = { drop -1 exit } if + dup s" >" stringcmp 0 = { drop -1 exit } if + dup s" <" stringcmp 0 = { drop -1 exit } if + dup s" >=" stringcmp 0 = { drop -1 exit } if + dup s" <=" stringcmp 0 = { drop -1 exit } if + dup s" >unsigned" stringcmp 0 = { drop -1 exit } if + dup s" =unsigned" stringcmp 0 = { drop -1 exit } if + dup s" <=unsigned" stringcmp 0 = { drop -1 exit } if + dup s" &" stringcmp 0 = { drop -1 exit } if + dup s" |" stringcmp 0 = { drop -1 exit } if + dup s" xor" stringcmp 0 = { drop -1 exit } if + dup s" invert" stringcmp 0 = { drop 0 exit } if + dup s" lit" stringcmp 0 = { drop 1 exit } if + dup s" litstring" stringcmp 0 = { drop 1 exit } if + dup s" !" stringcmp 0 = { drop -2 exit } if + dup s" @" stringcmp 0 = { drop 0 exit } if + dup s" +!" stringcmp 0 = { drop -2 exit } if + dup s" -!" stringcmp 0 = { drop -2 exit } if + dup s" 8!" stringcmp 0 = { drop -2 exit } if + dup s" 8@" stringcmp 0 = { drop 0 exit } if + dup s" 16!" stringcmp 0 = { drop -2 exit } if + dup s" 16@" stringcmp 0 = { drop 0 exit } if + dup s" 32!" stringcmp 0 = { drop -2 exit } if + dup s" 32@" stringcmp 0 = { drop 0 exit } if + dup s" control!" stringcmp 0 = { drop -1 exit } if + dup s" control@" stringcmp 0 = { drop 1 exit } if + dup s" value!" stringcmp 0 = { drop -1 exit } if + dup s" value@" stringcmp 0 = { drop 1 exit } if + dup s" memcopy" stringcmp 0 = { drop -3 exit } if + dup s" memmove" stringcmp 0 = { drop -3 exit } if + dup s" stringlen" stringcmp 0 = { drop 0 exit } if + dup s" reverse-stringlen" stringcmp 0 = { drop 0 exit } if + dup s" reverse-padding-len" stringcmp 0 = { drop 0 exit } if + dup s" stringcmp" stringcmp 0 = { drop -1 exit } if + dup s" branch" stringcmp 0 = { drop 0 exit } if + dup s" 0branch" stringcmp 0 = { drop 0 exit } if + ~ This is kind of a big assumption. + dup s" execute" stringcmp 0 = { drop -1 exit } if + dup s" entry-to-execution-token" stringcmp 0 = { drop 0 exit } if + dup s" execution-token-to-entry" stringcmp 0 = { drop 0 exit } if + dup s" entry-flags@" stringcmp 0 = { drop 0 exit } if + dup s" entry-flags!" stringcmp 0 = { drop -2 exit } if + dup s" entry-to-name" stringcmp 0 = { drop 0 exit } if + dup s" pack64" stringcmp 0 = { drop -1 exit } if + dup s" pack32" stringcmp 0 = { drop -1 exit } if + dup s" pack16" stringcmp 0 = { drop -1 exit } if + dup s" pack8" stringcmp 0 = { drop -1 exit } if + dup s" packstring" stringcmp 0 = { drop -1 exit } if + dup s" packalign" stringcmp 0 = { drop -1 exit } if + dup s" unpack64" stringcmp 0 = { drop 1 exit } if + dup s" unpack32" stringcmp 0 = { drop 1 exit } if + dup s" unpack16" stringcmp 0 = { drop 1 exit } if + dup s" unpack8" stringcmp 0 = { drop 1 exit } if + dup s" align-size" stringcmp 0 = { drop -1 exit } if + dup s" unpackalign" stringcmp 0 = { drop -1 exit } if + dup s" crash" stringcmp 0 = { drop 0 exit } if + + ~ From core-plus.e. + dup s" 1-" stringcmp 0 = { drop 0 exit } if + dup s" 1+" stringcmp 0 = { drop 0 exit } if + dup s" max" stringcmp 0 = { drop -1 exit } if + dup s" min" stringcmp 0 = { drop -1 exit } if + dup s" over" stringcmp 0 = { drop 1 exit } if + dup s" pick" stringcmp 0 = { drop 0 exit } if + ~ The following are deliberate omissions: ndrop, ndup. + dup s" 3drop" stringcmp 0 = { drop -3 exit } if + dup s" 3dup" stringcmp 0 = { drop 3 exit } if + dup s" &&" stringcmp 0 = { drop -1 exit } if + dup s" ||" stringcmp 0 = { drop -1 exit } if + dup s" not" stringcmp 0 = { drop 0 exit } if + dup s" negate" stringcmp 0 = { drop 0 exit } if + dup s" align-floor" stringcmp 0 = { drop -1 exit } if + + ~ From linux.e. + dup s" sys-exit" stringcmp 0 = { drop -1 exit } if + dup s" sys-write" stringcmp 0 = { drop -2 exit } if + dup s" sys-read" stringcmp 0 = { drop -1 exit } if + + ~ From output.e. + dup s" emitstring" stringcmp 0 = { drop -1 exit } if + dup s" space" stringcmp 0 = { drop 0 exit } if + dup s" newline" stringcmp 0 = { drop 0 exit } if + dup s" pow" stringcmp 0 = { drop 2 exit } if + dup s" logfloor" stringcmp 0 = { drop 2 exit } if + dup s" logceil" stringcmp 0 = { drop 2 exit } if + dup s" .base-unsigned" stringcmp 0 = { drop -3 exit } if + dup s" .base" stringcmp 0 = { drop -2 exit } if + dup s" ." stringcmp 0 = { drop -1 exit } if + dup s" .hex" stringcmp 0 = { drop -1 exit } if + dup s" .hex8" stringcmp 0 = { drop -1 exit } if + dup s" .hex16" stringcmp 0 = { drop -1 exit } if + dup s" .hex32" stringcmp 0 = { drop -1 exit } if + dup s" .hex64" stringcmp 0 = { drop -1 exit } if + dup s" .hexn" stringcmp 0 = { drop -2 exit } if + ~ The following is a deliberate omission: s0. + dup s" stack" stringcmp 0 = { drop 0 exit } if + dup s" stackhex" stringcmp 0 = { drop 0 exit } if + + ~ From amd64.e. + dup s" :rax" stringcmp 0 = { drop 1 exit } if + dup s" :rcx" stringcmp 0 = { drop 1 exit } if + dup s" :rdx" stringcmp 0 = { drop 1 exit } if + dup s" :rbx" stringcmp 0 = { drop 1 exit } if + dup s" :rsp" stringcmp 0 = { drop 1 exit } if + dup s" :rbp" stringcmp 0 = { drop 1 exit } if + dup s" :rsi" stringcmp 0 = { drop 1 exit } if + dup s" :rdi" stringcmp 0 = { drop 1 exit } if + dup s" :r8" stringcmp 0 = { drop 1 exit } if + dup s" :r9" stringcmp 0 = { drop 1 exit } if + dup s" :r10" stringcmp 0 = { drop 1 exit } if + dup s" :r11" stringcmp 0 = { drop 1 exit } if + dup s" :r12" stringcmp 0 = { drop 1 exit } if + dup s" :r13" stringcmp 0 = { drop 1 exit } if + dup s" :r14" stringcmp 0 = { drop 1 exit } if + dup s" :r15" stringcmp 0 = { drop 1 exit } if + dup s" :eax" stringcmp 0 = { drop 1 exit } if + dup s" :ecx" stringcmp 0 = { drop 1 exit } if + dup s" :edx" stringcmp 0 = { drop 1 exit } if + dup s" :ebx" stringcmp 0 = { drop 1 exit } if + dup s" :esp" stringcmp 0 = { drop 1 exit } if + dup s" :ebp" stringcmp 0 = { drop 1 exit } if + dup s" :esi" stringcmp 0 = { drop 1 exit } if + dup s" :edi" stringcmp 0 = { drop 1 exit } if + dup s" :ax" stringcmp 0 = { drop 1 exit } if + dup s" :cx" stringcmp 0 = { drop 1 exit } if + dup s" :dx" stringcmp 0 = { drop 1 exit } if + dup s" :bx" stringcmp 0 = { drop 1 exit } if + dup s" :sp" stringcmp 0 = { drop 1 exit } if + dup s" :bp" stringcmp 0 = { drop 1 exit } if + dup s" :si" stringcmp 0 = { drop 1 exit } if + dup s" :di" stringcmp 0 = { drop 1 exit } if + dup s" :al" stringcmp 0 = { drop 1 exit } if + dup s" :cl" stringcmp 0 = { drop 1 exit } if + dup s" :dl" stringcmp 0 = { drop 1 exit } if + dup s" :bl" stringcmp 0 = { drop 1 exit } if + dup s" :ah" stringcmp 0 = { drop 1 exit } if + dup s" :ch" stringcmp 0 = { drop 1 exit } if + dup s" :dh" stringcmp 0 = { drop 1 exit } if + dup s" :bh" stringcmp 0 = { drop 1 exit } if + dup s" :cc-overflow" stringcmp 0 = { drop 1 exit } if + dup s" :cc-no-overflow" stringcmp 0 = { drop 1 exit } if + dup s" :cc-below" stringcmp 0 = { drop 1 exit } if + dup s" :cc-above-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-not-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-below-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-above" stringcmp 0 = { drop 1 exit } if + dup s" :cc-sign" stringcmp 0 = { drop 1 exit } if + dup s" :cc-not-sign" stringcmp 0 = { drop 1 exit } if + dup s" :cc-even" stringcmp 0 = { drop 1 exit } if + dup s" :cc-odd" stringcmp 0 = { drop 1 exit } if + dup s" :cc-less" stringcmp 0 = { drop 1 exit } if + dup s" :cc-greater-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-less-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-greater" stringcmp 0 = { drop 1 exit } if + dup s" reg64" stringcmp 0 = { drop 0 exit } if + dup s" extrareg64" stringcmp 0 = { drop 0 exit } if + dup s" reg32" stringcmp 0 = { drop 0 exit } if + dup s" reg16" stringcmp 0 = { drop 0 exit } if + dup s" reg8" stringcmp 0 = { drop 0 exit } if + dup s" scalefield" stringcmp 0 = { drop 0 exit } if + dup s" condition-code" stringcmp 0 = { drop 0 exit } if + dup s" rex-0" stringcmp 0 = { drop 0 exit } if + dup s" rex-w" stringcmp 0 = { drop 0 exit } if + dup s" rex-r" stringcmp 0 = { drop 0 exit } if + dup s" rex-x" stringcmp 0 = { drop 0 exit } if + dup s" rex-b" stringcmp 0 = { drop 0 exit } if + dup s" rex-wr" stringcmp 0 = { drop 0 exit } if + dup s" rex-wx" stringcmp 0 = { drop 0 exit } if + dup s" rex-wb" stringcmp 0 = { drop 0 exit } if + dup s" rex-rx" stringcmp 0 = { drop 0 exit } if + dup s" rex-rb" stringcmp 0 = { drop 0 exit } if + dup s" rex-xb" stringcmp 0 = { drop 0 exit } if + dup s" rex-wrx" stringcmp 0 = { drop 0 exit } if + dup s" rex-wrb" stringcmp 0 = { drop 0 exit } if + dup s" rex-wxb" stringcmp 0 = { drop 0 exit } if + dup s" rex-rxb" stringcmp 0 = { drop 0 exit } if + dup s" rex-wrxb" stringcmp 0 = { drop 0 exit } if + dup s" opcodereg" stringcmp 0 = { drop -2 exit } if + dup s" opcodecc" stringcmp 0 = { drop -2 exit } if + dup s" modrm" stringcmp 0 = { drop -3 exit } if + dup s" sib" stringcmp 0 = { drop -3 exit } if + dup s" addressing-reg64" stringcmp 0 = { drop -2 exit } if + dup s" addressing-reg8" stringcmp 0 = { drop -2 exit } if + dup s" addressing-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" addressing-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" addressing-disp32-reg64" stringcmp 0 = { drop -3 exit } if + dup s" addressing-indexed-reg64" stringcmp 0 = { drop -4 exit } if + dup s" addressing-disp8-indexed-reg64" stringcmp 0 = { drop -5 exit } if + dup s" cld" stringcmp 0 = { drop 0 exit } if + dup s" std" stringcmp 0 = { drop 0 exit } if + dup s" syscall" stringcmp 0 = { drop 0 exit } if + dup s" hlt" stringcmp 0 = { drop 0 exit } if + dup s" push-reg64" stringcmp 0 = { drop -1 exit } if + dup s" pop-reg64" stringcmp 0 = { drop -1 exit } if + dup s" push-imm32-extended64" stringcmp 0 = { drop -1 exit } if + dup s" lea-reg64-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" lea-reg64-disp32-reg64" stringcmp 0 = { drop -3 exit } if + dup s" lea-reg64-indexed-reg64" stringcmp 0 = { drop -4 exit } if + dup s" lea-reg64-disp8-indexed-reg64" stringcmp 0 = { drop -5 exit } if + dup s" mov-reg64-imm32" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg64-imm64" stringcmp 0 = { drop -2 exit } if + dup s" mov-extrareg64-imm64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg64-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg64-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg64-disp32-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg64-indexed-reg64" stringcmp 0 = { drop -4 exit } if + dup s" mov-indexed-reg64-reg64" stringcmp 0 = { drop -4 exit } if + dup s" mov-indirect-reg64-reg32" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg32" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg32-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg32-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-indirect-reg64-reg16" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg16" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg16-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg16-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-indirect-reg64-reg8" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg8" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg8-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg8-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg8-reg8" stringcmp 0 = { drop -2 exit } if + dup s" movs8" stringcmp 0 = { drop 0 exit } if + dup s" movs16" stringcmp 0 = { drop 0 exit } if + dup s" movs32" stringcmp 0 = { drop 0 exit } if + dup s" movs64" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs8" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs16" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs32" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs64" stringcmp 0 = { drop 0 exit } if + dup s" lods8" stringcmp 0 = { drop 0 exit } if + dup s" lods16" stringcmp 0 = { drop 0 exit } if + dup s" lods32" stringcmp 0 = { drop 0 exit } if + dup s" lods64" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods8" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods16" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods32" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods64" stringcmp 0 = { drop 0 exit } if + dup s" stos8" stringcmp 0 = { drop 0 exit } if + dup s" stos16" stringcmp 0 = { drop 0 exit } if + dup s" stos32" stringcmp 0 = { drop 0 exit } if + dup s" stos64" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos8" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos16" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos32" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos64" stringcmp 0 = { drop 0 exit } if + dup s" cmps8" stringcmp 0 = { drop 0 exit } if + dup s" cmps16" stringcmp 0 = { drop 0 exit } if + dup s" cmps32" stringcmp 0 = { drop 0 exit } if + dup s" cmps64" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps8" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps16" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps32" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps64" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps8" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps16" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps32" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps64" stringcmp 0 = { drop 0 exit } if + dup s" scas8" stringcmp 0 = { drop 0 exit } if + dup s" scas16" stringcmp 0 = { drop 0 exit } if + dup s" scas32" stringcmp 0 = { drop 0 exit } if + dup s" scas64" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas8" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas16" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas32" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas64" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas8" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas16" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas32" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas64" stringcmp 0 = { drop 0 exit } if + dup s" add-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" add-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" add-reg64-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" add-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" sub-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" sub-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" sub-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" sbb-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" mul-reg64" stringcmp 0 = { drop -1 exit } if + dup s" divmod-reg64" stringcmp 0 = { drop -1 exit } if + dup s" idivmod-reg64" stringcmp 0 = { drop -1 exit } if + dup s" inc-reg64" stringcmp 0 = { drop -1 exit } if + dup s" dec-reg64" stringcmp 0 = { drop -1 exit } if + dup s" and-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" and-reg68-imm8" stringcmp 0 = { drop -2 exit } if + dup s" or-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" or-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" xor-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" not-reg64" stringcmp 0 = { drop -1 exit } if + dup s" cmp-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" test-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" set-reg8-cc" stringcmp 0 = { drop -2 exit } if + dup s" jmp-cc-rel-imm8" stringcmp 0 = { drop -2 exit } if + dup s" jmp-cc-rel-imm32" stringcmp 0 = { drop -2 exit } if + dup s" jmp-abs-indirect-reg64" stringcmp 0 = { drop -1 exit } if + dup s" jmp-rel-imm8" stringcmp 0 = { drop -1 exit } if + dup s" jmp-rel-imm32" stringcmp 0 = { drop -1 exit } if + + ~ From execution-support.e. + dup s" pack-next" stringcmp 0 = { drop 0 exit } if + dup s" pack-beforenext" stringcmp 0 = { drop -1 exit } if + dup s" pack-pushcontrol" stringcmp 0 = { drop -1 exit } if + dup s" pack-popcontrol" stringcmp 0 = { drop -1 exit } if + + ~ Word not provided statically, but used during the log-load routine anyway. + dup s" here" stringcmp 0 = { drop 1 exit } if + dup s" [" stringcmp 0 = { drop 0 exit } if + dup s" ]" stringcmp 0 = { drop 0 exit } if + dup s" :" stringcmp 0 = { drop 0 exit } if + dup s" ;" stringcmp 0 = { drop 0 exit } if + dup s" ;asm" stringcmp 0 = { drop 0 exit } if + dup s" L@'" stringcmp 0 = { drop 1 exit } if + dup s" L!'" stringcmp 0 = { drop -1 exit } if + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. We also return a comically large negative value, + ~ to make sure things fail as quickly as possible afterwards. + ." No known stack delta: " emitstring newline + -256 ; + + +~ (delta --) +: transform-apply-stack-delta + transform-state transform-state-user-stack-depth @ + + transform-state transform-state-user-stack-depth ! ; + + ~ Label transform implementation ~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~ @@ -469,6 +864,137 @@ allocate-transform-state s" transform-state" variable ; make-immediate +~ We implement alternates of all the high-level flow-control words for the +~ label transform: if, unless, if-else, forever, and while. We leave { and } +~ as their usual implementations. The values { and } leave on the stack will +~ be in the host address space, which is convenient anyway. Those values don't +~ make their way into the output, since everything is relative, and the +~ relative offsets are correct regardless. What we do need to change, though, +~ is the addresses of branch and 0branch. We need to resolve these via label. +~ +~ (start pointer, length --) +: label-if-alternate + 2dup swap dup 5 8 * + 3unroll swap + ~ (start pointer, length, start pointer, adjusted start pointer, length) + memmove + ~ (start pointer, length) + swap here @ swap here ! swap + ~ (old here, length) + swap-transform-variables + L@' 0branch + L@' != + L@' lit + swap-transform-variables + offset-to-target-address-space , 0 , ~ lit + offset-to-target-address-space , ~ != + ~ The branch length needs to be one word longer than the block length, + ~ because the length field itself is part of the scope of the branch. + offset-to-target-address-space , dup 8 + , ~ 0branch + ~ (old here, length) + drop 5 8 * + here ! + ; make-immediate + +~ (start pointer, length) +: label-unless-alternate + 2dup swap dup 5 8 * + 3unroll swap + ~ (start pointer, length, start pointer, adjusted start pointer, length) + memmove + ~ (start pointer, length) + swap here @ swap here ! swap + ~ (old here, length) + swap-transform-variables + L@' 0branch + L@' = + L@' lit + swap-transform-variables + offset-to-target-address-space , 0 , ~ lit + offset-to-target-address-space , ~ = + ~ The branch length needs to be one word longer than the block length, + ~ because the length field itself is part of the scope of the branch. + offset-to-target-address-space , dup 8 + , ~ 0branch + ~ (old here, length) + drop 5 8 * + here ! + ; make-immediate + +~ (true start, true length, false start, false length) +: label-if-else-alternate + ~ First we slide the false-block forward, then the true-block. We slide + ~ them both directly into their final positions, leaving space at the start + ~ for a test and branch, and space in between for an unconditional branch. + ~ Those spaces will take five words, and two words, respectively. So the + ~ false-block gets moved by seven words, and the true-block gets moved by + ~ five words. + 2dup swap dup 7 8 * + swap 3roll memmove + 4 roll dup 5 unroll 4 roll dup 5 unroll + swap dup 5 8 * + swap 3roll memmove + ~ (true start, true length, false start, false length) + + ~ Now we write out the initial test-and-branch. + 4 roll dup 5 unroll here @ 6 unroll here ! + ~ (old here, true start, true length, false start, false length) + swap-transform-variables + L@' 0branch + L@' != + L@' lit + swap-transform-variables + offset-to-target-address-space , 0 , ~ lit + offset-to-target-address-space , ~ != + ~ Branch past the length field, the true-block, and the unconditional + ~ branch in the middle. + offset-to-target-address-space , ~ 0branch + 3roll dup 4 unroll 3 8 * + , + + ~ Next, write out the unconditional branch in the middle. + swap dup 3unroll 5 8 * + here ! + swap-transform-variables + L@' branch + swap-transform-variables + offset-to-target-address-space , ~ branch + ~ Branch past the length field and the false-block. + dup 8 + , + + ~ Set "here" to point to the true end. + drop drop drop drop 7 8 * + here ! + ; make-immediate + +~ (start, length --) +: label-forever-alternate + swap-transform-variables + L@' branch + swap-transform-variables + offset-to-target-address-space , ~ branch + 8 + -1 * , drop + ; make-immediate + +~ (test start, test length, body start, body length --) +: label-while-alternate + ~ The conditional branch needs five words. + 2dup swap dup 5 8 * + swap 3roll memmove + here @ 5 unroll swap dup 3unroll here ! + ~ (old here, test start, test length, body start, body length) + swap-transform-variables + L@' 0branch + L@' != + L@' lit + swap-transform-variables + offset-to-target-address-space , 0 , ~ lit + offset-to-target-address-space , ~ != + ~ Branch past the length field, the body, and the unconditional branch. + offset-to-target-address-space , ~ 0branch + dup 3 8 * + , + ~ Set "here" to the new end. + 5 8 * 6 roll + here ! + ~ (test start, test length, body start, body length) + ~ Unconditionally branch backwards past the branch word, the body, the + ~ conditional branch, and the test. + swap-transform-variables + L@' branch + swap-transform-variables + offset-to-target-address-space , + 6 8 * + swap drop + swap drop -1 * , + ; make-immediate + + ~ This implements the label transform for a single word. It is directly ~ analogous to "interpret", and reading interpret.e may help in understanding ~ it, though it's meant to still make sense on its own. @@ -503,6 +1029,13 @@ allocate-transform-state s" transform-state" variable dup s" L!'" stringcmp 0 = { swap drop ' label-L!'-alternate swap } if dup s" keyword" stringcmp 0 = { swap drop ' label-keyword-alternate swap } if + dup s" if" stringcmp 0 = { swap drop ' label-if-alternate swap } if + dup s" unless" stringcmp 0 = { swap drop ' label-unless-alternate swap } if + dup s" if-else" stringcmp 0 = { + swap drop ' label-if-else-alternate swap } if + dup s" forever" stringcmp 0 = { + swap drop ' label-forever-alternate swap } if + dup s" while" stringcmp 0 = { swap drop ' label-while-alternate swap } if drop swap ~ (name as stack string, 0 or alternate entry pointer, name pointer) @@ -713,6 +1246,237 @@ allocate-transform-state s" transform-state" variable ~ For conceptual overview, see the top of this file. +~ This outputs code that performs a roll of a given size, for use by the +~ words that rely on the tracked user stack depth. +~ +~ (amount to roll by --) +: log-load-roll + ~ A roll of size 1 is an nop, and a roll of size 0 crashes. + dup 2 > { drop exit } if + + ~ A roll of size 2 is equivalent to a swap, and we compile it as one for + ~ clarity when reading the hexdump. + ~ + ~ Yes, clarity when reading the hexdump. + dup 2 = { + drop + + swap-transform-variables + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ swap + + exit + } if + + swap-transform-variables + L@' roll + L@' lit + swap-transform-variables + + offset-to-target-address-space , ~ lit + swap , + offset-to-target-address-space , ~ roll + ; + + +~ This outputs code that perfoms an unroll of a given size, for use by the +~ words that rely on the tracked user stack depth. + +~ (amount to unroll by --) +: log-load-unroll + ~ An unroll of size 1 is an nop, and an unroll of size 0 crashes. + dup 2 > { drop exit } if + + ~ Yes, clarity when reading the hexdump! What's so weird about that? :) + dup 2 = { + drop + + swap-transform-variables + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ swap + + exit + } if + + swap-transform-variables + L@' unroll + L@' lit + swap-transform-variables + + offset-to-target-address-space , ~ lit + swap , + offset-to-target-address-space , ~ unroll + ; + + +~ This checks the tracked user stack depth and outputs an appropriate roll +~ to put the log address on top, as preparation for calling something that +~ relies on it. +: log-load-roll-log-address + transform-state transform-state-user-stack-depth @ + ~ The amount we're rolling includes the log address, which is not a user + ~ value, so we add 1. + 1 + + log-load-roll ; + + +~ This checks the tracked user stack depth and outputs an appropriate unroll +~ to put the log address back at the bottom, as cleanup after calling +~ something that relies on it. +: log-load-unroll-log-address + transform-state transform-state-user-stack-depth @ + ~ The amount we're rolling includes the log address, which is not a user + ~ value, so we add 1. + 1 + + log-load-unroll ; + + +~ This checks the tracked user stack depth and outputs an appropriate roll +~ to put the saved label value on top, as preparation for calling something +~ that consumes it. +: log-load-roll-saved-label + transform-state transform-state-user-stack-depth @ + ~ The amount we're rolling includes both the log address and the label + ~ value, neither of which are user values, so we add 2. + 2 + + log-load-roll ; + + +~ This checks the tracked user stack depth and outputs an appropriate unroll +~ to put a saved label value on the bottom, as a way of safely storing it away +~ when it's newly generated. +: log-load-unroll-saved-label + transform-state transform-state-user-stack-depth @ + ~ The amount we're rolling includes both the log address and the label + ~ value, neither of which are user values, so we add 2. + 2 + + log-load-unroll ; + + +~ (name pointer --) +: log-load-compile-dynamic-word + log-load-roll-log-address + + swap-transform-variables + ~ Looking these up in reverse order saves us some stack juggling. Does it + ~ help readability, or hurt it? Who can say... + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + ~ (name pointer, log-load-comma, log-load-find-execution-token, litstring) + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ litstring + 3roll here @ swap packstring 8 packalign here ! + offset-to-target-address-space , ~ log-load-find-execution-token + offset-to-target-address-space , ~ log-load-comma + + log-load-unroll-log-address ; + + +~ When we want the log-load routine to run a word that wasn't statically +~ compiled-in to the target executable, we output code that looks up the word +~ by name on the log, then calls it. +~ +~ We update the user stack depth as we go, to account for our internal +~ needs. The last thing our generated code does is execute the word we were +~ asked to, and we have no way of knowing what its stack delta will be, so +~ that final delta is our caller's responsibility. The caller should only +~ consider the delta of the word it requested itself; we handle everything +~ pertaining to retrieving, and then consuming, its execution token. +~ +~ (name pointer --) +: log-load-execute-dynamic-word + log-load-roll-log-address + + swap-transform-variables + ~ This is reverse order again. + L@' swap + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + ~ (name pointer, swap, log-load-find-execution-token, litstring) + + offset-to-target-address-space , ~ litstring + 3roll here @ swap packstring 8 packalign here ! + offset-to-target-address-space , ~ log-load-find-execution-token + offset-to-target-address-space , ~ swap + + ~ Now the execution token is on the stack, immediately below the log + ~ address, so we apply a delta for it. + 1 transform-apply-stack-delta + + log-load-unroll-log-address + + swap-transform-variables + L@' execute + swap-transform-variables + + offset-to-target-address-space , ~ execute + + ~ Invoking execute consumes the execution token, which is a delta of -1. + ~ Any additional delta is our caller's responsibility, per above. + -1 transform-apply-stack-delta ; + + +~ We generate code that looks up "docol" by name, runs it to get the +~ codeword pointer, then finally appends it to the entry. +~ +~ This one's unusual in that it first executes the word, then compiles the +~ result. To avoid rolling and unrolling repeatedly, we implement it as a +~ special case. For clarity's sake we put the code here, with the other +~ dynamic word stuff. +~ +: log-load-compile-docol + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma + L@' execute + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ litstring + here @ s" docol" packstring 8 packalign here ! + offset-to-target-address-space , ~ log-load-find-execution-token + offset-to-target-address-space , ~ execute + offset-to-target-address-space , ~ log-load-comma + + log-load-unroll-log-address ; + + +~ There's one more compilation case, where we wish to compile an integer +~ literal. Again, for clarity, we do it here. +~ +~ (integer value --) +: log-load-compile-literal + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma + L@' log-load-comma + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ litstring + here @ s" lit" packstring 8 packalign here ! + offset-to-target-address-space , ~ log-load-comma + swap , ~ the value + offset-to-target-address-space , ~ log-load-comma + + log-load-unroll-log-address ; + + ~ This is the alternate version of "create" for use with the log-load ~ transform. This one is quite unlike the regular "create"; rather than ~ creating an entry on the log directly, its job is to output words which, @@ -723,16 +1487,20 @@ allocate-transform-state s" transform-state" variable ~ ~ (string pointer --) : log-load-create-alternate + log-load-roll-log-address + swap-transform-variables - ~ Looking these up in reverse order saves us some stack juggling. Does it - ~ help readability, or hurt it? Who can say... + ~ Just like in log-load-compile-dynamic-word, we do this in reverse. L@' log-load-create L@' litstring swap-transform-variables + + ~ The overall stack delta of this sequence is 0. offset-to-target-address-space , ~ litstring swap here @ swap packstring 8 packalign here ! offset-to-target-address-space , ~ log-load-create - ; + + log-load-unroll-log-address ; ~ This is the alternate version of ":" for use with the log-load transform. @@ -745,19 +1513,7 @@ allocate-transform-state s" transform-state" variable ~ We generate code that looks up "docol" by name, runs it to get the ~ codeword pointer, then finally appends it to the entry. - swap-transform-variables - ~ As usual, we do these in reverse. - L@' log-load-comma - L@' execute - L@' log-load-find-execution-token - L@' litstring - swap-transform-variables - - offset-to-target-address-space , ~ litstring - here @ s" docol" packstring 8 packalign here ! - offset-to-target-address-space , ~ log-load-find-execution-token - offset-to-target-address-space , ~ execute - offset-to-target-address-space , ~ log-load-comma + log-load-compile-docol ~ This is where we would mark the entry hidden, but we don't do that. It ~ won't shadow anything and it won't be called until the entire log-load @@ -776,6 +1532,8 @@ allocate-transform-state s" transform-state" variable : log-load-semicolon-alternate ~ We generate code that looks up "exit" by name and appends it to the ~ entry. + log-load-roll-log-address + swap-transform-variables ~ As usual, we do these in reverse. L@' log-load-comma @@ -783,11 +1541,14 @@ allocate-transform-state s" transform-state" variable L@' litstring swap-transform-variables + ~ The overall stack delta of this sequence is 0. offset-to-target-address-space , ~ litstring here @ s" exit" packstring 8 packalign here ! offset-to-target-address-space , ~ log-load-find-execution-token offset-to-target-address-space , ~ log-load-comma + log-load-unroll-log-address + ~ This is where we would unhide the entry, but again, we don't do that. ~ Since [ is an immediate word, we have to go to extra trouble to compile @@ -801,6 +1562,7 @@ allocate-transform-state s" transform-state" variable ~ below. It is likely to be extremely useful to read and understand ";asm" in ~ interpret.e before attempting to understand "log-load;asm". : log-load-semicolon-assembly-alternate + ~ TODO this is just unimplemented, which seems bad :D ~ here @ pack-next 8 packalign here ! ~ latest @ dup unhide-entry entry-to-execution-token ~ ~ The codeword needs to be transformed to the target address space. @@ -822,17 +1584,25 @@ allocate-transform-state s" transform-state" variable ~ the value on the stack when the generated log-load routine runs. So, each ~ instance of L@' must be closely followed by a matching instance of L!'. Each ~ label can only ever be used exactly once, and it must be a backward -~ reference. Furthermore, there is a very tight restriction on what can be -~ on the stack. The easiest way to explain it is by showing the interface of -~ these words from the transformed code's perspective: +~ reference. Furthermore, the stack is used in a very specific way, which the +~ transformed code must be compatible with. The easiest way to explain it is +~ by showing the interface of these words from the transformed code's +~ perspective: ~ -~ L!' is (preserved value, value of label -~ -- value of label, preserved value) -~ L@' is (value of label, preserved value -~ -- preserved value, value of label) +~ L!' is (preserved values, ..., ..., value of label +~ -- value of label, preserved values, ..., ...) +~ L@' is (value of label, preserved values, ..., ...) +~ -- preserved values, ..., ..., value of label) ~ -~ The preserved value is simply another item on the stack, which the label -~ takes pains not to interfere with. +~ The preserved values are simply more items on the stack, which the +~ alternates take pains not to interfere with. The alternates output a roll or +~ unroll of an appropriate size. Hopefully, in reading this, you have the +~ question: How can the alternates possibly know what size is appropriate? +~ The answer is that the log-load transform carefully tracks how many items +~ the transformed code is expected to have on the stack, based on its +~ hardcoded understanding of each word that's expected to be relevant, looked +~ up by the word's name. The number of items is stored in the user-stack-depth +~ field of transform-state. ~ ~ There is no adjustment done on the saved value, since it's created in the ~ target address space and then also used in the target address space. It @@ -841,31 +1611,25 @@ allocate-transform-state s" transform-state" variable ~ depending on which transform it's running under, and there'd have to be a ~ mechanism for that. ~ -~ If that sounds super complex: All we actually do is read a label name, -~ ignore it, and output a call to swap. -~ ~ This is sufficient to implement docol, and that's probably the only thing ~ it should be used for. : log-load-L@'-alternate word dropstring - - swap-transform-variables - L@' swap - swap-transform-variables - - offset-to-target-address-space , ~ swap + log-load-roll-saved-label + ~ We now begin thinking of the label value as user data, so we need to + ~ notate that appropriately. + 1 transform-apply-stack-delta ; make-immediate : log-load-L!'-alternate word dropstring - - swap-transform-variables - L@' swap - swap-transform-variables - - offset-to-target-address-space , ~ swap + ~ We cease to think of the label value as user data, so we need to notate + ~ that appropriately. + -1 transform-apply-stack-delta + log-load-unroll-saved-label ; make-immediate + ~ This implements the log-load transform for a single word. It is directly ~ analogous to "interpret", and reading interpret.e may help in understanding ~ it, though it's meant to still make sense on its own. @@ -901,8 +1665,7 @@ allocate-transform-state s" transform-state" variable swap drop ' log-load-semicolon-assembly-alternate swap } if dup s" L@'" stringcmp 0 = { swap drop ' log-load-L@'-alternate swap } if dup s" L!'" stringcmp 0 = { swap drop ' log-load-L!'-alternate swap } if - drop - ~ (name as stack string, 0 or alternate entry pointer) + ~ (name as stack string, 0 or alternate entry pointer, name pointer) ~ If we have an alternate, we want to run that now, regardless of what ~ mode we're in. They're all flagged as immediate, but we don't even bother @@ -910,11 +1673,12 @@ allocate-transform-state s" transform-state" variable ~ this transform there's three potential times at which we might execute ~ things, not two. The alternates are more immediate than immediate; they ~ run NOW, during the transformation. - dup { - dropstring-with-result entry-to-execution-token execute + over { + drop dropstring-with-result + entry-to-execution-token execute 0 exit } if - drop + drop drop ~ (name as stack string) ~ Now we might have a compiled word, an immediate word, or an integer @@ -929,32 +1693,26 @@ allocate-transform-state s" transform-state" variable ~ shadow an integer literal with a word definition. Oh, so limiting. value@ read-integer 0 = { ~ It's a number. + ~ + ~ (name as stack string, integer value) dropstring-with-result + ~ (integer value) interpreter-flags @ 0x01 & { ~ We're in compile mode, so we want to generate code which will compile ~ the number. - - swap-transform-variables - ~ Just like in log-load-create-alternate, we do these in reverse. - L@' log-load-comma - L@' log-load-comma - L@' litstring - swap-transform-variables - - offset-to-target-address-space , ~ litstring - here @ s" lit" packstring 8 packalign here ! - offset-to-target-address-space , ~ log-load-comma - swap , ~ the value - offset-to-target-address-space , ~ log-load-comma - + log-load-compile-literal 0 exit } if - ~ We're in interpret mode, so we want to generate code which will push the - ~ number to the stack. + ~ We're in interpret mode, so we want to generate code which will push + ~ the number to the stack. + ~ + ~ This is an immediate effect, so once we've done it, we update the user + ~ stack depth. An integer literal is a stack-depth delta of 1. swap-transform-variables L@' lit swap-transform-variables offset-to-target-address-space , , + 1 transform-apply-stack-delta 0 exit } if ~ (name as stack string) @@ -964,23 +1722,24 @@ allocate-transform-state s" transform-state" variable ~ means immediate words don't work with this transform. We still treat it ~ differently based on whether we're in compile mode. interpreter-flags @ 0x01 & { - ~ We're in compile mode. We compile code that compiles the word. - value@ - swap-transform-variables - ~ Just like in log-load-create-alternate, we do these in reverse. - L@' log-load-comma - L@' log-load-find-execution-token - L@' litstring - swap-transform-variables - - offset-to-target-address-space , ~ litstring - 3roll here @ swap packstring 8 packalign here ! - offset-to-target-address-space , ~ log-load-find-execution-token - offset-to-target-address-space , ~ log-load-comma + ~ We're in compile mode. We compile code that compiles the word. + ~ + ~ Since that's not an immediate effect, we don't need to update the + ~ user stack depth. Instead, this is a key spot where we rely on that + ~ knowledge, to roll and unroll the log address. + value@ log-load-compile-dynamic-word dropstring 0 exit } if ~ (name as stack string) + ~ At this point we know we're in immediate mode and have a regular word. + ~ While we still have the name pointer handy, we check what delta this word + ~ will cause for the user stack depth, when run. See + ~ transform-get-stack-delta for more explanation of this. We keep track of + ~ the proposed delta until we actually process the word, down below. + value@ dup transform-get-stack-delta swap + ~ (name as stack string, proposed stack depth delta, name pointer) + ~ We're in immediate mode. We compile code that runs the word immediately. ~ We check whether there's a label for the word; if there is, we'll output ~ that. Otherwise we'll output code that looks it up in the log and runs it. @@ -999,44 +1758,42 @@ allocate-transform-state s" transform-state" variable ~ The first pass will never accidentally think it succeeded, because even ~ the reference to L' cold-start from the ELF header is a forward reference ~ and won't exist on the first pass. - value@ + dup swap-transform-variables find-label swap-transform-variables { ~ Again just like in label-transform, we declare our use of the label ~ and get a value for it. - value@ swap-transform-variables intern-label use-label swap-transform-variables + ~ (name as stack string, proposed stack depth delta, label value) ~ Like in label-transform, this is a codeword pointer, so we just output ~ it directly. Also as before, because we don't have to examine it, we ~ don't have to do anything special in the case where it's zero due to the ~ way the label loop works. - offset-to-target-address-space , dropstring 0 exit + ~ + ~ This is an immediate effect, so once we've done that, we update the + ~ user stack depth. + offset-to-target-address-space , + transform-apply-stack-delta dropstring 0 exit } if + ~ (name as stack string, proposed stack depth delta, name pointer) ~ There's no label for the word; that means it wasn't statically ~ compiled-in to the target executable. So we output code that looks up the ~ word by name on the log, then calls it. - value@ - swap-transform-variables - ~ This is reverse order again. - L@' execute - L@' log-load-find-execution-token - L@' litstring - swap-transform-variables - - offset-to-target-address-space , ~ litstring - 3roll here @ swap packstring 8 packalign here ! - offset-to-target-address-space , ~ log-load-find-execution-token - offset-to-target-address-space , ~ execute - - ~ There's no such thing as not finding the word, with this transform. So - ~ we just exit. + ~ + ~ This is also an immediate effect, despite being distinct from the above + ~ case, so once we've done that, we update the user stack depth. + ~ + ~ There's no such thing as not finding the word, with this transform. So + ~ once we're done, we just exit. + log-load-execute-dynamic-word + transform-apply-stack-delta dropstring 0 ; @@ -1056,9 +1813,13 @@ allocate-transform-state s" transform-state" variable ~ since client code will make its own updates to them and then rely on those ~ updates having taken effect. So we do the swap just once, here outside the ~ loop, and set it back when the loop ends. + ~ + ~ We also take this opportunity to initialize the output-buffer-start and + ~ user-stack-depth fields of transform-state. here @ transform-state transform-state-saved-here ! latest @ transform-state transform-state-saved-latest ! over transform-state transform-state-output-buffer-start ! + 0 transform-state transform-state-user-stack-depth ! here ! 0 latest ! ~ Now the stack has nothing of ours on it, so client code can do its thing. @@ -1082,6 +1843,7 @@ allocate-transform-state s" transform-state" variable 0 transform-state transform-state-saved-here ! 0 transform-state transform-state-saved-latest ! 0 transform-state transform-state-output-buffer-start ! + 0 transform-state transform-state-user-stack-depth ! ~ Also put the input source back how it was. main-input-buffer pop-input-buffer -- cgit 1.4.1