diff options
Diffstat (limited to 'compilation/transform.e')
| -rw-r--r-- | compilation/transform.e | 6512 |
1 files changed, 6512 insertions, 0 deletions
diff --git a/compilation/transform.e b/compilation/transform.e new file mode 100644 index 0000000..80ef98b --- /dev/null +++ b/compilation/transform.e @@ -0,0 +1,6512 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Code transformation facility ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The process of producing an executable binary out of Evocation involves +~ various bootstrapping phases during which code operates under different +~ constraints, and must be written with different styles. In some cases, +~ substantially the same code must be output multiple times in slightly +~ different ways, and it would be both arduous and verbose to write each of +~ these directly. +~ +~ To solve this problem, this file implements a concept of code +~ transformation. There are two transforms, the label transform and the +~ log-load transform, each of which takes a string containing Evocation source +~ code and produces compiled code that has been modified to operate in a +~ specific way. The transforms rely on the label facility provided by +~ compilation/labels.e, and expect to run from within label-loop. +~ +~ The label transform produces code that uses one label per word it defines, +~ to statically reference everything. Thus, when output to an executable +~ binary, this code will function without external dependencies. The tradeoff +~ is that it has no way to reference data that exists only at runtime. +~ +~ The log-load transform relies on labels, but doesn't add any of its own. +~ It produces a compiled routine which, when run, dynamically looks up all the +~ references in the log, and appends the original code to the log. This adds +~ work that must be done when the runtime starts up, but the benefit is that +~ it can reference data that doesn't exist at compile-time. Most crucially, +~ it can reference the "here" and "latest" pointers in the log, which are +~ required for all the usual word-definition stuff to work, and whose +~ addresses are not known until runtime. +~ +~ The log-load transform may also be useful for experimental tasks such as +~ creating additional, independent logs, or injecting Evocation into another +~ process's address space. +~ +~ Please notice that both these transforms, in different ways, navigate the +~ same underlying design tension: The Forth compilation model hardcodes +~ references at the time compilation happens, and Evocation makes the choice +~ to not decide the address of the log until runtime. Thus the label transform +~ can't be sufficient on its own. Other Forths avoid this problem by +~ hardcoding an address for the log, or by using OS-provided load-time +~ symbol relocation. Evocation, however, does it on hard mode, mostly for fun. +~ +~ Because it was clear from early on that the label transform couldn't stand +~ alone, and that another one would be necessary, we've refrained from adding +~ too many features to it. Since we have multiple transforms, they should each +~ be kept simple and well-defined, so that they can be composed in creative +~ new ways down the line. When adding additional behavior, always give thought +~ to whether it belongs in an existing transform or a new one. +~ +~ +~ About the label transform +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The label transform operates on code that compiles itself, and ensures +~ that the result of the compilation is suitable to be included in an +~ executable binary as words that are statically referenced by their +~ addresses. To achieve this, it causes each newly-defined word to have a +~ corresponding label whose value is the offset of its codeword, and it causes +~ all compiled invocations of other words to be resolved by using these labels. +~ The label transform is suitable for code that must be directly invoked by +~ the warm-start routine provided by compilation/execution.e. +~ +~ The most fundamental technique the label transform performs is to separate +~ words that run in compile mode from words that run immediately. There is no +~ distinction made between words running in immediate mode, and words declared +~ as immediate. Immediate words are looked up and executed based on their +~ "real", currently-executing definitions. Compiled words, including +~ literals, are looked up via the label facility. +~ +~ Since the label facility is able to resolve forward references, there is +~ no hard requirement that everything in the file be topologically sorted. +~ However, the transform will refuse to create forward references to compiled +~ words. If you want them, you can create them by hand by calling use-label +~ yourself. This restriction is in place because allowing forward references +~ would be a significant difference from un-transformed code that could easily +~ become confusing, and because it simplifies the implementation a bit. +~ +~ Compilation words do make extensive reference to the global variables +~ "here" and "latest". In particular, flow-control words such as if-else +~ expect the log to have recent compilation outputs on it, and to be able to +~ mutate them in-place. In order to make this work, we provide temporary +~ values of these two variables which point to the location of the output +~ buffer. This allows pointer resolution to work correctly without additional +~ effort, but notice that the buffer's address will differ from the address +~ the resulting program loads itself at. There's no simple way to avoid this +~ concern, since the variables must point to one of those addresses or the +~ other, not both. +~ +~ We resolve the issue by running our own, alternate versions of most of the +~ critical word-defining words, including for example "create", ":", and ";". +~ These alternates run instead of the normal versions of these words, and use +~ the label facility to compute the addresses that will be needed at runtime. +~ The code being compiled is responsible for not doing anything else that +~ would rely on "here" and "latest" matching their runtime addresses, though +~ it is otherwise allowed to modify and rely on them in all the usual ways. +~ The alternate versions are defined in this file as their own words, +~ "label-create-alternate" and so on. +~ +~ Note that these alternates are applied via a purely lexical +~ transformation: when a word would be looked up in the dictionary to +~ interpret, first check if it's one of these. That means the transformation +~ won't apply to indirect callers of these words, nor to tick-quotes of them. +~ The code being compiled is responsible for not doing either of those things. +~ +~ Notably, the transformation uses the same "interpreter-flags" variable as +~ the rest of Evocation. There's no need to keep it separate like there is +~ with the other variables. This makes it easy to change modes. +~ +~ The label transformation and its alternates rely on various labels, all of +~ which must be defined elsewhere, lest the label loop fail to converge: +~ "lit", "origin", "docol", "exit", ":", ";", and ";asm". +~ +~ All of these limitations result in the compiled code being, in effect, +~ written in a dialect which is like Evocation, but more restricted. This is +~ acceptable, because the label transform is intended for compiling code that +~ is an early part of Evocation itself, and the necessary code has all been +~ written to follow these restrictions. +~ +~ +~ About the log-load transform +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The log-load transform also operates on code that compiles itself; it +~ produces a compiled routine which, when run, appends the original code to +~ the log. As the routine is run, each reference to another word is resolved +~ by looking up the name of the target word in the log. Furthermore, these +~ lookups are done using log-load-find, defined in language/static/log-load.e, +~ which accepts a pointer to the log's base address as a parameter. See that +~ file for more explanation of what the log is and why it's important. Thus, +~ unlike normal accesses to the log, this routine doesn't rely on already +~ having the log's base address hardcoded into it at the time of its own +~ compilation. The log-load transform is suitable for implementing the core +~ responsibilities of the warm-start routine provided by +~ compilation/execution.e, relying on only a few specific words that it +~ statically references via labels. +~ +~ Much like the label transform, the log-load transform provides alternate +~ versions of certain immediate words used in word definition. Also like the +~ label transform, it provides its own copies of "here" and "latest". +~ +~ The log-load transform provides alternates for a significantly broader set +~ of words than the label transform, including all the flow-control words such +~ as if-else. It runs its own alternates immediately, but unlike the label +~ transform, immediate execution for the log-load transform is not actually +~ immediate; it is compiled into words which will have those immediate effects +~ at the time the generated routine is run. The generated routine can itself +~ be thought of as a compilation process, producing its output on the log, so +~ doing things later for us still means doing them immediately during the +~ routine. +~ +~ The log-load transform does impose a no-forward-references requirement, +~ though it is applied at the time the routine is run, rather than at the time +~ of the transformation. +~ +~ The log-load transformation and its alternates rely on the following +~ labels, all of which must be defined elsewhere: TODO +~ +~ +~ About the hex transform +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The hex transform's role is a bit different. Whereas the label and +~ log-load transforms are used as part of generating an executable binary, the +~ hex transform produces a commented hex dump that, when later processed by +~ the "hex" tool, produces that same binary. It achieves this by modifying +~ various words which are core parts of Evocation to keep track of appropriate +~ comments and other metadata, and modifying the output facility to output a +~ hex dump with any attached comments, rather than raw bytes. +~ +~ By its nature, the hex transform needs to be able to cope with other +~ transforms running inside itself; that is, the transformation facility needs +~ to be reentrant. The other transforms don't have to cope with that, since +~ the code they run is mostly just about creating word definitions, but the +~ code given to the hex transform will normally include a call to label-loop, +~ all the memory manipulation that happens as part of binary generation, and +~ various output words. +~ +~ While the label and log-load transforms allow Evocation to be a +~ self-hosting compiler, the hex transform attains the even higher bar of +~ making Evocation a "self-bootstrapping" compiler, able to create a running +~ copy of itself without having any sort of pre-existing compiler at all, only +~ a hex converter or similar small tool. The idea is that the hex converter is +~ small and simple enough that it's easy to perform a BINARY audit on, and +~ that there need be no other binary artifacts in the chain of trust. +~ +~ This is not a new concept, but as far as Irenes are aware this name for it +~ is a new coinage. The approach of using a hex-to-binary conversion tool as +~ the initial bootstrapping stage is due to MesCC, which is quite inspiring in +~ that regard. +~ +~ The key insight is that, some sense, the difference between source code +~ and binary is the ability to have comments. +~ +~ The hex transform keeps some large, complex state as it runs, unlike the +~ label and log-load transforms, which only require very simple state. This +~ state is called the "output metadata". Entries in the output metadata are +~ created and modified as the code under transform runs, by "magic comments" +~ embedded within it. There is a complex command language for these comments, +~ which must be understood to write code designed to make good use of the hex +~ transform. Fortunately, that's really just assembly-language +~ implementations. +~ +~ It's quite an intense topic, and many readers may wish only to know that +~ the hex transform exists, not how it's structured. So, details on the output +~ metadata and the magic comments are described below, under "hex transform +~ implementation", rather than here. +~ +~ The hex transform DOES NOT WORK yet. It's still in development. +~ TODO update this note when it does work + + +~ Address-management helpers +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The facilities in this section are used as helper code in the +~ implementations of all three transforms. + + +~ We have a bunch of accessors for the transformation state structure, which +~ are all functions from pointers to pointers. We also define a global +~ variable which points to the transformation state. +: transformation-state-saved-here ; +: transformation-state-saved-latest 8 + ; +: transformation-state-output-buffer-start 2 8 * + ; +: transformation-state-user-stack-depth 3 8 * + ; +: transformation-state-label-scratch 4 8 * + ; +: transformation-state-output-metadata 5 8 * + ; +: allocate-transformation-state + 6 8 * allocate + dup transformation-state-saved-here 0 swap ! + dup transformation-state-saved-latest 0 swap ! + dup transformation-state-output-buffer-start 0 swap ! + dup transformation-state-user-stack-depth 0 swap ! + dup transformation-state-label-scratch 0 swap ! + dup transformation-state-output-metadata 0 swap ! ; +allocate-transformation-state s" transformation-state" variable + + +~ When calling the label facility during a transformation, it's necessary +~ to use the real, non-wrapped "here" and "latest". +: swap-transform-variables + here @ transformation-state transformation-state-saved-here @ + here ! transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest @ + latest ! transformation-state transformation-state-saved-latest ! ; + +~ We deal with a few address spaces. There's the "host" address space, the +~ space this process performing the compilation is using for itself. There's +~ the "target" address space, the address space that will exist later, when +~ the program we've compiled is running. +~ +~ Then there's "offsets", which are relative to the start of the output +~ buffer. For clarity's sake, we always refer to these as offsets, rather than +~ as addresses. +~ +~ When we define labels for compiled words, we set their values to be +~ offsets pointing to the generated codeword. This is done by +~ label-create-alternate. We then need to convert them either to the host or +~ the target address space, depending on how we're using them. +~ +~ There's no approach here that isn't confusing, but the hope is that by +~ using offsets, so that we always have to convert them regardless of what +~ we're doing with them, we won't miss a spot where conversion needs to +~ happen. +~ +~ (output offset -- target address) +: offset-to-target-address-space + ~ Don't transform null pointers. + dup { swap-transform-variables L@' origin swap-transform-variables + } if ; + +~ (target address -- output offset) +: target-address-space-to-offset + ~ Don't transform null pointers. + dup { swap-transform-variables L@' origin swap-transform-variables - } if ; + +~ (output offset -- host address) +: offset-to-host-address-space + ~ Don't transform null pointers + dup { transformation-state transformation-state-output-buffer-start @ + } if ; + +~ (host address --output offset) +: host-address-space-to-offset + ~ Don't transform null pointers + dup { transformation-state transformation-state-output-buffer-start @ - } if ; + +~ (host address inside the output buffer -- target address) +: host-address-space-to-target + host-address-space-to-offset offset-to-target-address-space ; + +~ (target address -- host address) +: target-address-space-to-host + target-address-space-to-offset offset-to-host-address-space ; + + +: describe-transformation + ." active here " here @ .hex64 space + ." latest " latest @ .hex64 newline + ." saved here " transformation-state transformation-state-saved-here + @ .hex64 space + ." latest " transformation-state transformation-state-saved-latest + @ .hex64 newline + ." output start " + transformation-state transformation-state-output-buffer-start + @ .hex64 newline + ." user stack depth " + transformation-state transformation-state-user-stack-depth + @ .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 transformation-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 compilation/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 language/static/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" 1+" stringcmp 0 = { drop 0 exit } if + dup s" 1-" 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" <=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 + 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 language/static/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 -2 exit } if + + ~ From language/static/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 + + ~ From language/static/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" push-extrareg64" stringcmp 0 = { drop -1 exit } if + dup s" pop-reg64" stringcmp 0 = { drop -1 exit } if + dup s" pop-extrareg64" 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-reg64-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 language/static/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 + + ~ From language/dynamic/dynamic.e. + dup s" stack" stringcmp 0 = { drop 0 exit } if + dup s" stackhex" stringcmp 0 = { drop 0 exit } if + dup s" is-in-log" stringcmp 0 = { drop 0 exit } if + dup s" oldest-entry" stringcmp 0 = { drop 1 exit } if + dup s" next-newer-entry" stringcmp 0 = { drop 0 exit } if + dup s" guess-entry-end" stringcmp 0 = { drop 0 exit } if + dup s" containing-entry" stringcmp 0 = { drop 0 exit } if + dup s" is-assembly-word" stringcmp 0 = { drop 0 exit } if + dup s" is-docol-itself" stringcmp 0 = { drop 0 exit } if + dup s" is-docol-codeword" stringcmp 0 = { drop 0 exit } if + dup s" is-docol-interpreted-word" stringcmp 0 = { drop 0 exit } if + dup s" is-codeword-pointer" stringcmp 0 = { drop 0 exit } if + dup s" indent" stringcmp 0 = { drop -1 exit } if + dup s" word-heading" stringcmp 0 = { drop -1 exit } if + dup s" list-dictionary" stringcmp 0 = { drop 0 exit } if + dup s" hexdump-row" stringcmp 0 = { drop -3 exit } if + dup s" hexdump-between" stringcmp 0 = { drop -2 exit } if + dup s" hexdump-from" stringcmp 0 = { drop -2 exit } if + dup s" hexdump" stringcmp 0 = { drop -1 exit } if + dup s" describe-hex" stringcmp 0 = { drop -1 exit } if + dup s" describe-docol" stringcmp 0 = { drop -1 exit } if + dup s" describe" stringcmp 0 = { drop -1 exit } if + dup s" describe-all" stringcmp 0 = { drop 0 exit } if + dup s" describe-compilation" stringcmp 0 = { drop 0 exit } if + dup s" symbolize-pointer" stringcmp 0 = { drop -1 exit } if + dup s" list-callers" stringcmp 0 = { drop 0 exit } if + dup s" forget" stringcmp 0 = { drop -1 exit } if + dup s" ," stringcmp 0 = { drop -1 exit } if + dup s" make-immediate" stringcmp 0 = { drop 0 exit } if + dup s" make-hidden" stringcmp 0 = { drop 0 exit } if + dup s" make-visible" stringcmp 0 = { drop 0 exit } if + dup s" recurse" stringcmp 0 = { drop 0 exit } if + dup s" recurse" stringcmp 0 = { drop 0 exit } if + dup s" find" stringcmp 0 = { drop 0 exit } if + dup s" allocate" stringcmp 0 = { drop 0 exit } if + dup s" create" stringcmp 0 = { drop -1 exit } if + dup s" self-codeword" stringcmp 0 = { drop 0 exit } if + dup s" variable" stringcmp 0 = { drop -2 exit } if + dup s" keyword" stringcmp 0 = { drop -1 exit } if + dup s" literal" stringcmp 0 = { drop -1 exit } if + + ~ From language/dynamic/input.e. + dup s" buffer-physical-start" stringcmp 0 = { drop 0 exit } if + dup s" buffer-physical-length" stringcmp 0 = { drop 0 exit } if + dup s" buffer-logical-start" stringcmp 0 = { drop 0 exit } if + dup s" buffer-logical-length" stringcmp 0 = { drop 0 exit } if + dup s" input-buffer-refill" stringcmp 0 = { drop 0 exit } if + dup s" input-buffer-next-source" stringcmp 0 = { drop 0 exit } if + dup s" clear-buffer" stringcmp 0 = { drop -1 exit } if + dup s" zero-input-buffer-metadata" stringcmp 0 = { drop -1 exit } if + dup s" allocate-input-buffer-metadata" stringcmp 0 = { drop 1 exit } if + dup s" allocate-input-buffer" stringcmp 0 = { drop 0 exit } if + dup s" attach-string-to-input-buffer" stringcmp 0 = { drop -2 exit } if + dup s" consume-from" stringcmp 0 = { drop -1 exit } if + dup s" peek-from" stringcmp 0 = { drop 0 exit } if + dup s" key-from" stringcmp 0 = { drop 0 exit } if + dup s" normalize-buffer" stringcmp 0 = { drop -1 exit } if + dup s" compute-next-buffer-free-block" stringcmp 0 = { drop 1 exit } if + dup s" refill-input-buffer-from-stdin" stringcmp 0 = { drop -1 exit } if + dup s" main-input-buffer" stringcmp 0 = { drop 1 exit } if + dup s" consume" stringcmp 0 = { drop 0 exit } if + dup s" peek" stringcmp 0 = { drop 1 exit } if + dup s" key" stringcmp 0 = { drop 1 exit } if + + ~ From language/dynamic/interpret.e. + dup s" unroll-past-string" stringcmp 0 = { drop 0 exit } if + dup s" swap-past-string" stringcmp 0 = { drop 0 exit } if + ~ The following are deliberate omissions: dropstring, + ~ dropstring-with-result, accumulate-string. + dup s" is-space" stringcmp 0 = { drop 0 exit } if + dup s" is-alphanumeric" stringcmp 0 = { drop 0 exit } if + ~ The following is a deliberate omission: word. + dup s" generalized-digit-value" stringcmp 0 = { drop 0 exit } if + ~ The following are deliberate omissions: decode-generalized-digit, + ~ read-base-unsigned, read-integer-unsigned, read-integer, read-decimal. + dup s" interpreter-flags" 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" '" stringcmp 0 = { drop 1 exit } if + dup s" relink-main-input-buffer-to-stdin" stringcmp 0 = { drop 0 exit } if + ~ The following is a deliberate omission: interpret. + dup s" quit" stringcmp 0 = { drop 0 exit } if + + ~ From language/dynamic/linux.e. + dup s" allocate-timespec" stringcmp 0 = { drop 1 exit } if + dup s" timespec-seconds" stringcmp 0 = { drop 0 exit } if + dup s" timespec-nanoseconds" stringcmp 0 = { drop 0 exit } if + dup s" nanosleep" stringcmp 0 = { drop 0 exit } if + dup s" sys-sigaction" stringcmp 0 = { drop -2 exit } if + dup s" sys-sigaltstack" stringcmp 0 = { drop -1 exit } if + dup s" allocate-sigaction" stringcmp 0 = { drop 1 exit } if + dup s" sigaction-action" stringcmp 0 = { drop 0 exit } if + dup s" sigaction-flags" stringcmp 0 = { drop 0 exit } if + dup s" sigaction-restorer" stringcmp 0 = { drop 0 exit } if + dup s" sigaction-mask" stringcmp 0 = { drop 0 exit } if + dup s" allocate-sigaltstack" stringcmp 0 = { drop 1 exit } if + dup s" sigaltstack-pointer" stringcmp 0 = { drop 0 exit } if + dup s" sigaltstack-flags" stringcmp 0 = { drop 0 exit } if + dup s" sigaltstack-size" stringcmp 0 = { drop 0 exit } if + dup s" prepare-signal-stack" stringcmp 0 = { drop 0 exit } if + ~ The following is a deliberate omission: signal-return-trampoline. + dup s" wrap-signal-handler" stringcmp 0 = { drop 0 exit } if + dup s" bind-signal" stringcmp 0 = { drop -2 exit } if + ~ The following is a deliberate omission: handle-crash. + dup s" install-crash-handler" stringcmp 0 = { drop 0 exit } if + + ~ Created by warm-start in compilation/execution.e. + dup s" log" stringcmp 0 = { drop 1 exit } if + dup s" s0" stringcmp 0 = { drop 1 exit } if + dup s" r0" stringcmp 0 = { drop 1 exit } if + dup s" latest" stringcmp 0 = { drop 1 exit } if + dup s" here" stringcmp 0 = { drop 1 exit } if + + ~ Word not provided statically, but used during the log-load routine anyway. + dup s" L@'" stringcmp 0 = { drop 1 exit } if + dup s" L!'" stringcmp 0 = { drop -1 exit } if + dup s" labels" stringcmp 0 = { drop 1 exit } if + dup s" allocate-transformation-state" 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 + transformation-state transformation-state-user-stack-depth @ + + transformation-state transformation-state-user-stack-depth ! ; + + +~ Label transform implementation +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The following code is all part of implementing the label transform. For +~ conceptual overview, see the top of this file. + + +~ This is the alternate version of "create" for use with the label +~ transform. Its code is the same as the regular "create" except as noted +~ below. It is likely to be extremely useful to read and understand "create" +~ in language/dynamic/dynamic.e before attempting to understand +~ label-create-alternate. +: label-create-alternate + ~ While we could put magic comments here, and be guaranteed to catch every + ~ word-defining word under the label transform, there's a subtle thing where + ~ we need to make sure the "indent" command happens in the same places it + ~ does when the same code runs under the log-load transform, and only those + ~ places. So, we do it in the callers of "create" instead. + dup stringlen 1 + + ~ : provide-data + dup 3unroll + here @ 10 + swap memmove + here @ + + ~ This value of "latest" is going into the generated output, so we need + ~ to map it to the target address space. It's stored in the host address + ~ space to make immediate words work as expected, so the appropriate + ~ conversion is host-address-space-to-target. + ~ : 8 #-- (previous entry pointer) + latest @ host-address-space-to-target pack64 + ~ : 1 #-- (entry flags) + 0 pack8 + ~ : bidirectional-null-terminated entry name + 0 pack8 + ~ : 1 data-adjust-output-point + ~ : fresh-line + + + 8 packalign + here @ latest ! + + ~ Now we're immediately after the word header, which is where the codeword + ~ will be. This is the value the label should taken on, so we set it. + dup host-address-space-to-offset + here @ 10 + + swap-transform-variables + intern-label set-label + swap-transform-variables + + here ! ; + + +~ This is the alternate version of ":" for use with the label transform. Its +~ code is the same as the regular "create" except as noted below. It is likely +~ to be extremely useful to read and understand ":" in +~ language/dynamic/dynamic.e before attempting to understand +~ label-colon-alternate. +: label-colon-alternate + ~ This calls label-create-alternate instead of "create". + word value@ + ~ : blank-line + ~ : blank-line + ~ : provide-string-copy + ~ : # is defined here via the label transform; this is its entry header. + ~ : indent + label-create-alternate dropstring + + ~ This looks up "docol" by label. + ~ : 8 #-- (docol codeword) + swap-transform-variables + L@' docol-codeword-value + L@' origin + swap-transform-variables + + , + ~ : blank-line + + latest @ dup entry-flags@ 0x80 | swap entry-flags! + ] ; + + +~ So, the way docol's user-facing entry is set up in language/static/core.e, +~ it really wants to reference "here" to create its codeword, but "here" is in +~ the host address space. We solve this by having it call the word +~ "self-codeword" and then patching around the address space issue with +~ alternates. +~ +~ If we didn't have this fix, everything would appear to work fine but the +~ statically generated user-facing docol from the label transform would have +~ a wrong codeword, varying based on the host's memory usage. It's never +~ actually called by evoke itself (it would crash horribly), though it may +~ be from programs that use the facilities differently. It's a binary +~ reproducibility issue - our only known one, in fact - so it's worth fixing. +: label-self-codeword-alternate + here @ dup 8 + host-address-space-to-target pack64 here ! + ; make-immediate + + +~ This is the alternate version of ";" for use with the label transform. Its +~ code is the same as the regular "create" except as noted below. It is likely +~ to be extremely useful to read and understand ";" in +~ language/dynamic/dynamic.e before attempting to understand +~ label-semicolon-alternate. +: label-semicolon-alternate + ~ This looks up "exit" by label. + swap-transform-variables + L@' exit + swap-transform-variables + offset-to-target-address-space , ~ : -8 exit #-- (codeword pointer) + ~ : deindent + + latest @ dup entry-flags@ 0x80 invert & swap entry-flags! + + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of ;. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ This is the alternate version of ";asm" for use with the label transform. +~ Its code is the same as the regular "create" except as noted below. It is +~ likely to be extremely useful to read and understand ";asm" in +~ language/dynamic/dynamic.e before attempting to understand +~ label-semicolon-assembly-alternate. +: label-semicolon-assembly-alternate + here @ pack-next 8 packalign + ~ : provide-data + here ! + ~ : deindent + + latest @ dup dup entry-flags@ 0x80 invert & swap entry-flags! + entry-to-execution-token + ~ The codeword needs to be transformed to the target address space. + ~ : provide-data + ~ : data-set-output-point + ~ : delete-last-comment-at-output-point + ~ : 8 #-- (self codeword) + dup 8 + host-address-space-to-target + swap ! + ~ : data-set-output-point + + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of ;asm. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ TODO there should really be an actual word that this alternate is replacing +~ +~ If it existed, that word would be (string pointer --). +: label-keyword-alternate + ~ : blank-line + ~ : blank-line + ~ : provide-string-copy + ~ : # is defined here via the label transform; this is its entry header. + ~ : indent + label-create-alternate + + here @ dup + ~ (self execution token, output point) + dup 8 + host-address-space-to-target pack64 + swap host-address-space-to-target :rax mov-reg64-imm64 + ~ (output point) + :rax push-reg64 + pack-next + 8 packalign + here ! + ~ : deindent + ; make-immediate + + +~ It's convenient to be able to work with strings in label-transformed +~ code. If we don't provide an alternate for it, we get codeword pointers in +~ the host address space, which therefore don't work. +: label-string-alternate + ~ Something subtle here: s" is state-dependent. That is, it does different + ~ things depending on the interpreter flags. We would really rather know + ~ which version we're getting, and also it would be best if it didn't + ~ scribble on the output buffer. Fortunately we can achieve both of these, + ~ by coercing things into a known state while calling it. + ~ + ~ We could choose either version of s", but the interpreted one is more + ~ convenient because it doesn't mess with a spurious litstring invocation, + ~ just scribbled into scratch space after "here". Of course, that raises the + ~ additional concern that we have the wrong "here", but we can just swap + ~ that around, too. + ~ + ~ This is all worth it to avoid reimplementing s". If we had two + ~ implementations, they'd have to be kept in sync, and it's an important + ~ user-facing word with semantics that are likely to improve over time. + interpreter-flags @ + ' s" entry-to-execution-token + swap-transform-variables + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of the alternate. + [ ' [ entry-to-execution-token , ] + execute + swap-transform-variables + swap interpreter-flags ! + + ~ Whew. What a mouthful. + ~ + ~ Having done this, we have the string pointer on the stack at transform + ~ time, which with the label transform is the same as immediate time. If + ~ we're in immediate mode, therefore, we've left the string on the stack and + ~ that's all we wanted. If we're in compile mode, it's our job to output a + ~ litstring invocation. + + interpreter-flags @ 0x01 & { + swap-transform-variables + L@' litstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ swap packstring 8 packalign here ! + } if + ; make-immediate + + +: label-dot-string-alternate + ' label-string-alternate entry-to-execution-token execute + + interpreter-flags @ 0x01 & { + swap-transform-variables + L@' emitstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 emitstring #-- (codeword pointer) + } { emitstring } if-else + ; make-immediate + + +~ Because docol requires it, we provide a special mini-version of the label +~ system. We only do L@' and L!', because that's all we need. These are real +~ labels; there can be arbitrarily many of them, and they can have forward +~ references. +~ +~ The value that's accepted is in the host address space; the label is set +~ to an offset; and the value that's returned is in the target address space. +~ +~ (-- value) +: label-L@'-alternate + word value@ + + swap-transform-variables + intern-label + use-label + swap-transform-variables + + dropstring-with-result + + offset-to-target-address-space + ; make-immediate + + +~ (value --) +: label-L!'-alternate + host-address-space-to-offset + + word value@ + + swap-transform-variables + intern-label + swap-transform-variables + + dropstring-with-result + + swap-transform-variables + set-label + swap-transform-variables + ; 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 * + 3roll + ~ (start pointer, length, adjusted start pointer, 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 , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 != #-- (codeword pointer) + ~ 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 , ~ : -8 0branch #-- (codeword pointer) + dup 8 + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ~ (old here, length) + drop 5 8 * + here ! + ; make-immediate + +~ (start pointer, length) +: label-unless-alternate + 2dup swap dup 5 8 * + 3roll + ~ (start pointer, length, adjusted start pointer, 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 , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 = #-- (codeword pointer) + ~ 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 , ~ : -8 0branch #-- (codeword pointer) + dup 8 + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ~ (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 * + 3roll memmove + 3 pick dup 5 8 * + 4 pick 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 , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 != #-- (codeword pointer) + ~ Branch past the length field, the true-block, and the unconditional + ~ branch in the middle. + offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer) + 3roll dup 4 unroll 3 8 * + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + + ~ 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 , ~ : -8 branch #-- (codeword pointer) + ~ Branch past the length field and the false-block. + dup 8 + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + + ~ 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 , ~ : -8 branch #-- (codeword pointer) + 8 + -1 * ~ : provide-hex + ~ : 8 # #-- (branch offset) + , 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 * + 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 , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 != #-- (codeword pointer) + ~ Branch past the length field, the body, and the unconditional branch. + offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer) + dup 3 8 * + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ~ 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 , ~ : -8 branch #-- (codeword pointer) + 6 8 * + swap drop + swap drop -1 * ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ; make-immediate + + +~ This implements the label transform for a single word. It is directly +~ analogous to "interpret", and reading language/dynamic/dynamic.e may help in +~ understanding it, though it's meant to still make sense on its own. +~ +~ It expects to be called from "label-transform", below, which loops. +~ +~ (-- done) +: label-transform-one + word + + ~ If no word was returned, end the transformation. + dup 0 = { drop 1 exit } if + + ~ The string is on the top of the stack, so to get a pointer to it we get + ~ the stack address. + ~ (string) + value@ + + ~ Check whether it's one of the words we have alternates for, and look up + ~ the alternate if so. + dup 0 swap + ~ (name as stack string, name pointer, placeholder, name pointer) + dup s" create" stringcmp 0 = { swap drop ' label-create-alternate swap } if + dup s" :" stringcmp 0 = { swap drop ' label-colon-alternate swap } if + dup s" self-codeword" stringcmp 0 = { + swap drop ' label-self-codeword-alternate swap } if + dup s" ;" stringcmp 0 = { swap drop ' label-semicolon-alternate swap } if + dup s" ;asm" stringcmp 0 = { + swap drop ' label-semicolon-assembly-alternate swap } if + ~ It is nontrivial to construct a string with a double-quote in it. + dup ' s" entry-to-name stringcmp 0 = { + swap drop ' label-string-alternate swap } if + dup ' ." entry-to-name stringcmp 0 = { + swap drop ' label-dot-string-alternate swap } if + dup s" L@'" stringcmp 0 = { swap drop ' label-L@'-alternate swap } if + 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) + + ~ If an alternate was found, the alternate will be used in immediate mode. + ~ If not, we look up the word in the regular, non-transformed dictionary + ~ and use that for immediate mode. + over { dup + transformation-state transformation-state-saved-latest @ swap find-in + 3roll drop swap } unless + ~ (name as stack string, immediate entry pointer, name pointer) + + ~ In regular "interpret", we would check whether we found the word before + ~ checking the mode. However, we have three different places words could + ~ come from, so that's not a simple notion. So, we check the mode first. + interpreter-flags @ 0x01 & { + ~ If we're in compile mode, there's still a chance it's an immediate + ~ word. First check whether we have an immediate entry, then if so, check + ~ that entry's flags. Notice that this means the generated code can't + ~ override an immediate word with a non-immediate word of the same name. + over dup { entry-flags@ 0x01 & not } { not } if-else + + { + ~ Either there was no immediate entry, or the immediate entry wasn't + ~ flagged as an immediate word. So we check whether this could be a + ~ compilation. + ~ + ~ To do this, we need to look the word up in the output buffer. We + ~ can't easily traverse the next-entry pointers in the output buffer's + ~ dictionary, so we check the label. Since we don't know the word's name + ~ statically, this is a rare scenario where we can't use the abbreviated + ~ label syntax, but that's easy enough. + ~ + ~ Even though we've ruled out the possibility that the word is only + ~ ever used immediately, it is still possible that there's some reason + ~ the word doesn't exist. In particular, it could be an integer literal. + ~ If we were to call use-label first, that would count as a requirement + ~ that the label must eventually be set. We don't want to require that + ~ quite yet, so we call find-label. + ~ + ~ This check is the means by which forward references are disallowed: + ~ On the very first pass, a forward-referenced label won't exist yet, so + ~ transform will give a "no such word" error, which in an ideal world + ~ would prevent there from being a subsequent pass, but at the very + ~ least it will ensure the output isn't a valid ELF. + dup + swap-transform-variables + find-label + swap-transform-variables + { + ~ It exists, so we declare our use of it (that's also the only way to + ~ get a value for it). + ~ : provide-string-copy + swap-transform-variables + intern-label use-label + swap-transform-variables + + ~ Labels point to codewords (because that's what + ~ label-create-alternate does), which is already what we want to + ~ output. + ~ + ~ An important caveat: Though it would require something weird to be + ~ happening, such as a forced forward reference, the label may be + ~ zero! We need to allow for that possibility by not examining the + ~ contents of a nonexistent entry. + ~ + ~ Fortunately we don't have to look at it, just append it to the log + ~ and clean up. + ~ : 8 # #-- (codeword pointer) + offset-to-target-address-space , drop dropstring 0 exit + } if + + ~ If we got here, we're in compile mode, no label was found, and even + ~ if there was a candidate for an immediate word it wasn't flagged as + ~ immediate. There are two possibilities: It's genuinely missing, or it's + ~ an integer literal. We decline to run the candidate immediate entry, + ~ even if it exists, because that's not the correct semantics. + ~ + ~ If the word is genuinely missing, we want to make sure we make it + ~ all the way to the not-found error-handling code at the end, because + ~ that will be way easier to debug than doing the wrong thing will. Way, + ~ way easier. Far less staring at numbers. + ~ + ~ Anyway, we no longer need the immediate entry pointer, so we drop + ~ it. + drop drop + } { + ~ If we get here, we're in compile mode, but there was a candidate + ~ entry for an immediate word, and it was indeed flagged as immediate. + ~ So, we run it and exit. + drop dropstring-with-result entry-to-execution-token execute + 0 exit + } if-else + + ~ This is the end of the compile-mode branch. As you can see by tracing + ~ through all the above cases, if we got here, the two possibilities are + ~ that the word is genuinely missing, or it's an integer literal. + ~ + ~ Please notice that these are the same two possibilities remaining at + ~ the end of the immediate-mode branch, below. + } { + ~ If we got here, we're in interpret mode. There are three + ~ possibilities: there's an immediate word which we should run; it's an + ~ integer literal; or the word is genuinely missing. + ~ + ~ If the immediate entry pointer is non-zero, run it and exit. + over { + drop dropstring-with-result entry-to-execution-token execute + 0 exit + } if + + ~ There was no immediate word, so either it's an integer literal or + ~ the word is genuinely missing. Please notice that these are the same two + ~ possibilities remaining at the end of the compile-mode branch, above. + ~ + ~ We no longer need the immediate-mode pointer, so drop it. + drop drop + } if-else + ~ (name as stack string) + + ~ If we got here, one of two things is true: the word is an integer + ~ literal, or it's genuinely missing. We know this because both the mode + ~ cases above end with these as the only two remaining possibilities. So + ~ + ~ Check whether it's an integer literal. As before, we get the stack + ~ address and use it as a string pointer. + value@ read-integer 0 = { + ~ It's a number. + interpreter-flags @ 0x01 & { + ~ We're in compile mode; append first "lit", then the number, to the + ~ log. The version of "lit" we use is found by label, so it'll be the + ~ one that exists when this code is ultimately run. + dropstring-with-result + + ~ We look up "lit" as a label. + swap-transform-variables L@' lit swap-transform-variables + offset-to-target-address-space + ~ : 8 lit #-- (codeword pointer) + , + ~ : provide-hex + ~ : 8 # #-- (integer literal) + , + 0 exit + } if + + ~ We're in interpret mode; push the number to the stack. Or at least, that's + ~ what the code we're interpreting will see. Really it's already on the + ~ stack, just clean everything else up and leave it there. + dropstring-with-result + 0 exit + } if + + ~ If it's neither in the dictionary nor a number, just print an error. + ~ + ~ It's really important, when maintaining this code, to make sure that all + ~ the possible ways the word can fail to exist, end up here. Doing anything + ~ else is going to result in many hours of trying to untangle the + ~ consequences of incorrect behavior, after-the-fact. + s" No such word: " emitstring value@ emitstring newline dropstring 0 ; + + +~ This implements the label transform for all words in a region given as an +~ input string. It is directly analogous to "quit", in interpet.e, but is far +~ more complex. +~ +~ (output buffer start, output point, input string pointer +~ -- output buffer start, output point) +: label-transform + ~ : blank-line + ~ : blank-line + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~ : blank-line + ~ : This is the start of a long block of code which has been processed by + ~ : the label transform, meaning it consists of ready-to-run Forth word + ~ : definitions that reference each other by address, suitable for direct + ~ : execution as soon as the cold-start routine has set up the basic + ~ : registers, flags, and memory areas that form Evocation's internal ABI. + ~ : + ~ : Each word definition consists of a dictionary entry header, a + ~ : codeword, and a word body. For words implemented as Forth code, the + ~ : codeword points to the "docol" routine, and the word body is an array of + ~ : pointers to the codewords of other words, occasionally interspersed with + ~ : literal values. For words implemented as machine code, the codeword + ~ : points to the start of the body, and the body is the machine code. + ~ : + ~ : All the word entry headers in this code link to each other, from last + ~ : backwards to first, forming an Evocation dictionary. + ~ : + ~ : The warm-start routine relies on words defined by the label transform, + ~ : as does the log-load routine. + ~ : blank-line + + main-input-buffer dup push-input-buffer + swap attach-string-to-input-buffer + + ~ Save the old values of "here" and "latest", and set the initial values + ~ of the internal ones. These values need to persist across iterations, + ~ 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. + here @ transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest ! + swap transformation-state transformation-state-output-buffer-start ! + here ! + 0 latest ! + ~ Now the stack has nothing of ours on it, so client code can do its thing. + + ~ It's important that the stack has nothing of ours on it that persists + ~ across iterations, so that client code can add and remove stuff there as + ~ it sees fit. + { label-transform-one + ~ (..., done) + + ~ When the loop is done, get the real values of "here" and "latest" + ~ back. The internal "here" is also the output point, and will become our + ~ return value. The internal "latest" is discarded. + { transformation-state transformation-state-output-buffer-start @ + here @ + transformation-state transformation-state-saved-here @ here ! + transformation-state transformation-state-saved-latest @ latest ! + ~ (output buffer start, output point) + + ~ Though we don't actually use transformation-state outside of this + ~ invocation, for tidiness we zero it out. + 0 transformation-state transformation-state-saved-here ! + 0 transformation-state transformation-state-saved-latest ! + 0 transformation-state transformation-state-output-buffer-start ! + + ~ Also put the input source back how it was. + main-input-buffer pop-input-buffer + + exit } if } forever ; + + +~ Log-load transform implementation +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The following code is all part of implementing the log-load transform. +~ 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 , ~ : -8 swap #-- (codeword pointer) + + exit + } if + + swap-transform-variables + L@' roll + L@' lit + swap-transform-variables + + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + swap ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 roll #-- (codeword pointer) + ; + + +~ 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 , ~ : -8 swap #-- (codeword pointer) + + exit + } if + + swap-transform-variables + L@' unroll + L@' lit + swap-transform-variables + + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + swap ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 unroll #-- (codeword pointer) + ; + + +~ 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 + transformation-state transformation-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 + transformation-state transformation-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 + transformation-state transformation-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 + transformation-state transformation-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 , ~ : -8 litstring #-- (codeword pointer) + 3roll here @ swap packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + 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 , ~ : -8 litstring #-- (codeword pointer) + 3roll here @ swap packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + + ~ 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 , ~ : -8 execute #-- (codeword pointer) + + ~ 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 , ~ : -8 litstring #-- (codeword pointer) + here @ s" docol" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 execute #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + 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@' lit + L@' log-load-comma + 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 , ~ : -8 litstring #-- (codeword pointer) + here @ s" lit" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + swap ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + 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, +~ when they're later executed, will do create's job. +~ +~ In practice that means outputting a codeword pointer to run a +~ statically-compiled word that does the work. The implementation of +~ log-load-create is in language/static/log-load.e. +~ +~ It's worth keeping in mind that this alternate only gets called for +~ manual invocations of "create". It isn't called from the colon alternate. +: log-load-create-alternate + ~ In immediate mode, we have special behavior because this is fundamental + ~ to bootstrapping the log. In compile mode, we compile a dynamic call, + ~ which is the same thing that would happen if we didn't have an alternate + ~ at all. + interpreter-flags @ 0x01 & { + ~ Notice that when we're in compile mode, we aren't actually defining a + ~ word at the time the log-load routine runs, so we don't have magic + ~ comments. + s" create" log-load-compile-dynamic-word + } { + ~ : blank-line + ~ : create + log-load-roll-log-address + + swap-transform-variables + L@' log-load-create + L@' swap + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-create #-- (codeword pointer) + + ~ We've consumed a string pointer from the stack, so that's a delta of -1. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + } if-else ; + + +~ This is the alternate version of ":" for use with the log-load transform. +~ Its code is the same as the regular ":" except as noted below. It is likely +~ to be extremely useful to read and understand ":" in +~ language/dynamic/dynamic.e before attempting to understand +~ "log-load-colon-alternate". +: log-load-colon-alternate + word value@ + ~ : blank-line + ~ : blank-line + ~ : provide-string-copy + ~ : # is defined here via the log-load transform. + ~ : indent + + ~ Calling log-load-create-alternate would result in some redundant rolling + ~ and unrolling, so we do it together like this instead. + log-load-roll-log-address + + swap-transform-variables + L@' log-load-create + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + swap here @ swap packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-create #-- (codeword pointer) + + log-load-unroll-log-address + + dropstring + + ~ We generate code that looks up "docol" by name, runs it to get the + ~ codeword pointer, then finally appends it to the entry. + 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 + ~ routine has finished. + + ~ Switching between immediate and compile mode is one of the very few + ~ things that happens NOW, while the log-load transform is actually running. + ] + ; + + +~ See notes on label-self-codeword-alternate for what problem this is +~ solving. +~ +~ Since self-codeword's real definition is in language/dynamic/dynamic.e, +~ which absolutely cannot be loaded yet at the time we output docol at the +~ very beginning of language/static/core.e, we need to provide an alternate +~ for the log-load transform as well, even though only the label transform has +~ the reproducibility issue. +: log-load-self-codeword-alternate + ~ It's important to remember, this is not an immediate word! It needs to + ~ produce correct compiled output, when invoked in compile mode. Since it's + ~ also a regular word that exists, correct output is a reference to the + ~ non-alternate version. + interpreter-flags @ 0x01 & { + s" self-codeword" log-load-compile-dynamic-word + } { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-self-codeword + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-self-codeword #-- (codeword pointer) + + log-load-unroll-log-address + } if-else + ; make-immediate + + +~ This is the alternate version of ";" for use with the log-load transform. +~ Its code is the same as the regular ";" except as noted below. It is +~ likely to be extremely useful to read and understand ";" in +~ language/dynamic/dynamic.e before attempting to understand +~ "log-load-semicolon-alternate". +: 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 + 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 , ~ : -8 litstring #-- (codeword pointer) + here @ s" exit" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + log-load-unroll-log-address + + ~ : deindent + + ~ 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 + ~ it as part of ;. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ This is the alternate version of ";asm" for use with the log-load +~ transform. Its code is the same as the regular "create" except as noted +~ below. It is likely to be extremely useful to read and understand ";asm" in +~ language/dynamic/dynamic.e before attempting to understand "log-load;asm". +: log-load-semicolon-assembly-alternate + ~ We generate code that statically invokes log-load-semicolon-assembly, + ~ which does all the actual work. There's quite a few steps, so it makes + ~ sense to have a word that bundles them up. + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-semicolon-assembly + swap-transform-variables + + ~ The stack delta of this call is 0. + offset-to-target-address-space , + ~ : -8 log-load-semicolon-assembly #-- (codeword pointer) + + log-load-unroll-log-address + + ~ : deindent + + ~ 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 + ~ it as part of ;. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ This just does the same thing [ always does, but having it as an alternate +~ means it happens at transformation time, which is sooner than "immediate" +~ time. The log load transform is weird like that, it has three different +~ times things can happen, rather than the usual two. +: log-load-left-square-brace-alternate + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of the alternate. + [ ' [ entry-to-execution-token , ] + ; make-immediate + +~ We need this one, too. It's not even an immediate word normally! +: log-load-right-square-brace-alternate ] ; make-immediate + + +: log-load-comma-alternate + ~ In immediate mode, we have special behavior because of the "here" magic. + ~ In compile mode, we compile a dynamic call, which is the same thing that + ~ would happen if we didn't have an alternate at all. + interpreter-flags @ 0x01 & { + s" ," log-load-compile-dynamic-word + } { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-comma + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + ~ We consumed the value, so we apply a delta. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } if-else + ; make-immediate + + +: log-load-variable-alternate + ~ In immediate mode, we have special behavior because of the "here" magic. + ~ In compile mode, we compile a dynamic call, which is the same thing that + ~ would happen if we didn't have an alternate at all. + interpreter-flags @ 0x01 & { + s" variable" log-load-compile-dynamic-word + } { + ~ Calling log-load-create-alternate would result in some redundant rolling + ~ and unrolling, so we do it together like this instead. + log-load-roll-log-address + + swap-transform-variables + L@' log-load-variable + L@' 3unroll + swap-transform-variables + + offset-to-target-address-space , ~ : -8 3unroll #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-variable #-- (codeword pointer) + + ~ We consumed the string and address, so we apply a delta. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + } if-else + ; make-immediate + + +: log-load-keyword-alternate + ~ In immediate mode, we have special behavior because of the "here" magic. + ~ In compile mode, we compile a dynamic call, which is the same thing that + ~ would happen if we didn't have an alternate at all. + interpreter-flags @ 0x01 & { + s" keyword" log-load-compile-dynamic-word + } { + ~ Calling log-load-create-alternate would result in some redundant rolling + ~ and unrolling, so we do it together like this instead. + log-load-roll-log-address + + swap-transform-variables + L@' log-load-keyword + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-keyword #-- (codeword pointer) + + ~ We consumed the string, so we apply a delta. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } if-else + ; make-immediate + + +~ Yeah comments have to go. +: log-load-tilde-alternate + ' ~ entry-to-execution-token execute + ; make-immediate + + +~ Strings are important and must happen now, now, now. +: log-load-string-alternate + ~ Wrapping s" is surprisingly difficult; see label-string-alternate + ~ for detailed notes on how that works. Once we've finished the + ~ transform-time part, our implementations will diverge, but this first bit + ~ is the same. + interpreter-flags @ + ' s" entry-to-execution-token + swap-transform-variables + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of the alternate. + [ ' [ entry-to-execution-token , ] + execute + swap-transform-variables + swap interpreter-flags ! + + ~ Nope, doing it twice didn't make that any less of a mouthful. + ~ + ~ Having done this, we have the string pointer on the stack at transform + ~ time (not, mind you, at log-load time, as yet). Now it is our job to + ~ either compile it, or invoke it "immediately". Recall that the log-load + ~ transform's "immediate" time, which we also call log-load time, is + ~ analogous to the label transform's "compile" time. The log-load + ~ transform's "compile" time is an additional layer of indirection. + ~ + ~ No matter which mode we're in, the first thing we want to do is get the + ~ string onto the value stack at log-load time. So we compile code to do + ~ that, first. We do that using the static "litstring", which we find by + ~ label. + ~ + ~ If this is all too twisty, it might be helpful to go re-read the + ~ definition of log-load-compile-literal, which does a simpler version of + ~ this same task (because integers are easier than strings). + + swap-transform-variables + L@' litstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ swap packstring 8 packalign here ! + + ~ Now the string pointer is on the stack at log-load time, so we apply a + ~ delta for it. + 1 transform-apply-stack-delta + + ~ If we're in immediate mode, we're done! Yay! Putting the string on the + ~ stack at log-load time is what we wanted. If not... + interpreter-flags @ 0x01 & { + ~ We're in compile mode, so we need to look up the ultimate, dynamic, + ~ log-based, super-atomic space rocket copy of "litstring" and use that. + ~ We could call log-load-compile-dynamic-word here, but, as usual, it + ~ would produce some excessive rolling and unrolling, so we do its job + ~ ourselves instead. + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma-string + L@' swap + L@' log-load-comma + 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 , + ~ : -8 litstring #-- (codeword pointer) + here @ s" litstring" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma-string #-- (codeword pointer) + + ~ We consumed the string pointer at log-load time, so we apply a delta + ~ for it. + ~ + ~ Notice by the way how the nearby calls to log-load-unroll-log-address + ~ rely on this being split into two deltas like this, even though they + ~ net out to zero; we aren't doing it just for kicks. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } if + ; make-immediate + + +: log-load-dot-string-alternate + ' log-load-string-alternate entry-to-execution-token execute + + interpreter-flags @ 0x01 & { + ~ Hey look, it's the one time we're doing something simple enough that + ~ we can actually benefit from log-load-compile-dynamic-word as something + ~ more than an example to start from. :) + s" emitstring" log-load-compile-dynamic-word + } { + swap-transform-variables + L@' emitstring + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 emitstring #-- (codeword pointer) + } if-else + ; make-immediate + + +~ No matter what mode we're in, we read a name at transform time. Then we +~ look up the name at either log-load time or runtime, depending. +: log-load-tick-alternate + ~ Read the name. + word value@ + + ~ Get the name onto the stack at log-load time. + swap-transform-variables + L@' litstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ swap packstring 8 packalign here ! + + ~ Apply a delta for the string pointer. + 1 transform-apply-stack-delta + + dropstring + + ~ Now break out the remaining behavior based on mode. + interpreter-flags @ 0x01 & { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + L@' log-load-comma-string + L@' swap + L@' log-load-comma + 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 , + ~ : -8 litstring #-- (codeword pointer) + here @ s" litstring" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma-string #-- (codeword pointer) + + offset-to-target-address-space , + ~ : -8 litstring #-- (codeword pointer) + here @ s" find" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + ~ We consumed the string pointer at log-load time, so we apply a delta + ~ for it. As in log-load-string-alternate, this needs to be split into + ~ two parts like this. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-find + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-find #-- (codeword pointer) + + ~ We leave an execution token on the log-load-time stack, so no delta + ~ needed. + + log-load-unroll-log-address + } if-else + ; make-immediate + + +~ Because docol requires it, we provide a special mini-version of the label +~ system. We only do L@' and L!', because that's all we need. Unlike the +~ version of this feature for the label transform, for the log-load transform, +~ we heavily restrict the use-case. +~ +~ The implementation strategy is that we ignore the label name, and store +~ 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, 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 values, ..., ..., value of label +~ -- value of label, preserved values, ..., ...) +~ L@' is (value of label, preserved values, ..., ...) +~ -- preserved values, ..., ..., value of label) +~ +~ 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 transformation-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 +~ wouldn't actually be necessary to use this at all, since checking "here" +~ would be sufficient, but then the code would have to do something different +~ depending on which transform it's running under, and there'd have to be a +~ mechanism for that. +~ +~ This is sufficient to implement docol, and that's probably the only thing +~ it should be used for. +: log-load-L@'-alternate + word dropstring + 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 + ~ 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 + + +~ Not to be outdone by the label transform, the log-load transform also +~ offers alternates of all the high-level flow-control words: if, unless, +~ if-else, forever, and while. Unlike the label transform, we also need to +~ implement alternates of { and }, because their values need to be on the +~ stack at log-load "immediate" time, not at transform time. +~ +~ Anyway, most of the implementation is deferred to pre-packaged words in +~ language/static/log-load.e. +: log-load-left-curly-brace-alternate + log-load-roll-log-address + + swap-transform-variables + L@' log-load-left-curly-brace + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-left-curly-brace #-- (codeword pointer) + + ~ It pushes a start pointer onto the stack. + 1 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : { + ~ : indent + ; make-immediate + + +: log-load-right-curly-brace-alternate + ~ : deindent + ~ : } + log-load-roll-log-address + + swap-transform-variables + L@' log-load-right-curly-brace + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-right-curly-brace #-- (codeword pointer) + + ~ It pushes a length value onto the stack. + 1 transform-apply-stack-delta + + log-load-unroll-log-address + ; make-immediate + + +~ (start pointer, length --) +: log-load-if-alternate + ~ : if + log-load-roll-log-address + + swap-transform-variables + L@' log-load-if + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-if #-- (codeword pointer) + + ~ It pops the start and length. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (start pointer, length) +: log-load-unless-alternate + ~ : unless + log-load-roll-log-address + + swap-transform-variables + L@' log-load-unless + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-unless #-- (codeword pointer) + + ~ It pops the start and length. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (true start, true length, false start, false length) +: log-load-if-else-alternate + ~ : if-else + log-load-roll-log-address + + swap-transform-variables + L@' log-load-if-else + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-if-else #-- (codeword pointer) + + ~ It pops two pairs of start and length. + -4 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (start, length --) +: log-load-forever-alternate + ~ : forever + log-load-roll-log-address + + swap-transform-variables + L@' log-load-forever + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-forever #-- (codeword pointer) + + ~ It pops the start and length. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (test start, test length, body start, body length --) +: log-load-while-alternate + ~ : while + log-load-roll-log-address + + swap-transform-variables + L@' log-load-while + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-while #-- (codeword pointer) + + ~ It pops two pairs of start and length. + -4 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ This implements the log-load transform for a single word. It is directly +~ analogous to "interpret", and reading language/dynamic/interpret.e may help +~ in understanding it, though it's meant to still make sense on its own. +~ +~ It expects to be called from "log-load-transform", below, which loops. +~ +~ (-- done) +: log-load-transform-one + word + + ~ If no word was returned, end the transformation. + dup 0 = { drop 1 exit } if + + ~ The string is on the top of the stack, so to get a pointer to it we get + ~ the stack address. + ~ (string) + value@ + + ~ Check whether it's one of the words we have alternates for, and look up + ~ the alternate if so. + 0 swap + ~ (name as stack string, placeholder, name pointer) + dup s" create" stringcmp 0 = { + swap drop ' log-load-create-alternate swap } if + dup s" :" stringcmp 0 = { + swap drop ' log-load-colon-alternate swap } if + dup s" self-codeword" stringcmp 0 = { + swap drop ' log-load-self-codeword-alternate swap } if + dup s" ;" stringcmp 0 = { + swap drop ' log-load-semicolon-alternate swap } if + dup s" ;asm" stringcmp 0 = { + swap drop ' log-load-semicolon-assembly-alternate swap } if + dup s" [" stringcmp 0 = { + swap drop ' log-load-left-square-brace-alternate swap } if + dup s" ]" stringcmp 0 = { + swap drop ' log-load-right-square-brace-alternate swap } if + dup s" ," stringcmp 0 = { swap drop ' log-load-comma-alternate swap } if + dup s" variable" stringcmp 0 = { + swap drop ' log-load-variable-alternate swap } if + dup s" keyword" stringcmp 0 = { + swap drop ' log-load-keyword-alternate swap } if + dup s" ~" stringcmp 0 = { + swap drop ' log-load-tilde-alternate swap } if + ~ It is nontrivial to construct a string with a double-quote in it. + dup ' s" entry-to-name stringcmp 0 = { + swap drop ' log-load-string-alternate swap } if + dup ' ." entry-to-name stringcmp 0 = { + swap drop ' log-load-dot-string-alternate swap } if + dup ' ' entry-to-name stringcmp 0 = { + swap drop ' log-load-tick-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 + dup s" {" stringcmp 0 = { + swap drop ' log-load-left-curly-brace-alternate swap } if + dup s" }" stringcmp 0 = { + swap drop ' log-load-right-curly-brace-alternate swap } if + dup s" if" stringcmp 0 = { swap drop ' log-load-if-alternate swap } if + dup s" unless" stringcmp 0 = { + swap drop ' log-load-unless-alternate swap } if + dup s" if-else" stringcmp 0 = { + swap drop ' log-load-if-else-alternate swap } if + dup s" forever" stringcmp 0 = { + swap drop ' log-load-forever-alternate swap } if + dup s" while" stringcmp 0 = { swap drop ' log-load-while-alternate swap } if + ~ (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 + ~ checking, because it doesn't fully describe their behavior anyway. With + ~ 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. + over { + drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } if + drop drop + ~ (name as stack string) + + ~ Now we might have a compiled word, an immediate word, or an integer + ~ literal. Recall that the word won't actually be looked up until the + ~ routine we're producing is run - that's the whole point - so there's no + ~ check we can perform now that will tell us whether the word we have exists + ~ in the eventual log. Instead, we invert the usual fallback order and + ~ check whether the word could be an integer literal. If it is, we'll + ~ handle that; if not, we'll assume it'll eventually exist. + ~ + ~ This means that code that's run with the log-load transform can't + ~ 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. + 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. + ~ + ~ 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 , ~ : -8 lit #-- (codeword pointer) + ~ : provide-hex + , ~ : -8 # #-- (integer literal) + 1 transform-apply-stack-delta + 0 exit + } if + ~ (name as stack string) + + ~ We know it's a regular word, and we're assuming it will exist at + ~ runtime. We of course have no way to check what flags it will have, which + ~ 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. + ~ + ~ 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. + ~ + ~ Just like in label-transform, we use find-label to check whether a label + ~ exists without declaring a dependency on it, then if it does, we do + ~ use-label to ask for its value. + ~ + ~ There's one additional wrinkle to remember here: We're running inside + ~ the label loop, and warm-start appears before all the normal words in the + ~ executable. So all the labels we'll be checking are forwared references, + ~ and on the very first pass they definitely won't be defined. That's fine + ~ though, they will exist on all subsequent passes, so things will + ~ definitely still converge. + ~ + ~ 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. + 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. + ~ : provide-string-copy + 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. + ~ + ~ This is an immediate effect, so once we've done that, we update the + ~ user stack depth. + offset-to-target-address-space , + ~ : -8 # #-- (codeword pointer) + 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. + ~ + ~ 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 ; + + +~ This implements the log-load transform for all words in a region given as +~ an input string. It is directly analogous to "quit", in +~ language/dynamic/interpret.e, but is far more complex. +~ +~ (output buffer start, output point, input string pointer +~ -- output buffer start, output point) +: log-load-transform + ~ : blank-line + ~ : This is the start of the log-load routine, which is a long block of + ~ : code that has been processed by the log-load transform. It is part of + ~ : the warm-start routine, which does other things before and after it. + ~ : For clarity's sake, to avoid weird nesting, the section header above + ~ : calls this the warm-start section of the executable, but in a sense it + ~ : might be more accurate to call it the log-load section. + ~ : + ~ : The routine is interpreted Forth code, just as the warm-start routine + ~ : as a whole is; see above. + ~ : + ~ : The job of the log-load routine is to create runnable code in the + ~ : dynamic log, at runtime. The normal way to create a Forth executable + ~ : is to use label-transformed code to implement a minimal set of + ~ : functionality needed for the log-load routine to run, then invoke the + ~ : log-load routine to copy a more complete set of functionality into + ~ : memory. + ~ : + ~ : The log-load routine is super important, but also extremely verbose, + ~ : which necessarily makes it hard to read. If you're skimming this file + ~ : for the first time to get a sense of what it contains, you might want + ~ : to search for the words "label transform" to get to the stuff that makes + ~ : better introductory reading. + ~ : blank-line + + main-input-buffer dup push-input-buffer + swap attach-string-to-input-buffer + + ~ Save the old values of "here" and "latest", and set the initial values + ~ of the internal ones. These values need to persist across iterations, + ~ 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 transformation-state. + here @ transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest ! + swap transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + here ! + 0 latest ! + ~ Now the stack has nothing of ours on it, so client code can do its thing. + + ~ It's important that the stack has nothing of ours on it that persists + ~ across iterations, so that client code can add and remove stuff there as + ~ it sees fit. + { log-load-transform-one + ~ (..., done) + + ~ When the loop is done, get the real values of "here" and "latest" + ~ back. The internal "here" is also the output point, and will become our + ~ return value. The internal "latest" is discarded. + { transformation-state transformation-state-output-buffer-start @ + here @ + transformation-state transformation-state-saved-here @ here ! + transformation-state transformation-state-saved-latest @ latest ! + ~ (output buffer start, output point) + + ~ Though we don't actually use transformation-state outside of this + ~ invocation, for tidiness we zero it out. + 0 transformation-state transformation-state-saved-here ! + 0 transformation-state transformation-state-saved-latest ! + 0 transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + + ~ Also put the input source back how it was. + main-input-buffer pop-input-buffer + + exit } if } forever ; + + +~ Hex transform implementation +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The following code is all part of implementing the hex transform. For +~ conceptual overview, see the top of this file. +~ +~ The hex transform operates under some very complex memory-management +~ assumptions, even compared to the other transforms, so it's worth going over +~ all that and studying how it comes together, even though much of it is +~ material that has been explained elsewhere. This explanation is here with +~ the implementation details rather than at the top of the file, because it's +~ only necessary to understanding how to modify the transform, not how to use +~ it. +~ +~ This is the bit of the hex transform where all the memory-management +~ assumptions are in play at once, so, a quick refresher. The transform +~ itself is running in the outer context; hex-trace and its siblings are +~ part of Evocation's main log and dictionary. This is also true for the +~ label and log-load transforms. Evocation has two global variables, +~ "here" and "latest", which are the root of all references to the log and +~ dictionary, respectively. Remember, the log is the structure used for +~ memory allocation, and the dictionary, which forms the majority of the +~ log, is the structure used for looking up words by name. +~ +~ Every transform, in its various ways, is changing what it means to +~ "execute" and "compile" code; therefore, when the transforms are invoked, +~ they are passed an "output buffer" which is used as the destination for +~ any compilation that occurs, and any scratch space that is needed. When +~ more than one transform is running at once (such as when the hex transform +~ operates on code that is itself running the label transform), each +~ transform has its own separate output buffer. +~ +~ Furthermore, the transformation facility helps each transform to swap out +~ the values of "here" and "latest", and restore them later, so that the code +~ being transformed will see the output buffer as if it is the "real" log, and +~ will see the separate dictionary stored within the output buffer as if it is +~ the "real" dictionary. +~ +~ All this stuff about the output buffer applies to every transform. The +~ hex transform takes it one step further, and as such there are two +~ additional memory regions that are important to understanding it. The first +~ is the label-loop buffer, which is allocated out of the inner log, and used +~ to hold draft versions of the binary output that the inner compilation +~ process would eventually emit to the standard output stream, if it were +~ being allowed to emit output in the normal way. The second is the output +~ metadata buffer, which is allocated out of the outer log, and used to hold +~ metadata such as comments and formatting pertaining to code structure, which +~ will need to be referenced when actually outputting the final hex dump. +~ +~ So, the label-loop buffer can be thought of as scratch space for the +~ compiled binary output from the code being transformed, and the output +~ metadata buffer can be thought of as the scratch space for the formatted hex +~ dump that will be made out of that output. It's important not to confuse +~ either of them with the output buffer, which is the scratch space used as +~ part of the compilation process. +~ +~ Confusingly, the output buffer and the label-loop buffer both contain +~ logs and dictionaries, at least potentially, if the code being compiled is +~ Forth code. It is also possible to use the hex transform on assembly code, +~ in which case the label-loop buffer won't have a log in it but the output +~ buffer still will. In practice, the hex transform frequently winds up +~ needing to be careful about the log and dictionary in the output buffer, but +~ rarely does anything that directly touches the log and dictionary in the +~ label-loop buffer, so you can usually ignore the latter when reading this +~ code. +~ +~ Allocating the output buffer and output metadata buffer is the +~ responsibility of the caller of hex-transform. Allocating the label-loop +~ buffer is the responsibility of label-loop, which is called by the code +~ being transformed, but the hex transform intervenes in that allocation to +~ save information about it. +~ +~ The output buffer is referenced during the transform via the +~ transformation-state-output-buffer-start field of the global +~ "transformation-state" variable, and the output metadata buffer is +~ referenced via the transformation-state-output-metadata field of that same +~ variable. The label-loop buffer is referenced from the +~ hex-output-metadata-label-loop-buffer-start and -length fields of the +~ output metadata's top-level header, and the code being transformed passes +~ around its own reference to that same buffer. +~ +~ Finally, recall that, when Evocation itself is the thing being +~ transformed, the code under transformation includes its own copy of the +~ transformation facility, along with all the rest of Evocation. When the code +~ under transformation invokes the label and log-load transforms, it will do +~ so using the copies of those transforms which have been transformed by the +~ hex transform. The same goes for most Evocation internals invoked by the +~ compilation process, except for whatever specific exceptions the hex +~ transform creates. Do not confuse the inner copies of anything with the +~ outer copies. Also try not to worry too much about the inner-inner copies, +~ let the inner transforms deal with them. +~ +~ Got all that background fresh in your mind? Okay, time to get concrete! +~ The output metadata is a header structure followed by an array of entry +~ structures, as follows: +~ +~ (header start) +~ 0x00 - 0x07 Label-loop buffer start +~ 0x08 - 0x0f Label-loop buffer length +~ (entry start) +~ ... + 0x00 - ... + 0x07 Data pointer +~ ... + 0x08 - ... + 0x0f Referenced data length +~ ... + 0x10 - ... + 0x17 String pointer +~ (entry fields repeat at successive offsets, until...) +~ ... + 0x00 - ... + 0x07 (end) Zero, used as a delimiter +~ +~ +~ Magic comment syntax +~ ~~~~~~~~~~~~~~~~~~~~ +~ +~ How, the sufficiently determined reader may ask, does all this output +~ metadata get created? Surely, the reader may rightly think, creating +~ metadata entries which fully describe a compilation process must entail +~ gathering and synthesizing information from disparate stages of that +~ process, which seems quite involved. +~ +~ That is correct: It is quite involved. It would be nice if there were a +~ simple trick, but this appears to be essential complexity. Several +~ approaches were considered. In principle it would be possible to have a +~ specific trap defined here in this file for every word that generates +~ nontrivial output, and keep knowledge of what information to gather from +~ those words in the trap definitions. However, that would bind the important +~ semantics quite closely to the already-overwhelming topic of the +~ transformation data structures, and make it all but impossible to port +~ Evocation to a new architecture. The knowledge we wish to capture is really +~ knowledge about an instruction set architecture, not about data structures. +~ +~ Instead, following the principle that different kinds of knowledge on the +~ same topic should live close together, we've defined a magic-comment syntax +~ which allows the assembly-language words in language/static/amd64.e to +~ describe their own metadata, and is versatile enough to do the same for +~ future architectures. +~ +~ When the compiler operates normally, without the hex transform, these +~ magic comments are simply regular comments, and are discarded as the +~ interpreter finds them. When the compiler runs under the hex transform, they +~ are instead recognized as commands to be processed by the hex transform. +~ Magic comments can only appear in the body of a word being compiled, not at +~ the top level. The hex transform intervenes in the compilation process to +~ insert calls to its own internal words, which are executed, not when the +~ comment is read, but later, when the word it was compiled into is called. +~ When the word in question is itself part of the compiler, the magic comments +~ will be able to see and work with all the state that exists as it runs, and +~ gather it as they wish. +~ +~ There are several kinds of magic comment. All of them begin with the +~ characters : and space as the first two characters of the comment body (and +~ don't forget that there's a space after ~, as well). The syntax on the rest +~ of the line determines what type of command it is. +~ +~ Here are some examples: +~ +~ ~ : Intriguing commentary goes here. +~ ~ : 5 This comment describes the next five bytes of output. +~ 777 pack32 ~ : -4 This comment describes the previous four bytes. +~ +~ ~ : indent +~ ~ : deindent +~ ~ : fresh-line +~ ~ : blank-line +~ +~ ~ : 1 adjust-length +~ ~ : -10 adjust-start +~ ~ : 1 data-adjust-length +~ ~ : -1 data-adjust-start +~ +~ ~ : 0x1000 set-output-point +~ ~ : 8 adjust-output-point +~ ~ : data-set-output-point +~ ~ : 1 data-adjust-output-point +~ +~ ~ : 1 suppress +~ ~ : delete-first-comment-at-output-point +~ ~ : delete-last-comment-at-output-point +~ +~ ~ : Do a thing with # and # ? +~ ~ : provide-decimal +~ ~ : provide-hex +~ ~ : provide-hex8 +~ ~ : provide-hex16 +~ ~ : provide-hex32 +~ ~ : provide-hex64 +~ ~ : provide-string +~ ~ : provide-string-copy +~ ~ : provide-keyword +~ ~ : provide-data +~ ~ : drop-subitem +~ ~ : swap-subitems +~ ~ : 3 roll-subitems +~ +~ By the way, the reason it's possible to write these examples is that +~ they're all embedded within an outer comment, the text you're reading, so +~ they don't look like real magic comments to the hex transform. Hopefully +~ that's not too confusing; there isn't really another way. +~ +~ So. You'll have noticed that some magic comments seem to be descriptive +~ text, and others seem to be commands. Every magic comment, in one way or +~ another, creates or manipulates the metadata entries, which are stored in +~ an array inside the output metadata as global mutable state. There are +~ several phases of processing, and if you've gotten this far, you likely need +~ to understand what they are and what order they happen in. +~ +~ The simplest kind of comment is the "line comment", the first example +~ above. Any comment that doesn't match some more-specific syntax is treated +~ as a line comment. It has not escaped Irenes' notice that this means your +~ syntax errors will seem to half-work; sorry about that. When a line comment +~ is executed, it creates a metadata entry at the end of the array of entries, +~ of -entry-type-line-comment, attached to the latest output point. +~ +~ This is the general pattern: Any magic comment that creates a metadata +~ entry will always create it at the end of the entry array, and will always +~ attach it to the latest output point as of the time the comment executes. +~ Notice that, although the entry array will eventually be sorted by the +~ addresses entries are attached to, at the time entries are created they're +~ simply appended. This is rarely an important distinction, but when it is, it +~ is. +~ +~ What is the latest output point? Well, the hex transform has trapped all +~ the words from core that compilation processes use to directly append bytes +~ to the label-loop buffer, including pack8, packstring, and the variants +~ thereof. The traps are able to tell when the destination is in the +~ label-loop buffer, and they ignore any writes that aren't. The traps keep +~ track of the next address AFTER whatever was just written, and store that +~ in the output metadata header so magic comments can make use of it. +~ +~ It's necessary to take this sneaky approach, because the compiler is free +~ to write things in any order it wants; the label loop goes back to the start +~ every so often, and the high-level flow-control words even slide things +~ around after the fact. The compiler is also free to pass around addresses +~ however it wants within itself, and without restricting that, there's no way +~ for the hex transform to know which value represents the place stuff MIGHT +~ be written to. +~ +~ The semantics of the latest output point are simple enough that they're +~ easy to keep in mind while writing magic comments. In practice, the output +~ point is almost never the cause of confusion about the behavior of magic +~ comments, but it's important to know about since it's the input the whole +~ thing starts with. +~ +~ Now, one thing to keep in mind is that every metadata entry has both an +~ address in the label-loop buffer that it attaches to, and a length field. +~ Line comments insert themselves in between lines of output in the hex dump, +~ and don't otherwise affect the surrounding formatting, so they don't need to +~ make use of the length and it's always set to zero. +~ +~ Now the second example above, which starts with the number 5 before its +~ descriptive text. When the first space-separated word of a magic comment's +~ body is a valid integer literal, this is taken as a parameter; different +~ types of magic comment use that parameter in different ways. The parameter +~ can be positive or negative, and can be written in any base Evocation +~ normally supports. +~ +~ When a parameter is given (even if it's zero), and the comment doesn't +~ match some other more-specific syntax, it's treated as a "suffix comment". +~ Much like a line comment, when a suffix comment is executed, it creates a +~ metadata entry at the end, of -entry-type-suffix-comment, attached to the +~ latest output point. The command uses the parameter as the initial value of +~ the entry's length field, but it's worth being aware that other commands may +~ change it later. +~ +~ It's called a suffix comment because, when all the passes described below +~ have run and the formatting happens, it will appear at the end of a line of +~ text, after the byte values it's attached to. Things like assembly-language +~ instructions should almost always be suffix comments, because this makes it +~ easy for a human reader to see which bytes of machine code go with them. +~ +~ There's also an implicit way to create a suffix comment, which is to have +~ non-blank words of any kind on the line prior to the magic comment. In this +~ case, the default is to be a suffix comment rather than a line comment. +~ Suffix comments created this way will have zero length. +~ +~ Before we move on from magic comments that produce descriptive text, also +~ look at the third example above. This is another suffix comment, but it's +~ got a negative number as its parameter. It's got a bit of code on the line +~ before it, to illustrate the typical way these negative parameters are used. +~ Just as a suffix comment with a positive length describes a span of bytes +~ with its start anchored at the address the comment is attached to, so when +~ the length is negative, the span of bytes has its END anchored at the +~ address. +~ +~ You can see examples of how this syntax is useful in compilation/elf.e, +~ where it describes fields of various header structures. When it fits the +~ situation, this notation is concise and easy to visually skim both in the +~ actual source code, and in the generated hex dump. +~ +~ Now let's look at some magic comments that do more interesting things. +~ The two commands "indent" and "deindent" both create an entry of +~ -entry-type-indent. Neither takes a parameter as part of the comment syntax, +~ but the entry structure has an internal value which is set to 2 for "indent" +~ and -2 for "deindent". When output is eventually formatted, these entries +~ will be used to adjust the amount of space at the beginning of each line, +~ which can be very useful to visually group code together. The formatting +~ process has some mutable state of its own, which doesn't exist until this +~ very late stage (long after magic comments execute); among other things, +~ there's a notion of current indentation level, which is preserved until +~ these entries adjust it. +~ +~ The commands "fresh-line" and "blank-line" create entries of +~ -entry-type-fresh-line and -entry-type-blank-line, respectively. Just as the +~ output formatting knows how deeply indented it is, it also knows whether +~ it's at the start of a line. A fresh-line entry will insert a line break, +~ but only if we're somewhere deep in a line; if we're already at the start, +~ it does nothing. A blank-line entry will do the same thing as fresh-line, +~ then it will add another line break, so that the result is to output a fully +~ blank line in the hex dump. This can be useful to break things up visually. +~ +~ Thus far, though we've taken pains to allude to the fact that there are +~ many stages of processing of metadata entries after they're created, we +~ haven't introduced any interesting features that rely on that. That changes +~ with the "adjust-line" command. When this command executes, it doesn't +~ create a new metadata entry. Rather, it scans backwards from the end of the +~ entry array, to find the most recently-created entry which is a line or +~ suffix comment. It skips over entries of other types. Then it adjusts the +~ length of that entry, in-place! The parameter of adjust-line may be positive +~ or negative, and either way it's added to the pre-existing length of the +~ entry it modifies. +~ +~ If that doesn't sound confusing, you may not have fully appreciated that +~ adjust-line commands don't have to come in the same word as the command that +~ created the entry they're modifying. For example, in +~ language/static/amd64.e, rex-w is a common helper word called as part of +~ many assembly instructions. It always outputs a single byte. Commentary in +~ that file describes an accounting convention whereby keeping track of this +~ byte is rex-w's job, so rex-w also has a magic comment with an adjust-length +~ command. Whatever word calls rex-w will have already created a suffix +~ comment giving the name of the instruction it's implementing, by the time +~ this is called, and rex-w's call to adjust-length will find that comment's +~ entry and modify it. +~ +~ The use of this may not seem like much for a word like rex-w, which always +~ outputs the same number of bytes, but now look at the definition of +~ addressing-indirect-reg64. This is a common addressing mode shared by many +~ instructions, and called as a helper from various instruction words. Notice +~ how it has to generate a different encoding when it's given the register +~ :rsp, which has an extra SIB byte that's not needed for any other register. +~ There's no magic comments in addressing-indirect-reg64 itself, but the word +~ "sib" is another helper which does an appropriate adjust-length, if and only +~ if sib is actually called. +~ +~ You can see how it might become quite confusing trying to decide which +~ word should take responsibility for a particular byte, when there are +~ multiple layers of abstraction like this. It's especially confusing because +~ this is an extra form of side-effect which acts on global mutable state, and +~ is out-of-band compared to the normal Forth value stack. When you're +~ implementing an instruction set architecture, you should strongly consider +~ defining an accounting convention which makes that clear and unambiguous. +~ Feel free to consult the convention described at the top of +~ language/static/amd64.e for inspiration. +~ +~ All the adjust-* commands change something immediately, as they execute. +~ What they adjust differs. In the cases of adjust-length and adjust-start, +~ it's a field of a recent entry. Notionally, adjust-start does the same thing +~ as adjust-length but for the start address the entry is attached to, rather +~ than the length of the attachment. Also, while adjust-length only affects +~ comment entries, adjust-start affects any entry that produces output, such +~ as fresh-line. +~ +~ The various -output-point commands are used to directly interact with the +~ notion of the latest output point, which can be useful if a location has +~ been skipped over and there are commands which should be run before +~ outputting anything at the new location. The simplest variant is +~ set-output-point, which sets it to the parameter value. The data-set- +~ variant obtains a value in the manner of the other data-* commands, adds it +~ to the parameter value, and sets the latest output point to the result. The +~ adjust- and data-adjust- variants, like other adjust commands, add a value +~ to the existing one. +~ +~ Notice that the general rule is that data-set-* commands use their +~ parameter as an addend, while data-adjust-* commands use it as a multiplier. +~ +~ The data-adjust-* variants deserve further commentary, though you may find +~ it more productive to read and understand the entire explanation about +~ provide-* commands before worrying about these. These variants adjust the +~ same things as the non-data ones, but instead of adjusting by a fixed +~ amount, they look for the most recent -entry-type-saved-data metadata entry. +~ They delete that entry from the entry array entirely, and use the value +~ saved in it as the amount to adjust by. Such entries are created by the +~ provide-data command, on which more below. Additionally, the data-adjust-* +~ commands use their parameters as scaling factors to the adjustment, and +~ these factors may be negative. You'll usually specify a parameter of 1 or +~ -1. +~ +~ We will revisit the topic of adjust-length later, when we describe the +~ comment template feature, but for now we'll leave it there. +~ +~ Direct your attention to the "suppress" command. Sometimes, you intend to +~ call a helper word which is going to create its own entries, but you know +~ that those entries don't suit your purpose, and you want to ignore them. +~ For example, you may be calling a word which outputs a binary string and +~ creates entries describing the string, but you're doing something more +~ specific and would prefer to create entries that describe your special case, +~ instead. +~ +~ When you need this, you can call "suppress" with an integer parameter. If +~ the parameter is 1, the next time a metadata entry would have been created, +~ it won't; then things go back to normal. If you want to suppress more than +~ one entry in a row, you can pass it a larger number. If you change your +~ mind, you can pass it a negative number. At the time magic comments are +~ executing, there's a running count of how many entries should be suppressed, +~ which is decremented any time it's greater than zero and an entry would be +~ created, and adjusted every time a call to "suppress" is executed. +~ +~ Sometimes, an entry has already been created, and you now need to get rid +~ of it. While there are reasons to be cautious of more-general mechanisms, +~ the commands delete-*-comment-at-output-point will search for a metadata +~ entry which is one of the comment types and which has its start position set +~ to the same address as the current output point. The -first- variant will +~ search forward from the start of the array, while -last- will search +~ backward from the end; both will stop as soon as they encounter one. This is +~ usually desired when overwriting a location that has already been written +~ to. +~ +~ Take a quick look at the remaining examples. These are part of the comment +~ template feature. We'll need to describe the other phases of processing +~ before we can talk about how they work, but notice that one of them has the +~ space-separated word # inside it, while the others are commands whose names +~ start with provide-. Any line or suffix comment can have # in it, which will +~ consume a subitem from somewhere else, replacing the # like it's a template. +~ The various provide- commands are the origins of those subitems. Which # +~ goes with which provide- command? Thereby hangs a tale. +~ +~ So. Let's pretend for the moment that we've finished talking about things +~ that happen when magic comments execute. We haven't, quite, but to finish it +~ out you'll need the full picture in your head. +~ +~ All this time, the hex transform has been executing the compiler, which +~ is running its guts inside a utility called the label loop (see +~ compilation/labels.e). The compiler guts have been calling their own various +~ internal words and accumulating their binary output in the label-loop +~ buffer. While this is happening, the hex transform's various traps have been +~ tracking the latest output point, executing magic comments, and doing other +~ vital but simpler tasks. +~ +~ Eventually the label-loop will reach the end of its iteration, and then it +~ will either conclude that all the labels in the program have been resolved +~ successfully, or it will notice that some of them were given addresses that +~ don't work. If the labels aren't all resolved, the label loop will start +~ over from the beginning, running all the same compiler guts again. The hex +~ transform will notice that this happened, clear out all the metadata +~ entries, and restart its own activities as well. +~ +~ When the label loop finally declares success, and exits, the compiler will +~ want to actually produce its binary output. The hex transform has trapped +~ this, too! Now there's a postprocessing phase which cleans up all the +~ metadata entries, and then finally there's a formatting phase where the +~ entries are "run", as if they're a program, and the final hex dump with all +~ its comments is output. +~ +~ As a side note, the hex transform doesn't stop the compiler short; it lets +~ the compiler decide which bytes will be output and in what order. In +~ practice, Evocation and the various supplemental programs around it only +~ ever write their output in a single giant chunk, but the formatting phase +~ actually runs every single time the compiler calls sys-write, and it only +~ handles the portion of the label-loop buffer which the compiler passed to +~ sys-write. +~ +~ The postprocessing phase is idempotent - doing it twice is the same as +~ doing it once - so it's simply called every time sys-write is, before the +~ formatting phase starts. Postprocessing considers every metadata entry, +~ every time it runs, even when sys-write is called on something less than +~ the whole buffer. +~ +~ If you add postprocessing features, make sure to keep them idempotent. +~ While it's possible to imagine reasons one might want to have back-and-forth +~ interplay between successive formatting and postprocessing phases, Evocation +~ goes to some trouble to make sure there is none. In Irenes' opinion, this +~ is already quite enough complexity and is nearing the limit of what humans +~ will find worthwhile. If you break idempotence, you are hereby warned that +~ you are at risk of falling into the abyss[1]. +~ +~ Postprocessing re-organizes entries, without changing their meaning, but +~ in a way that will make them easier to format. There are two things it +~ does, and they happen simultaneously: The whole array is bubble-sorted; +~ and some suffix comment entries are split apart. +~ +~ The bubble sort resolves ordering first by the address each entry is +~ attached to, low-to-high. As a tiebreaker when two entries have the same +~ address, a comment entry is sorted after a stack-manipulation entry. The +~ tiebreaker rule means that stack-manipulation commands can come after the +~ last byte that's within the comment's span; otherwise they would always have +~ to be before it. If neither criterion applies, the entries will stay in +~ whatever order they were in to begin with; that is, it's a stable sort. +~ +~ The comment splitting applies only to suffix comments, and only when their +~ length is not zero. They become a fresh-line entry at the start of the span +~ the comment originally attached to, and a zero-length suffix comment entry +~ at the end of the span. +~ +~ Please notice that adjust-length commands happen when magic comments are +~ executed, which was long, long ago by now. By the time the postprocessing +~ happens, every entry's length has been as adjusted as it's ever going to be. +~ This is important, because the order of entries is going to matter during +~ the formatting phase. +~ +~ Notice also that the splitting of suffix comment entries changes what +~ address the comment is attached to (unless it's a negative length, which is +~ already at the end of its span). Any entries that were attached to output +~ points somewhere inside the span will now definitely be before the suffix +~ comment's entry in the entry array, whereas up till now they were likely +~ somewhere after it, depending on the exact order everything was created in. +~ +~ The postprocessing phase is conceptually simple - unlike the magic-comment +~ execution phase before it, and unlike the formatting phase after it, there +~ isn't any mutable state inside the phase that would make it matter what +~ order things happen in. Enjoy this, because ordering is about to become +~ super confusing. +~ +~ Now let's consider the formatting phase. We've already mentioned that +~ there is some global state which is tracked throughout the phase, such as +~ the current indentation level and whether the output is at the start of a +~ line. The formatting phase is given an overall block of bytes in the +~ label-loop buffer, which it iterates through in order from beginning to end. +~ Any time the formatting phase reaches an address which has metadata entries +~ attached to it, all the entries at that address are executed, in the order +~ they exist in the entry array. +~ +~ Yes, that's right, executing an entry is different from executing the +~ magic comment that created the entry. That's important. +~ +~ The line-comment and suffix-comment entries do the obvious things: They +~ print out the appropriate comment text. Suffix comments are also all +~ horizontally aligned with each other, to make them easier to visually skim. +~ The two kinds of comment entries also do a less-obvious thing, which is fill +~ in any # template items that are part of the comment text, in order from +~ left to right. +~ +~ Where do those items come from? Well, there's a separate stack, the +~ subitem entry stack, which is kept in the hex output metadata header. The +~ subitem entry stack has an extremely small, fixed maximum depth. The maximum +~ depth is deliberately small, so that any leaks onto it will be detected +~ somewhere close to their root causes, for ease of diagnosis. Unusually for +~ Evocation, if you underflow or overflow it, you'll get a friendly error +~ message rather than a segfault - how nice! Of course, the error message will +~ appear in the middle of your regular output and corrupt it, but you can't +~ have everything... +~ +~ Each time a comment template is being filled and encounters a # +~ placeholder, an item is popped off the subitem entry stack and formatted +~ according to what type of entry it is. It's called an "entry stack" for a +~ reason: it's a stack of pointers to metadata entries, whose backing store +~ is in this very same entry array that we're executing. So, all the various +~ internal fields of an entry are available to provide rich behavior which +~ allows different kinds of values to be formatted in different ways. +~ +~ For those used to languages with automatic memory management, keep in mind +~ that there's no language-provided guarantee that the thing a pointer points +~ to still exists, and hasn't been replaced with some other +~ misleadingly-similar thing. The separation of all this stuff into phases +~ provides that guarantee, because there's nothing in the formatting phase +~ that destroys or moves metadata entries in the array, but if that separation +~ were to break down, astonishingly complex wrong behavior would be entirely +~ likely. If you're reading all this, it's probably to touch that code, so +~ please keep those consequences in mind. +~ +~ How do entry pointers get pushed onto the subitem entry stack, and where +~ do the values inside them come from? Okay, now this is the payoff, the part +~ where you need to understand all these phases at once. Cast your mind all +~ the way back to the magic-comment execution, and take another look at the +~ provide-* examples above. Recall that magic comment commands execute when +~ the word they're contained in is running. For the other comment commands, +~ this is mostly a curiosity; we talked about adjust-length, above, but that's +~ still just recording the fact that the word did or didn't run. +~ +~ The provide-* commands are deeper than that. They peek at the top item on +~ the stack OF THE COMPILER, the code being transformed. The -decimal and +~ -hex* variants create a corresponding -entry-type-push-subitem- metadata +~ entry of the matching type, and copy the numeric value into it. +~ +~ The -string variant expects to find a pointer to a null-terminated string; +~ -string-copy does too, but copies the contents of it to a safe place +~ immediately, on the assumption they'll be overwritten. The -keyword variant +~ expects to find a keyword (a word which, when executed, pushes its own +~ execution token onto the stack); the command extracts the name of the +~ keyword from the dictionary entry header. All three of these save pointer to +~ their respective strings in a push-subitem-string metadata entry. +~ +~ Admit it, you thought writing out "metadata entry" so many times instead +~ of just "entry" was silly because there was no other kind of entry in +~ consideration, right up until you got to "dictionary entry". If so, hey +~ look, neat, right? ;) +~ +~ The -data variant treats the value as opaque, and creates an +~ -entry-type-saved-data metadata entry. Unlike the others, these entries do +~ not affect the subitem entry stack; they're consumed and removed from the +~ entry array before entry execution even starts, by the matching data-* +~ command. +~ +~ Anyway, notice that when the various provide-* commands execute, all +~ they're doing is capturing values and creating metadata entries. Like all +~ metadata entries, these are attached to the latest output point as of the +~ time the magic comment executes. In particular, the subitem entry stack +~ isn't touched until all the way at the end, in the formatting phase. It's +~ only when the formatting reaches the address the entry is attached to that +~ the entry is executed, which has the effect of pushing a pointer to the +~ entry onto the subitem entry stack. +~ +~ It's been said already, but just to bring it all full circle, the life +~ cycle of a push-* entry ends later in the formatting phase, when a comment +~ entry pops it off the subitem entry stack and pretty-prints the value it +~ holds. +~ +~ With all this context, it likely doesn't need much explanation, but the +~ drop-subitem command will create an -entry-type-drop-subitem entry. When +~ this entry is executed, it will discard an item from the subitem entry +~ stack. Similarly, swap-subitems creates an -entry-type-swap-subitems, which +~ swaps the top two items, and roll-subitems creates an +~ -entry-type-roll-subitems, which rolls them, or unrolls them with a negative +~ parameter. + +~ In general, the order in which provide-* commands execute will most likely +~ match the order in which the corresponding bytes are output. This may not +~ always match the order in which the comment template wants to pretty-print +~ them. Therefore, you will want to use these commands to get the subitem +~ stack in the proper order. +~ +~ In using these commands that manipulate the subitem stack, it's important +~ to remember that, when formatting happens, the left-to-right output of +~ subitems in the final output comment is top-to-bottom on the subitem stack, +~ because they're popped in order. This is the opposite of the usual visual +~ representation of stacks, and can easily be confusing. +~ +~ It's probably clear from the extreme emphasis this documentation has taken +~ on describing the order things happen in, but it is quite common to define +~ a suffix comment at the start of an assembly-instruction word; adjust its +~ length as other words are called; accumulate push-* entries; then rely +~ on the address sorting to make sure the push-* entries are executed +~ before the suffix comment entry, even though the suffix-comment command +~ executed before the others, and even though the adjust-length commands may +~ have come before or after the provide-* commands that go with the same +~ suffix comment. +~ +~ Now that you have this full picture in your head, you finally also have +~ the background to understand the data-adjust-* commands. You may find it +~ helpful to go re-read the explanation of them, above, to let it sink in. +~ +~ This is the kind of forwards-and-backwards thinking which humans are +~ surprisingly good at when reading and writing software, but which it's +~ quite difficult to formalize in a way that lets a computer share that +~ understanding. If you've read this far, Irenes would absolutely adore +~ hearing about how you found the explanation and whether you did anything +~ with it; don't be shy! +~ +~ [1] https://katalepsis.net/ + +~ We have a bunch of accessors and traversers for the output metadata, which +~ are all functions from pointers to pointers. Don't confuse these with the +~ accessors for the transformation state, defined far, far above. +: hex-output-metadata-label-loop-buffer-start ; +: hex-output-metadata-label-loop-buffer-length 8 + ; +: hex-output-metadata-latest-output-point 2 8 * + ; +: hex-output-metadata-has-non-space-this-input-line 3 8 * + ; +: hex-output-metadata-suppression-count 4 8 * + ; +: hex-output-metadata-is-fresh-line 5 8 * + ; +: hex-output-metadata-indentation-depth 6 8 * + ; +: hex-output-metadata-current-column 7 8 * + ; +: hex-output-metadata-n-bytes-this-line 8 8 * + ; +: hex-output-metadata-subitem-entry-stack-depth 9 8 * + ; +: hex-output-metadata-subitem-entry-stack-zero 10 8 * + ; +: hex-output-metadata-subitem-entry-stack-capacity 8 ; +: hex-output-metadata-first-entry + 10 hex-output-metadata-subitem-entry-stack-capacity + 8 * + ; +: hex-output-metadata-entry-data-start ; +: hex-output-metadata-entry-data-length 8 + ; +: hex-output-metadata-entry-type 2 8 * + ; +: hex-output-metadata-entry-content 3 8 * + ; +: hex-output-metadata-next-entry 4 8 * + ; +: hex-output-metadata-previous-entry 4 8 * - ; +: hex-output-metadata-entry-type-line-comment 0 ; +: hex-output-metadata-entry-type-suffix-comment 1 ; +: hex-output-metadata-entry-type-fresh-line 2 ; +: hex-output-metadata-entry-type-blank-line 3 ; +: hex-output-metadata-entry-type-indent 4 ; +: hex-output-metadata-entry-type-string-literal 5 ; +: hex-output-metadata-entry-type-raw-string-literal 6 ; +: hex-output-metadata-entry-type-push-subitem-decimal 7 ; +: hex-output-metadata-entry-type-push-subitem-hex 8 ; +: hex-output-metadata-entry-type-push-subitem-hex8 9 ; +: hex-output-metadata-entry-type-push-subitem-hex16 10 ; +: hex-output-metadata-entry-type-push-subitem-hex32 11 ; +: hex-output-metadata-entry-type-push-subitem-hex64 12 ; +: hex-output-metadata-entry-type-push-subitem-string 13 ; +: hex-output-metadata-entry-type-saved-data 14 ; +: hex-output-metadata-entry-type-drop-subitem 15 ; +: hex-output-metadata-entry-type-swap-subitems 16 ; +: hex-output-metadata-entry-type-roll-subitems 17 ; + +~ Initialize the contents of the output metadata to all zeroes. This is +~ called from hex-transform at its top level, at the very start, to make sure +~ everything is structurally valid. We can't store real values at that point, +~ because they don't exist yet. The actual label-loop buffer, per its name, +~ won't be allocated until label-loop is called, so we can't possibly know its +~ address till then. +: zero-hex-output-metadata + transformation-state transformation-state-output-metadata @ + dup hex-output-metadata-label-loop-buffer-start 0 swap ! + dup hex-output-metadata-label-loop-buffer-length 0 swap ! + dup hex-output-metadata-latest-output-point 0 swap ! + dup hex-output-metadata-has-non-space-this-input-line 0 swap ! + dup hex-output-metadata-suppression-count 0 swap ! + dup hex-output-metadata-is-fresh-line 1 swap ! + dup hex-output-metadata-indentation-depth 0 swap ! + dup hex-output-metadata-current-column 0 swap ! + dup hex-output-metadata-n-bytes-this-line 0 swap ! + dup hex-output-metadata-subitem-entry-stack-depth 0 swap ! + dup hex-output-metadata-first-entry 0 swap ! ; + +~ (pointer -- boolean) +: is-in-label-loop-buffer + dup + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-start @ + <= + swap + transformation-state transformation-state-output-metadata @ + dup hex-output-metadata-label-loop-buffer-start @ + swap hex-output-metadata-label-loop-buffer-length @ + + > && ; + +: has-non-space-this-input-line@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-has-non-space-this-input-line @ ; + +: has-non-space-this-input-line! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-has-non-space-this-input-line ! ; + +: is-comment-entry + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-line-comment = swap + hex-output-metadata-entry-type-suffix-comment = || ; + +: is-output-producing-entry + dup is-comment-entry swap + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-fresh-line = 3roll || swap + hex-output-metadata-entry-type-blank-line = || ; + +: is-saved-data-entry + hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-saved-data = ; + +: is-push-subitem-entry + ~ Notably, the subitem swap, drop, and roll entry types are not + ~ push-subitem entries. + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-push-subitem-decimal = swap + dup hex-output-metadata-entry-type-push-subitem-hex = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex8 = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex16 = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex32 = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex64 = 3roll || swap + hex-output-metadata-entry-type-push-subitem-string = || ; + +: is-subitem-stack-manipulation-entry + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-drop-subitem = swap + dup hex-output-metadata-entry-type-swap-subitems = 3roll || swap + hex-output-metadata-entry-type-roll-subitems = || ; + +: is-fresh-line@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-is-fresh-line @ ; + +: is-fresh-line! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-is-fresh-line ! ; + +: fresh-line is-fresh-line@ not { newline } if ; + +: indentation-depth@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-indentation-depth @ ; + +: indentation-depth! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-indentation-depth ! ; + +: current-column@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-current-column @ ; + +: current-column! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-current-column ! ; + +: advance-current-column current-column@ + current-column! ; + +: n-bytes-this-line@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-n-bytes-this-line @ ; + +: n-bytes-this-line! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-n-bytes-this-line ! ; + +: increment-bytes-this-line n-bytes-this-line@ 1+ n-bytes-this-line! ; + +: describe-subitem-entry-stack + transformation-state transformation-state-output-metadata @ + ." depth " + dup hex-output-metadata-subitem-entry-stack-depth @ .hex64 newline + ." capacity " + hex-output-metadata-subitem-entry-stack-capacity .hex64 newline + hex-output-metadata-subitem-entry-stack-zero + hex-output-metadata-subitem-entry-stack-capacity 8 * hexdump-from ; + +: subitem-entry-stack-depth@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-depth @ ; + +: subitem-entry-stack-depth! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-depth ! ; + +: is-subitem-entry-stack-empty + subitem-entry-stack-depth@ 0 = ; + +: is-subitem-entry-stack-full + subitem-entry-stack-depth@ + hex-output-metadata-subitem-entry-stack-capacity = ; + +: push-subitem-entry-stack + is-subitem-entry-stack-full not { + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-zero + subitem-entry-stack-depth@ 8 * + ! + + subitem-entry-stack-depth@ 1+ subitem-entry-stack-depth! + } { + ~ We still consume the value, so that our caller doesn't crash. + drop + + ." Subitem entry stack overflow." newline + } if-else ; + +: pop-subitem-entry-stack + is-subitem-entry-stack-empty not { + subitem-entry-stack-depth@ 1- subitem-entry-stack-depth! + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-zero + subitem-entry-stack-depth@ 8 * + @ + } { + ." Subitem entry stack underflow." newline + + ~ We still return a value, so that our caller doesn't crash. + 0 + } if-else ; + +~ (data start, data length, entry type, string pointer, entry pointer --) +: hex-output-metadata-entry! + dup hex-output-metadata-entry-content 3roll swap ! + dup hex-output-metadata-entry-type 3roll swap ! + dup hex-output-metadata-entry-data-length 3roll swap ! + dup hex-output-metadata-entry-data-start 3roll swap ! + drop ; + +~ (entry pointer, data start, data length, entry type, string pointer +~ -- next entry pointer) +: pack-hex-output-metadata-entry + 4 pick hex-output-metadata-entry! + hex-output-metadata-next-entry ; + +~ (data start, data length, entry type, string pointer --) +: add-hex-output-metadata-entry + ~ If the suppression count is greater than zero, decrement it. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-suppression-count @ + dup 0 < { + 1- + transformation-state transformation-state-output-metadata @ + hex-output-metadata-suppression-count ! + 4 ndrop exit + } { drop } if-else + + 3 pick is-in-label-loop-buffer { + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + { dup @ dup { dup 3 pick >= drop } if } { + hex-output-metadata-next-entry + } while + + 5 unroll pack-hex-output-metadata-entry + 0 pack64 drop + } { drop drop drop drop } if-else ; + +~ (entry pointer --) +: delete-metadata-entry + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + { dup @ } { hex-output-metadata-next-entry } while + ~ (entry pointer, array-end marker pointer) + over hex-output-metadata-next-entry - 8 + + ~ (entry pointer, length of block to move) + swap dup hex-output-metadata-next-entry swap 3roll memmove ; + + +~ (-- entry pointer or 0) +: find-latest-metadata-entry + ~ Loop forward from the beginning of the entry array to find the last + ~ actual entry. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + dup @ { + { dup hex-output-metadata-next-entry @ } + { hex-output-metadata-next-entry } while + } if ; + +~ (-- entry pointer or 0) +: find-latest-comment-metadata-entry + find-latest-metadata-entry + ~ (entry pointer or 0) + + ~ If and only if we actually found one, now loop backwards to find the + ~ most recent one that's a comment entry. All length adjustments apply to + ~ comment entries, anything else needs to be skipped for this purpose. + { dup { dup is-comment-entry not } { 0 } if-else } + { transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + over > { + hex-output-metadata-previous-entry } { drop 0 } if-else } while + ~ (entry pointer or 0) + ; + +~ (-- entry pointer or 0) +: find-latest-output-producing-metadata-entry + find-latest-metadata-entry + ~ (entry pointer or 0) + + ~ If and only if we actually found one, now loop backwards to find the + ~ most recent one that's an output-producing entry. + { dup { dup is-output-producing-entry not } { 0 } if-else } + { transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + over > { + hex-output-metadata-previous-entry } { drop 0 } if-else } while + ~ (entry pointer or 0) + ; + +~ (-- entry pointer or 0) +: find-latest-saved-data-metadata-entry + find-latest-metadata-entry + ~ (entry pointer or 0) + + ~ If and only if we actually found one, now loop backwards to find the + ~ most recent one that's a comment entry. All length adjustments apply to + ~ comment entries, anything else needs to be skipped for this purpose. + { dup { dup is-saved-data-entry not } { 0 } if-else } + { transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + over > { + hex-output-metadata-previous-entry } { drop 0 } if-else } while + ~ (entry pointer or 0) + ; + +~ (target start location -- entry pointer or 0) +: find-first-comment-metadata-entry-with-start + ~ Find the first entry, but if it doesn't exist, we want 0 instead. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + ~ (target start location, entry pointer) + + ~ Now loop forwards to find the first that's a comment entry and has the + ~ desired start location. + { dup @ } { + dup is-comment-entry + over hex-output-metadata-entry-data-start @ 3 pick = + && { swap drop exit } if + hex-output-metadata-next-entry + } while drop drop 0 ; + + +~ (target start location -- entry pointer or 0) +: find-latest-comment-metadata-entry-with-start + find-latest-metadata-entry + ~ (target start location, entry pointer or 0) + + dup { + { dup @ } { + dup is-comment-entry + over hex-output-metadata-entry-data-start @ 3 pick = + && { swap drop exit } if + + dup + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + = { drop drop 0 exit } if + + hex-output-metadata-previous-entry + } while + } if swap drop ; + + +~ (length adjustment --) +: adjust-latest-comment-metadata-entry-length + find-latest-comment-metadata-entry + + ~ We've found the entry we want to act on, if it exists, so do it. + dup { + hex-output-metadata-entry-data-length dup @ 3roll + swap ! + } { + drop + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. + ." No pre-existing metadata entry to adjust." newline + crash + } if-else ; + +~ (length adjustment --) +: adjust-latest-output-producing-metadata-entry-start + find-latest-output-producing-metadata-entry + + ~ We've found the entry we want to act on, if it exists, so do it. + dup { + hex-output-metadata-entry-data-start dup @ 3roll + swap ! + } { + drop + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. + ." No pre-existing metadata entry to adjust." newline + crash + } if-else ; + + +~ (target start location --) +: delete-first-comment-metadata-entry-with-start + find-first-comment-metadata-entry-with-start + dup { delete-metadata-entry } { drop } if-else ; + +~ (target start location --) +: delete-latest-comment-metadata-entry-with-start + find-latest-comment-metadata-entry-with-start + dup { delete-metadata-entry } { drop } if-else ; + +: delete-first-comment-metadata-entry-at-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point @ + delete-first-comment-metadata-entry-with-start ; + +: delete-latest-comment-metadata-entry-at-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point @ + delete-latest-comment-metadata-entry-with-start ; + + +~ (value --) +: set-latest-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point ! ; + +~ (adjustment --) +: adjust-latest-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point + dup 3unroll @ + swap ! ; + +~ (-- data value) +: data-consume + find-latest-saved-data-metadata-entry + ~ (entry pointer or 0) + + dup { + dup hex-output-metadata-entry-content @ swap + ~ (data value, entry pointer) + + delete-metadata-entry + } { + drop + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. + ." No saved-data metadata entry to take a value from." newline + + ~ We still return a value, so that our caller doesn't crash. + 0 + } if-else ; + +~ (adjustment scale factor --) +: data-adjust-latest-comment-metadata-entry-length + ~ All the entry array manipulation happens in data-consume. Once we're + ~ done doing that, the array is now in a consistent state, so we can hand + ~ off to the non-data implementation to do the rest of the work. + data-consume * adjust-latest-comment-metadata-entry-length ; +~ (adjustment scale factor --) +: data-adjust-latest-output-producing-metadata-entry-start + ~ Same as for adjusting the entry length. + data-consume * adjust-latest-output-producing-metadata-entry-start ; + +~ (value offset --) +: data-set-latest-output-point + data-consume + set-latest-output-point ; +~ (adjustment scale factor --) +: data-adjust-latest-output-point + data-consume * adjust-latest-output-point ; + + +~ (count adjustment --) +: adjust-hex-output-suppression-count + transformation-state transformation-state-output-metadata @ + hex-output-metadata-suppression-count dup @ 3roll + swap ! ; + +~ This is the followup to zero-hex-output-metadata, above. Once we do have +~ the label-loop buffer, we need to create some default entries. This is +~ called in the first label-loop iteration by hex-allocate-replacement, and +~ it's called before subsequent iterations by the hook on reset-labels defined +~ in hex-colon-alternate. +~ +~ This overwrites whatever entries currently exist with the new ones, and +~ adds a zero delimiter at the end. +~ +~ In addition to setting up the entries, we also set latest-output-point to +~ the start of the label-loop buffer here. This needs to happen at the start +~ of each pass, so although it doesn't quite fit the name, we do it here. +~ +~ It requires the header to have already been initialized; in particular it +~ requires the label-loop buffer start pointer to be valid. +: create-hex-output-metadata-top-of-file-entries + transformation-state transformation-state-output-metadata @ + dup hex-output-metadata-label-loop-buffer-start @ + swap hex-output-metadata-first-entry + ~ (label buffer start, metadata output point) + + ~ This likely won't affect anything, because every call to pack* + ~ overwrites it, but we initialize the latest output point to the start of + ~ the label loop buffer here. That way, in the event the very first thing in + ~ the output is something that's supposed to have a magic comment on it, + ~ hex-tilde-replacement will know where to attach the metadata entry. + ~ + ~ If that was word soup, go read about hex-tilde-replacement and + ~ hex-tilde-alternate and come back. :) + over + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point ! + 0 has-non-space-this-input-line! + + over 0 hex-output-metadata-entry-type-line-comment + s" This file is a commented hexadecimal representation of a compiled" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" program, the output of Evocation's hex transform. The comments are" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" intended to allow a human reader to audit it. You can convert it to a" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" runnable executable by piping it through the program named 'hex' and" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" chmodding the output 755. The difference between a source and a binary" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" is comments! Enjoy. :)" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-blank-line 0 + pack-hex-output-metadata-entry + + 0 swap ! ~ End-of-entries delimiter + drop ; + +: hex-self-codeword-alternate self-codeword ; + +: hex-string-alternate + ~ The technique we use to wrap s" is analogous to how we do it in the + ~ label transform, but with one critical decision different. + ~ + ~ In the label transform, the output buffer is going to be written + ~ directly into the final executable at some point, and we'd really rather + ~ not scribble temporary values into it, even if we expect to overwrite them + ~ later. Additionally, everything the label transform does runs inside the + ~ label loop, so the code it's transforming isn't expected to do any sort of + ~ miscellaneous setup things, just define a bunch of words. In that + ~ situation, making sure to use temporary space from the outer, "real" log + ~ is helpful. + ~ + ~ In the hex transform, most of that is different. The output buffer will + ~ include all sorts of things that don't become part of the final + ~ executable, though they're used in producing it. So, it's fine to use it + ~ for scratch space. Additionally, using the outer log for string literals + ~ gets us into trouble, since some of these temporary strings need to be + ~ made more durable by calling allocate-string on them. If we do that with + ~ a string pointer backed by the outer log, the inner "here" will wind up + ~ pointing to the end of the outer log, and all sorts of things will start + ~ scribbling atop each other. + ~ + ~ We do still benefit from using the interpreted version of s" rather than + ~ the compiled one; as with the label transform, it's convenient to handle + ~ the litstring dance ourselves. + ~ + ~ If we're in compile mode, we have reinvented a problem which the + ~ regular, non-transformed s" already deals with: The temporary space we're + ~ writing to is in the same place as the code we're compiling. We solve it + ~ the same way: Check beforehand and write out the call to litstring if we + ~ need it, so that we won't have to slide things around later. + interpreter-flags @ 0x01 & { + ~ We look up the inner version of litstring to reference here. This is + ~ similar to what the label transform does, except we don't use a label + ~ for it. + s" litstring" find entry-to-execution-token , + } if + + ~ Now, regardless of what mode we're actually in, call the interpreted + ~ version of s" to read the actual string and its null terminator. + interpreter-flags @ + ' s" entry-to-execution-token + [ ' [ entry-to-execution-token , ] + execute + swap interpreter-flags ! + + ~ Now we have a string pointer on the stack at transform time. If we're in + ~ immediate mode, that's sufficient. If we're in compile mode, we also + ~ already output a litstring invocation, and the string is in the right + ~ place, but "here" is pointing before it and needs to point after it, then + ~ we also still need to add alignment padding. Plus, we need to be sure to + ~ not leave the string pointer itself on the stack. + interpreter-flags @ 0x01 & { + dup stringlen 1+ + 8 packalign here ! + } if + ; make-immediate + +: hex-dot-string-alternate + ' hex-string-alternate entry-to-execution-token execute + + interpreter-flags @ 0x01 & { + ~ We look up the inner version of emitstring, too. + s" emitstring" find entry-to-execution-token , + } { emitstring } if-else + ; make-immediate + +: hex-create-alternate create ; + +~ This is a helper called from the patched version of "variable", described +~ in more detail in hex-colon-alternate, below. It expects to be called after +~ outputting the entry header for "variable", during the body of the +~ definition, so that it can output compiled code which will run as part of +~ the transformed "variable". +~ +~ The helper accepts a string pointer giving a variable name. The code it +~ produces checks the name of the variable being defined and, if the two names +~ match, alters the resulting inner variable to point to the same backing +~ store as the outer variable of the same name. +~ +~ In many ways the hex transform is the trippiest one. To wit, there's two +~ layers of compilation happening here... so don't get confused. When the +~ helper is called, we're compiling the inner "variable", but "variable" +~ itself is a word-defining word which also has the task of compilation... +~ which we're modifying. +~ +~ (name pointer --) +: hex-variable-use-outer + ~ The actual payload here is that we check whether we're defining the + ~ word described by the name pointer we were given, and, if so, we make it + ~ reference the outer backing store instead of the inner one. + ~ + ~ We want to do this all as references to inner words, which fortunately + ~ have been defined by now, but we have to do that a bit indirectly... + s" dup" find entry-to-execution-token , + s" litstring" find entry-to-execution-token , + here @ over packstring 8 packalign here ! + s" stringcmp" find entry-to-execution-token , + s" lit" find entry-to-execution-token , 0 , + s" =" find entry-to-execution-token , + + ~ Also, we don't have high-level flow control yet, and even if we did, + ~ it would be awkward to use it here. So we count the branch by hand. Ah + ~ well. As always, remember that with forward branches, the offset to + ~ branch by is the first word to be skipped, and is included in the count. + s" 0branch" find entry-to-execution-token , 6 8 * , + + ~ If control reaches here in the generated code, the string matched. + s" swap" find entry-to-execution-token , + s" drop" find entry-to-execution-token , + + ~ To get the value of the outer variable, we just call it. Of course, + ~ looking up an outer entry is a pain, but at least it's a pain in a way + ~ that should be familiar by now. + s" lit" find entry-to-execution-token , + swap-transform-variables + find + swap-transform-variables + entry-to-execution-token execute , + + s" swap" find entry-to-execution-token , ; + +~ This is a helper used by postprocess-metadata-entries, below. It +~ duplicates the entry it's given, creating a second identical copy +~ immediately after it in the entry array, sliding everything else forward to +~ make room. +~ +~ (entry pointer --) +: dup-metadata-entry + ~ Find all the remaining entries, and the final terminator, and slide + ~ them forward by the length of one entry. + dup dup + ~ (entry pointer, entry pointer, entry pointer) + + { dup @ } { hex-output-metadata-next-entry } while 8 + + ~ (entry pointer, entry pointer, entry array end pointer) + swap - + ~ (entry pointer, entry array tail length) + swap dup hex-output-metadata-next-entry 3roll + ~ (entry pointer, adjusted entry pointer, entry array tail length) + memmove ; + +~ This is a helper used by postprocess-metadata-entries, below. It swaps +~ the contents of the entry it's given with the contents of the entry +~ immediately after it in the entry array. +~ +~ (entry pointer --) +: swap-metadata-entries + ~ Copy the current entry to a scratch area. + dup dup dup hex-output-metadata-next-entry swap - + ~ (entry pointer, entry pointer, entry length) + swap-transform-variables here @ swap-transform-variables swap + ~ (entry pointer, entry pointer, scratch pointer, entry length) + memcopy + ~ (entry pointer) + + ~ Copy the next entry over the current entry. + dup dup hex-output-metadata-next-entry dup + ~ (entry pointer, entry pointer, next entry pointer, next entry pointer) + 3roll - + ~ (entry pointer, next entry pointer, entry length) + 2 pick swap + ~ (entry pointer, next entry pointer, entry pointer, entry length) + memcopy + ~ (entry pointer) + + ~ Copy the scratch area over the next entry. + dup hex-output-metadata-next-entry dup + ~ (entry pointer, next entry pointer, next entry pointer) + 3roll - + ~ (next entry pointer, entry length) + swap-transform-variables here @ swap-transform-variables 3unroll + ~ (scratch pointer, next entry pointer, entry length) + memcopy ; + +~ Metadata entries are post-processed before they're output, in order to +~ make the structure of the output code simpler. The post-processing won't +~ happen until output actually occurs, which is important for operations that +~ modify entries in-place. +~ +~ Any time output is performed, all existing entries are post-processed. +~ Therefore, the post-processing is required to be idempotent, and is. +: postprocess-metadata-entries + 1 { } { + 0 + ~ (did anything this iteration) + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + { dup @ } { + ~ (did anything, entry pointer) + + ~ Is the entry a suffix comment with a non-zero data length? + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-suffix-comment = + over hex-output-metadata-entry-data-length @ 0 != && { + ~ Split it into two entries so as not to rely on data length for + ~ formatting. + dup dup-metadata-entry + ~ (did anything, entry pointer) + ~ Now we have the original entry at the original location, and a copy + ~ of it at the next location. + + ~ We have a feature which lets a suffix comment be created with a + ~ negative length, which means it covers bytes before the current output + ~ point rather than after it. This logic here is the implementation of + ~ that feature. + dup hex-output-metadata-entry-data-start @ dup + 2 pick hex-output-metadata-entry-data-length @ + + 2dup min 3unroll max + ~ (..., entry pointer, low end of data, high end of data) + + ~ Now we modify the original in-place to turn it into a fresh-line + ~ entry at the low end of the data... + 2 pick hex-output-metadata-entry-type + hex-output-metadata-entry-type-fresh-line swap ! + ~ (..., entry pointer, low end of data, high end of data) + + 2 pick hex-output-metadata-entry-data-start 3roll swap ! + ~ (..., entry pointer, high end of data) + over hex-output-metadata-entry-data-length 0 swap ! + ~ (..., entry pointer, high end of data) + + ~ ... then we modify the next entry in-place to set its location to + ~ the end of the data instead of the beginning, and its length to zero. + over hex-output-metadata-next-entry + ~ (..., entry pointer, high end of data, next entry pointer) + + dup hex-output-metadata-entry-data-start 3roll swap ! + ~ (..., entry pointer, next entry pointer) + hex-output-metadata-entry-data-length 0 swap ! + ~ (..., entry pointer) + + ~ This rule won't fire again on the fresh-line entry because it's of a + ~ a different type, and it won't fire on the modified suffix-comment + ~ entry because its data length is zero. + ~ + ~ It's possible that one or the other of the bubble-sort rules will + ~ fire on either of them. + + ~ (did anything, entry pointer) + swap drop 1 swap + } if + ~ (did anything, entry pointer) + + ~ Do this entry and the next entry both exist, and they're out of + ~ order based on their data starts? + dup hex-output-metadata-next-entry dup @ + { hex-output-metadata-entry-data-start @ + over hex-output-metadata-entry-data-start @ > } + { drop 0 } if-else + { + ~ Swap the order of the two entries. Since this whole thing is in a + ~ loop, this functions as a bubble sort. + dup swap-metadata-entries + swap drop 1 swap + + ~ This rule won't fire again on the same pair of entries because now + ~ they're in the correct order. It may fire again next iteration, + ~ but only until everything is sorted. + ~ + ~ This rule does nothing to alter whether the suffix-comment rule + ~ will fire on either of the entries it swapped, so there's no + ~ possibility of an infinite loop through that one. + } if + ~ (did anything, entry pointer) + + ~ Do this entry and the next entry both exist, and they have the same + ~ data start, and this one is a comment entry, and the next one is a + ~ stack-manipulation entry with zero length? + dup is-comment-entry over hex-output-metadata-next-entry @ && + { ~ (did anything, entry pointer) + dup hex-output-metadata-next-entry + over hex-output-metadata-entry-data-start @ + over hex-output-metadata-entry-data-start @ = + swap dup hex-output-metadata-entry-data-length @ 0 = 3roll && swap + is-subitem-stack-manipulation-entry && } + { 0 } if-else + { + ~ Swap the order of the two entries. Since this whole thing is in a + ~ loop, this functions as a bubble sort. + dup swap-metadata-entries + swap drop 1 swap + + ~ This rule can't fire in the same iteration as the previous swap, + ~ because that one doesn't fire when the starts are equal. It also + ~ won't fire again on the same pair of entries, again because now + ~ they're in the correct order. If it fires again in the next + ~ iteration that'll only be in the usual way it does for a bubble + ~ sort. + ~ + ~ As with the other swap rule, this rule also does nothing to alter + ~ whether the suffix-comment rule will fire on either entry it + ~ touches, so it won't loop through that one. + } if + ~ (did anything, entry pointer) + + hex-output-metadata-next-entry + } while drop + } while ; + +: hex-comment-first-tab-stop 36 ; +: hex-comment-second-tab-stop 58 ; + +~ This is a helper called from hex-emit-template-string. The word pointer +~ is in the outer log's scratch space, and must not be overwritten. +~ +~ (queued space count, word pointer -- should ignore space) +: hex-emit-template-string-word + dup s" #" stringcmp 0 = { + ~ (queued space count, word pointer) + drop + + pop-subitem-entry-stack + ~ (queued space count, subitem entry) + + ~ If we underflowed the stack, we got zero back, so make sure not to + ~ crash. A crash here would be a pain to debug because it would be + ~ unclear how much of the overall system is working, and it's a + ~ complex system. + dup { + ~ (queued space count, subitem entry) + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-decimal = { + swap dup indent advance-current-column 0 swap + + dup hex-output-metadata-entry-content @ + dup 10 swap logfloor 1+ advance-current-column + . + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ + dup 16 swap logfloor 1+ 2 + advance-current-column + .hex + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex8 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex8 + 4 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex16 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex16 + 6 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex32 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex32 + 10 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex64 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex64 + 18 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-string = { + swap dup indent advance-current-column 0 swap + + dup hex-output-metadata-entry-content @ + dup stringlen advance-current-column + emitstring + } if + } if + + drop drop 0 exit + } if + + dup s" #--" stringcmp 0 = { + ~ (queued space count, word pointer) + + hex-comment-second-tab-stop current-column@ + 2dup > { + drop drop swap drop 0 swap + newline + hex-comment-first-tab-stop indent ." ~" + hex-comment-second-tab-stop hex-comment-first-tab-stop 1+ - indent + hex-comment-second-tab-stop current-column! + } { + - dup indent advance-current-column + swap drop 0 swap + } if-else + + drop drop 1 exit + } if + + ~ (queued space count, word pointer) + swap dup indent advance-current-column + dup stringlen advance-current-column + emitstring 0 ; + + +~ (string pointer --) +: hex-emit-template-string + 0 swap + ~ (queued space count, input point) + + { unpack8 dup } { + ~ (queued space count, input point, latest character) + dup is-space { + ~ Instead of outputting space characters as we reach them, we keep a + ~ count of how many are pending. This allows us to do word-wrapping + ~ without having to worry about trailing spaces. + 3roll 1+ 3unroll drop + } { + ~ (queued space count, input point, first word character) + ~ We use the outer log's scratch space to accumulate each word in. + swap-transform-variables here @ swap-transform-variables + swap + pack8 + swap + ~ (queued space count, scratch output point, input point) + + ~ Scan forward and find a space-separated word. + { unpack8 dup dup is-space not && } { + ~ (queued space count, scratch output point, adjusted input point, + ~ next character) + 3roll swap pack8 swap + ~ (queued space count, adjusted scratch output point, + ~ adjusted input point) + } while + ~ (queued space count, scratch output point, input point, + ~ first non-word character or 0) + 3roll 0 pack8 drop + ~ (queued space count, input point, first non-word character or 0) + + swap-transform-variables here @ swap-transform-variables + ~ (queued space count, input point, first non-word character or 0, + ~ word pointer) + + 4 roll swap 1 max hex-emit-template-string-word 0 4 unroll + ~ (queued space count, input point, first non-word character, + ~ should ignore space) + + over { + ~ If the character is non-zero, it's a space, so it can't be part of + ~ a word, so we can queue it for later output... unless we were asked + ~ to skip it, of course. + not { + ~ (queued space count, input point, first non-word character) + 3roll 1+ 3unroll + } if + drop + } { + ~ If this is the end of the string, we can discard the 0, but then + ~ we need to nudge the input point back so the loop will terminate. + drop drop 1- + } if-else + ~ (queued space count, input point) + } if-else + } while drop drop drop ; + + +~ (string pointer --) +: hex-emit-comment + hex-comment-second-tab-stop current-column@ > { + newline + hex-comment-first-tab-stop dup indent current-column! + 1 is-fresh-line! + 0 n-bytes-this-line! + } if + + ." ~" + 1 advance-current-column + + dup @ { + space + 1 advance-current-column + } if + + hex-emit-template-string ; + + +~ This "replacement" is a little different from an alternate: When the code +~ under transformation attempts to compile its own version of sys-write, it +~ gets a stub that calls this word instead. It's swapped out by +~ hex-colon-alternate, whereas the regular alternates are swapped out by +~ hex-transform-one. +~ +~ In the programs we're actually running the transform on, there's only ever +~ a single call to sys-write which is the whole binary in one go, but we don't +~ want to require that, so we keep all the formatting state in the output +~ metadata header. +~ +~ (file descriptor, base address, length to write -- length written) +: hex-sys-write-replacement + ~ In intended operation, the code under transformation is a compilation + ~ process, and it won't output anything that isn't executable binary. + ~ However, while developing, it's common to have crashes, and it's nice to + ~ get the crash dump as ASCII rather than hex. + over is-in-label-loop-buffer not { + sys-write exit + } if + 3roll drop dup 3roll + ~ The result should be the length written. We just proactively declare + ~ that we'll write the full length we were asked to, threading that through + ~ as the result we'll eventually return. + ~ (result, length to write, base address) + + postprocess-metadata-entries + + ~ Importantly, postprocessing leaves the entries sorted, which means we + ~ can go back and forth in a linear scan through the entry array while we + ~ also do a linear scan of the output data. It's fiddly, but we can't afford + ~ to be O(n^2) here, it adds up to quite a lot of runtime. + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + ~ (result, length to write, base address, initial metadata scan pointer) + { 2 pick 0 <= } { + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + ~ Keep inspecting entries as long as the output address is greater than + ~ or equal to the entry address. If we're looking at the entries that come + ~ before the output, this will scan through all of them first, then + ~ eventually catch up. Since the scan pointer is kept across iterations, + ~ it's important we not go beyond that point. + { dup @ dup + ~ (result, length remaining, current output address, + ~ metadata scan pointer, entry's first field, entry's first field) + { + ~ This is an nop, but for clarity's sake it's best to not depend on + ~ details of the structure layout that perhaps not everyone has + ~ memorized... + ~ + ~ To get into this block, we tested for the array end indicator, but + ~ now that we know we have an entry here, we're looking at its + ~ contents. + hex-output-metadata-entry-data-start + + dup 3 pick + ~ (result, length remaining, current output address, + ~ metadata scan pointer, entry's data start, entry's data start, + ~ current output address) + >= swap drop + } if + } { + dup @ + 2 pick = { + ~ We found a matching metadata entry. + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-line-comment = { + fresh-line + indentation-depth@ dup indent advance-current-column + + dup hex-output-metadata-entry-content @ hex-emit-comment + newline + + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-suffix-comment = { + hex-comment-first-tab-stop current-column@ - 1 max + dup indent advance-current-column + + dup hex-output-metadata-entry-content @ hex-emit-comment + newline + + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-fresh-line = { + fresh-line + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-blank-line = { + fresh-line + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-indent = { + dup hex-output-metadata-entry-content @ + indentation-depth@ + indentation-depth! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-string-literal = { + fresh-line + indentation-depth@ dup indent advance-current-column + + ." ~ " + 0x22 value@ emitstring drop + dup hex-output-metadata-entry-content @ emitstring + 0x22 value@ emitstring drop + ." (string literal with null)" + + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-raw-string-literal = { + fresh-line + indentation-depth@ dup indent advance-current-column + + ." ~ " + 0x22 value@ emitstring drop + dup hex-output-metadata-entry-content @ emitstring + 0x22 value@ emitstring drop + ." (raw string literal)" + + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup is-push-subitem-entry { + dup push-subitem-entry-stack + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-saved-data = { + ~ It's not valid to execute these, so print a diagnostic. They're + ~ supposed to always be consumed by data-* commands. + ." A saved-data metadata entry leaked." newline + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-drop-subitem = { + pop-subitem-entry-stack drop + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-swap-subitems = { + ~ If we underflow the stack, we'll get zeroes back here. In order + ~ to avoid causing more confusing problems later, we make sure to + ~ discard the zeroes instead of pushing them. Just like in + ~ hex-emit-template-string, the reasoning is that it's easier to + ~ diagnose what's wrong with this subsystem when it runs to + ~ completion. + pop-subitem-entry-stack + pop-subitem-entry-stack + swap + dup { push-subitem-entry-stack } { drop } if-else + dup { push-subitem-entry-stack } { drop } if-else + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-roll-subitems = { + ~ The parameter giving the amount to roll by is in the content + ~ field. + dup hex-output-metadata-entry-content @ + ~ (... amount to roll by) + + ~ We resist the temptation to do the memcopy math. We don't need + ~ to, since the regular Forth roll and unroll do it for us. + dup 0 < { + ~ In this scenario, we're rolling. The amount to roll by is also + ~ the number of items. + + 0 { 2dup < } { pop-subitem-entry-stack 3unroll 1+ } while + drop + ~ (... items, amount to roll by / number of items) + + ~ Please notice that the items we have popped from the subitem + ~ entry stack are now, on the value stack, in the reverse of the + ~ order they were on the entry stack. They will reverse again when + ~ we push them back. + ~ + ~ The amount to roll by is positive, so the desired operation is + ~ a regular roll. Since the entries are reversed right now, we + ~ unroll them, which will be what we want when we put them back. + ~ + ~ Try it out interactively with a toy example and convince + ~ yourself. It's hard to really model in your head, but it's true. + ~ The intuition is that, if you're looking at the value stack, + ~ the bottommost item there will be the topmost one after + ~ re-reversing, so we think of our operations as proceeding + ~ up-stack from there, instead of the usual operations that start + ~ at the topmost item and proceed downwards. + ~ + ~ Anyway, this little trick does a regular unroll, which acts as + ~ a roll, and keeps the value around. + dup 3unroll 1+ unroll + } if + ~ (... items if positive, amount to roll by) + + ~ We did the positive case first, which means the amount to roll + ~ by is still its original value, regardless of whether that case + ~ ran or not. So, we can check if it's negative to see if we need + ~ to do the negative case. + dup 0 > { + ~ In this scenario, we're unrolling. We negate the amount to + ~ roll by to get the amount to unroll by, which is also the number + ~ of items. + negate + + 0 { 2dup < } { pop-subitem-entry-stack 3unroll 1+ } while + drop + ~ (... items, number of items) + + ~ The parameter was negative, so we were asked to do an unroll. + ~ This trick does a roll, and keeps the value. Notice that "roll" + ~ always needs a positive amount. + dup 1+ roll swap + } if + ~ (... items, number of items) + + ~ Now, regardless of which case ran, we have the items and we have + ~ a non-negative count of them. Notice that if we were asked to roll + ~ by zero, neither case ran, but that still describes what we have + ~ accurately. + + ~ Now we push them back. + 0 { 2dup < } { + 3roll + + ~ Again, if we underflowed we got zeros, and we discard them. + dup { push-subitem-entry-stack } { drop } if-else + + 1+ + } while + drop drop + } if + } if + hex-output-metadata-next-entry + } while + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + 2 pick { + n-bytes-this-line@ 16 = { + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + is-fresh-line@ { + indentation-depth@ dup indent advance-current-column + } { + space + 1 advance-current-column + } if-else + + over 8@ .hex8 + + 2 advance-current-column + increment-bytes-this-line + 0 is-fresh-line! + } if + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + 3unroll 1+ swap 1- swap 3roll + } while drop ; + +~ This has complex logic, so we do it as a trace rather than with magic +~ comments. +~ +~ (new label value, label entry pointer --) +: hex-set-label-trace + ~ If the value is zero, don't bother making an entry. There's a bunch of + ~ unused labels set to zero and even if they were used, showing them at the + ~ start of the file would not provide useful information. + over 0 = { drop drop exit } if + + ~ Similarly, if the label has its non-offset bit set, we don't need an + ~ entry for that, either + ~ + ~ It's worth noting that this bit is set by the code being compiled, + ~ potentially after it has already called label-set, and therefore after + ~ this trace. This introduces an ordering dependency, though it's unlikely + ~ to come up in practice because the bit is kept across label-loop passes + ~ and as long as there are any forward references there will always be at + ~ least two passes. + dup is-label-non-offset { drop drop exit } if + + ~ Recall that label values are offsets within the output file. This is not + ~ otherwise a requirement, compiled code can use their values for anything + ~ it wants, but the label transform treats them as offsets and so does the + ~ ELF code. + ~ + ~ We want to create metadata entries associated with that offset; recall + ~ also that entries' data starts are host addresses which must be within + ~ the label-loop buffer. So... + over + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-start @ + + 0 + ~ (new label value, label entry pointer, entry data start, + ~ entry data length) + + 2dup hex-output-metadata-entry-type-push-subitem-hex64 7 roll + add-hex-output-metadata-entry + ~ (label entry pointer, entry data start, entry data length) + + 2dup hex-output-metadata-entry-type-push-subitem-string + 6 roll entry-to-name + + swap-transform-variables here @ swap-transform-variables dup 3unroll + ~ (copy, original, copy) + over stringlen 1+ memcopy + swap-transform-variables allocate-string swap-transform-variables + add-hex-output-metadata-entry + + hex-output-metadata-entry-type-line-comment + s" label # at offset # is here." + add-hex-output-metadata-entry ; + +~ (data start, data length --) +: hex-pack-trace + ~ We keep a running tally of the next address in the output, for the + ~ benefit of hex-tilde-replacement, which needs to know where to attach its + ~ metadata entries. + + + dup is-in-label-loop-buffer { + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point ! + } { drop } if-else ; + +~ (output point, string pointer --) +: hex-packstring-trace + dup stringlen 1+ + ~ (output point, string pointer, string length) + 2 pick over hex-pack-trace + swap + ~ (output point, string length, string pointer) + drop over + hex-output-metadata-entry-type-string-literal swap + add-hex-output-metadata-entry ; + +~ The purpose of this word is to make sure that the memory-sliding +~ techniques used by the high-level flow control words are appropriately +~ reflected in the output metadata. This is accomplished by finding all +~ entries whose data start pointer or string content pointer is within the +~ slid region, and adjusting the relevant pointer appropriately. +~ +~ Notice that this strategy means there's no metadata entry describing the +~ old location of the slid memory, though sliding is non-destructive. The +~ assumption is that that location is going to be overwritten with new code, +~ which will have its own metadata entries created as the new code is written. +~ Otherwise, since we don't do anything to erase metadata entries pertaining +~ to overwritten locations, old and new metadata entries would overlap and +~ cause confusion. The assumption is correct for all existing uses of +~ memory-sliding as of the time this was written, but it's possible it will +~ need to be revisited someday. +~ +~ This word is called for both memcopy and memmove. It's called by +~ hex-memory-slide-replacement, which is itself installed by a variety of +~ means for different situations; see its documentation for more detail. +~ +~ (source, destination, length --) +: hex-memory-slide-trace + 2 pick is-in-label-loop-buffer + 2 pick is-in-label-loop-buffer && + { + ~ At the time this runs, the metadata entry array isn't sorted, so we + ~ check the whole thing. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + ~ (source, destination, length, initial metadata scan pointer) + { dup @ } { + ~ (source, destination, length, metadata scan pointer) + + dup hex-output-metadata-entry-data-start @ 4 pick <= + ~ (source, destination, length, metadata scan pointer, lower bound okay) + over hex-output-metadata-entry-data-start @ 5 pick 4 pick + > + && { + ~ (source, destination, length, metadata scan pointer) + dup hex-output-metadata-entry-data-start @ 4 pick - 3 pick + + over hex-output-metadata-entry-data-start ! + } if + + dup hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-string-literal = + swap hex-output-metadata-entry-type-raw-string-literal = || { + dup hex-output-metadata-entry-content @ + ~ (source, destination, length, scan pointer, content pointer) + dup 5 pick <= + ~ (source, destination, length, scan pointer, content pointer, + ~ lower bound okay) + over 6 pick 5 pick + > && { + ~ (source, destination, length, scan pointer, content pointer) + 4 pick - 3 pick + + over hex-output-metadata-entry-content ! + } { drop } if-else + } if + + hex-output-metadata-next-entry + } while 4 ndrop + } { drop drop drop } if-else ; + + +~ By overriding colon, we can special-case the definitions of particular +~ words. It's very metacircular. +~ +~ This lets us prepend trap code to the original definition. For those not +~ familiar, a "trap" in systems programming is code that runs instead of some +~ other, pre-existing code, by violating the usual abstractions in some way. +~ We implement our traps by creating the word header, including the docol +~ pointer, then compiling the trap code before we return from the colon +~ alternate, so that it's already been output before the original word's body +~ starts to compile. +~ +~ Prepending our trap code to the original code like this can also be used +~ to get the effect of replacing the original code entirely by calling "exit" +~ at the end of our trap. The original code will still be compiled, after the +~ trap code, but doing this will make sure it doesn't run. Most of the time, +~ though, we do want to run the original code, so we allow the trap to fall +~ through to it. We carefully note fall-through with comments, to make the +~ traps easier to maintain. +~ +~ The kinds of side-effects we care about can all be written this way, +~ though occasionally we wind up having to compute an intermediate value that +~ the code we're trapping will then compute independently, and it's important +~ to keep those implementations in sync. +~ +~ The most significant challenge is that, because our trap will be defined +~ at the same point in loading as the original word would be, it can only use +~ words that are available at that point. Occasionally this results in some +~ awkwardness. +~ +~ Code for these traps winds up looking a lot like code written for log-load +~ alternates, in that we have to do the dictionary lookups and other +~ compilation ourselves. +~ +~ At times, we also need to trap words that are implemented in assembler. +~ The most notable of these is "sys-write", which is fundamental to what the +~ hex transform does. The details of how we make our traps work with assembler +~ words are explained below, as they arise. +: hex-colon-alternate + word value@ + + ~ The word "variable" is itself a word-defining word, and we will + ~ special-case its definition to special-case the definitions of particular + ~ variables. It's very very metacircular. + dup s" variable" stringcmp 0 = { + ~ Don't lose track of the layering happening here. The word "variable" + ~ is a regular docol word; it's defining a word that's implemented in + ~ assembly, but it can use whatever Forthy logic it wants to do so. In + ~ this case we're going to have it run a little extra logic, then continue + ~ with the rest of its usual definition. + + ~ Before we get to the extra logic, we do want an entry header for + ~ "variable" itself, so we do that... This takes care of all of colon's + ~ responsibilities except switching to compile mode; we'll do that part + ~ after we've output our payload. + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ There's two variables that we want to point to the outer backing + ~ stores, rather than the inner ones. The code for that is a bit + ~ repetitive, so we have a helper for it; see above. + ~ + ~ It is worth stopping to contemplate the meaning of sharing these two + ~ variables in particular between the inner and outer contexts. + ~ Essentially this says that they're both reading the same input stream, + ~ and the two copies of the interpreter both share the same state. Thus, + ~ trading off responsibility for lexing between inner and outer contexts + ~ works just like trading off responsibility between two interpreters + ~ when there's no transformation involved, or between a regular + ~ interpreter and a transform. + ~ + ~ If we didn't do this, we'd still have to invent some way to control + ~ what input the inner context sees, and the concept of "the next + ~ character" would become more complex during the transform and require + ~ care and attention. Sharing this stuff keeps it simple. + s" interpreter-flags" hex-variable-use-outer + s" main-input-buffer" hex-variable-use-outer + ~ After this, we can return control to the regularly-scheduled + ~ "variable", which will do the "create" and all that. That stuff isn't + ~ colon's responsibility, so it isn't our responsibility, it'll happen + ~ regardless. + + ~ Notably, we do NOT share transformation-state. There are at least a + ~ hundred places where it would need to be carefully swapped, and we + ~ already have quite enough of that kind of brittleness in the log-load + ~ transform. Plus, there's no obvious way to do a real push/pop notion for + ~ it, so we wouldn't get arbitrary nesting of transforms anyway. By + ~ letting the code inside the hex transform have its own, separate copy of + ~ transformation-state, we avoid that problem entirely, and it's still not + ~ hard to access the "other" one when circumstances require. + + ~ Now we close out colon's responsibilities by switching to compile + ~ mode. We return from colon after this. The hex transform will continue + ~ by processing the source words that form the regular body of "variable", + ~ eventually hitting the matching semicolon. Our friendly tampering is + ~ now complete! + ' ] entry-to-execution-token execute + exit + } if + + ~ Now we want to override s". As usual, that's the single most annoying + ~ string to quote, so we cheat. + dup ' s" entry-to-name stringcmp 0 = { + ~ Create the word header. It's a normal docol word, so that much is + ~ simple. + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ This time around we would really rather just always use the alternate, + ~ which already untangles the layered nonsense. So we have the payload + ~ call the alternate directly, then exit. We could come up with a way to + ~ then skip forward in the code under transformation, but that would be + ~ complex, and it's unnecessary: We let it keep running, outputting the + ~ usual body of s", which we know will never be reached. + ' hex-string-alternate entry-to-execution-token , + s" exit" find entry-to-execution-token , + + ~ As before, finish up colon's responsibilities, then return control to + ~ the code under transformation. + ' ] entry-to-execution-token execute + exit + } if + + ~ Same deal for .". Hey, we're getting good at this! + dup ' ." entry-to-name stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ' hex-dot-string-alternate entry-to-execution-token , + s" exit" find entry-to-execution-token , + + ' ] entry-to-execution-token execute + exit + } if + + ~ We want to suppress the behavior of relink-main-input-buffer-to-stdin + ~ entirely. Happily, that's easy. We need to do this because otherwise the + ~ transformed code will mess with our outer interpreter! + dup s" relink-main-input-buffer-to-stdin" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ Return before doing anything. + s" exit" find entry-to-execution-token , + + ' ] entry-to-execution-token execute + exit + } if + + ~ We are entirely replacing sys-write with our own version. It's an + ~ assembly word, and we're replacing it with a Forth word, so there's some + ~ matching code in the ;asm alternate that makes sure to not mess that up. + dup s" sys-write" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ' hex-sys-write-replacement entry-to-execution-token , + s" exit" find entry-to-execution-token , + + ' ] entry-to-execution-token execute + exit + } if + + ~ Now we have a bunch of patches that keep track of output metadata. These + ~ are all Forth words, nothing too complicated about the actual patching. + dup s" reset-labels" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ This is only ever called in one place, the end of a failed iteration + ~ of label-loop. We need to reinitialize all the metadata entries whenever + ~ that happens, and reset-labels is a good semantic match for that + ~ behavior, so it's a good place for the hook. + ' create-hex-output-metadata-top-of-file-entries + entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + dup s" set-label" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ (new label value, label entry pointer --) + s" 2dup" find entry-to-execution-token , + ' hex-set-label-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + + dup s" packstring" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ (output point, string pointer) + s" 2dup" find entry-to-execution-token , + ~ This one's a lot of work, so we defer to a single-purpose word. + ' hex-packstring-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ This is highly similar to packstring. + dup s" pack-raw-string" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ (output point, string pointer) + s" 2dup" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" stringlen" find entry-to-execution-token , + ~ (output point, string pointer, string length NOT including terminator) + + ~ Before we add the metadata entry, we also want to call hex-pack-trace + ~ to make sure latest-output-point gets adjusted for the string. + ~ Otherwise, we'd see magic comments in the wrong place. + s" 3roll" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" lit" find entry-to-execution-token , + 4 , + s" unroll" find entry-to-execution-token , + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, string pointer, string length NOT including terminator, + ~ output point, string length NOT including terminator) + ' hex-pack-trace entry-to-execution-token , + + ~ (output point, string pointer, string length including terminator) + s" swap" find entry-to-execution-token , + ' hex-output-metadata-entry-type-raw-string-literal + entry-to-execution-token , + s" swap" find entry-to-execution-token , + ' add-hex-output-metadata-entry entry-to-execution-token , + ~ (output point, string pointer) + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + + dup s" pack8" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 1 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ Extremely similar to the pack8 patch. + dup s" pack16" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 2 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ Extremely similar to the pack8 patch. + dup s" pack32" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 4 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ Extremely similar to the pack8 patch. + dup s" pack64" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 8 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ If no special case matches, we fall back to just being a regular colon. + ~ We already read the word name above, so we have to do the rest of the + ~ steps ourselves as well. + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + ' ] entry-to-execution-token execute + ; + + +~ This word gets installed as a trap at the beginning of every Forth word, +~ so that it can examine the control stack and produce kinds of metadata that +~ require information that only exists at runtime. See +~ hex-semicolon-alterante, below, for details of how it's installed. +~ +~ It is worth noting that hex-trap can coexist with the more-targeted traps +~ installed by hex-colon-alternate, above. It runs before them, because +~ hex-colon-alternate prepends its stuff first and then +~ hex-semicolon-alternate slides that all forward to prepend the call to +~ hex-trace. +~ +~ TODO this probably doesn't serve a purpose in the end, and should go away, +~ but the actual stack-walking code is useful and should be kept until it's +~ been refactored into something worth keeping. +: hex-trace + exit + ~ value@ here @ swap 0 hex-output-metadata-entry-type-line-comment + ~ add-hex-output-metadata-entry + newline + ~ This stack-walking code is modeled off the code in list-callers, in + ~ language/dynamic/dynamic.e. + ~ + + ~ This is the bit of the hex transform where all the memory-management + ~ assumptions are in play at once, so, in understanding it, it's probably + ~ a good idea to skim back over the background described under "hex + ~ transform implementation", above, and make sure it's fresh in your mind. + ~ + ~ It's important to notice that, as we walk it, the values of "here" and + ~ "latest" reflect the log and dictionary of the code being transformed, ie. + ~ they are the ones in the output buffer, not the log and dictionary of the + ~ outer program. Therefore, we can use containing-entry to find the entry + ~ headers for words inside the transform, and if we want to look at words + ~ outside the transform we can wrap containing-entry in + ~ swap-transform-variables. We can't use is-in-log, though, because the + ~ label-loop buffer is inside the output buffer, which is inside the outer + ~ log, so it doesn't make the distinctions we need it to. + ~ + ~ Every word inside the transform will have hex-transform-one exactly once + ~ in its call chain, so we walk the control stack only up to that point. + control@ + { ~ First, check to make sure we haven't run off the bottom of the control + ~ stack. Remember, the control stack is an array of pointers, so this is a + ~ simple bounds check. + dup r0 @ > + + ~ If it is, we also want to look at what it points to. + dup { + ~ Dereference the pointer we've been iterating (... we're actually + ~ looking at a pointer to a pointer ...), and check that it's not inside + ~ hex-transform-one's body. + drop dup @ + + ~ The inner dictionary is inside the outer log, so we'll get an entry + ~ header regardless of which dictionary we consider, but it may not be + ~ the one we care about. If we want to get the correct entry pointer, we + ~ have to make sure we're looking at the outer dictionary. + swap-transform-variables + + ~ Check what entry the control pointer is in. + containing-entry + + ~ Get the entry for hex-transform-one to compare against. This would + ~ be a forward reference, so we need to look it up at runtime. + s" hex-transform-one" find + + ~ Now switch back. + swap-transform-variables + + ~ If they're equal, we want to stop the loop. + != + } if } + { dup @ + + ~ TODO this isn't in quine.asm, so if we keep this code at all, that needs + ~ to be dealt with + ~ symbolize-pointer space + + ~ Iterate to the next pointer in the control stack. It's an array of + ~ pointers, so this is just arithmetic. + 8 + } while + drop ; + + +~ We want to trace every call to a Forth word, for use in generating +~ metadata. To do this, we want to add a prefix trap to the calls, but we +~ can't put the logic in hex-colon-alternate because we don't know which +~ words are Forth words and which are assembly words until we see the +~ semicolon. +~ +~ So, we do it here in hex-semicolon-alternate. The word body has already +~ been compiled at this point, so we slide the whole body forward to make +~ room. This is explicitly allowed by our compilation model; you may be +~ aware that it's also how high-level flow control is implemented. +~ +~ You might find it useful to compare this code to the implementations of +~ high-level flow-control utilities in language/static/log-load.e; it operates +~ under a very similar set of constraints, except that fortunately we don't +~ have the nightmare multi-dictionary situation that the log-load transform +~ does. +: hex-semicolon-alternate + latest @ entry-to-execution-token 8 + + dup dup dup + ~ (start, start, start, start) + + ~ The actual body of the trap is just a single word long (see below). If + ~ that ever changes, make sure to keep the amount we slide by in sync with + ~ it. + 8 + swap ~ TODO change number of words + ~ (start, start, adjusted start, start) + + here @ swap - + ~ (start, start, adjusted start, length) + + memmove + ~ (start) + + ~ We're going to use comma to append compiled code, so let's swap out the + ~ value of "here" to point to the space we just opened up. + here @ swap here ! + ~ (old "here") + + ~ This applies to every single word terminated with semicolon, which is + ~ all the Forth words that are created directly rather than with "variable" + ~ or some similar high-level facility. Because we also can't have forward + ~ references, that means we can't assume we'll have any available words in + ~ the transformed code to call, at all. So, the only thing we can usefully + ~ have the trap do is call a word that's defined as part of the transform. + ~ + ~ Fortunately, we do get to assume there will be a normal entry header in + ~ place for the word we're trapping. So we don't need to scrounge up any + ~ runtime data for the trap's benefit; the trap will be able to get what it + ~ needs by inspecting the control stack and the log. + ' hex-trace entry-to-execution-token , + + ~ We're done compiling the trap's contents, so swap "here" back. Again, + ~ keep this in sync with the length of the trap. + 8 + here ! + + ~ Now we do the regular semicolon stuff. + [ ' ; entry-to-execution-token , ] + ; make-immediate + + +: hex-semicolon-assembly-alternate + latest @ entry-to-name + dup s" sys-write" stringcmp 0 = { + ~ As detailed in hex-colon-alternate, above, sys-write is implemented in + ~ assembly but we replace it with Forth. This logic here collaborates with + ~ the logic there to make that work. + ~ + ~ The transformed code will still have compiled some assembly, though it + ~ won't be reached and would crash, so we need to fix alignment before we + ~ call semicolon. + drop + here @ 8 packalign here ! + [ ' ; entry-to-execution-token , ] + exit + } if + drop + + ~ If no special case matches, we fall back to the regular behavior. + [ ' ;asm entry-to-execution-token , ] + ; make-immediate + + +~ Because docol requires it, we provide a special mini-version of the label +~ system. We only do L@' and L!', because that's all we need. Unlike with the +~ label transform, these are NOT real labels; they're restricted similarly to +~ how they are for the log-load transform. +~ +~ Per the precedence rules in hex-transform-one, this version will apply to +~ all invocations, regardless of compile mode vs. immediate execution. +~ However, its own logic defers to the inner label system when that exists. +: hex-L@'-alternate + ~ If there's an inner copy of L@' defined, defer to it. + s" L@'" find dup { + entry-to-execution-token execute + exit + } { drop } if-else + + word dropstring + transformation-state transformation-state-label-scratch @ + ; make-immediate + +: hex-L!'-alternate + ~ If there's an inner copy of L!' defined, defer to it. + s" L!'" find dup { + entry-to-execution-token execute + exit + } { drop } if-else + + word dropstring + transformation-state transformation-state-label-scratch ! + ; make-immediate + + +~ The code we're compiling may try to exit when it's done. We want to return +~ to our caller instead; we turn that into an nop. This isn't quite correct, +~ but it will work as long as the inner code doesn't try to do anything else +~ after. +: hex-bye-alternate ; + + +~ Okay, now here's an interesting one. We need to provide additional +~ behavior for "allocate", but only when it is called directly from the body +~ of label-loop. That condition of being in the body is only testable +~ immediately, though "allocate" is not an immediate word and the effect of it +~ needs to happen later. This is crucial functionality that we can't work +~ without. So, we use a replacement and an alternate that work in tandem. +~ +~ First, we define the replacement... +~ +~ (size -- pointer) +: hex-allocate-replacement + dup allocate swap + ~ (result pointer, size) + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-length ! + ~ (result pointer) + + dup + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-start ! + ~ (result pointer) + + create-hex-output-metadata-top-of-file-entries ; + +~ ... then, we define the alternate. +~ +~ The alternate is flagged as immediate, which means hex-transform-one will +~ treat it as always having the highest priority. It checks what mode we're +~ in; if we're immediate, it runs the inner "allocate" if it exists or the +~ outer one if not. If we're compiling, it checks if we're in the body of +~ label-loop and compiles an execution token for the replacement if so, or the +~ inner "allocate" if not. +~ +~ If that was confusing: The point is, by having the immediate effect be +~ compilation, we get to have it both ways. +: hex-allocate-alternate + interpreter-flags @ 0x01 & { + ~ Compile mode. + latest @ entry-to-name dup s" label-loop" stringcmp 0 = { + ~ In label-loop. + drop + ' hex-allocate-replacement entry-to-execution-token , + } { + ~ Not in label-loop. + drop + s" allocate" find entry-to-execution-token , + } if-else + } { + ~ Immediate mode. + s" allocate" find + dup { entry-to-execution-token execute } { drop allocate } if-else + } if-else ; make-immediate + + +~ In order to handle code that slides compiled code around, most notably the +~ high-level flow-control words, we trap memcopy and memmove. These are +~ assembly words, so trapping them with hex-colon-alternate is inconvenient; +~ instead we patch their callers. This is like the "allocate" trap, but +~ simpler. There's no special logic needed here, we just unconditionally +~ install the trap. +~ +~ This word is responsible for processing the hook. For code running +~ directly under the hex transform, it's installed by hex-memcopy-alternate +~ and hex-memmove-alternate, immediately below. For code running in a nested +~ label transform, see hex-label-word-replacement, further down. Note +~ carefully that when it's in a nested transform, the hook only runs in +~ immediate mode; running it in compile mode would affect the program being +~ compiled. +~ +~ It is worth noting that, as of the time this code was written, there is +~ never actually any memory sliding of compiled code that occurs outside of a +~ nested transform. This aligns with intuition, since sliding is really only +~ done in the high-level flow-control words. However, should it happen in the +~ future, we still want it to work, so it's implemented. +~ +~ The actual metadata handling is done by hex-memory-slide-trace, which is +~ above, near the other words that trace memory operations. We let the +~ replacement handle preserving the parameters so that the trace doesn't need +~ to, since that would be a difference between it and the other words similar +~ to it. +~ +~ (source, destination, length -- source, destination, length) +: hex-memory-slide-replacement + 2 pick 2 pick 2 pick hex-memory-slide-trace ; + +~ These two alternates are responsible for installing +~ hex-memory-slide-replacement, immediately above, in invocations of memcopy +~ and memmove that occur directly under the hex transform. For invocations +~ that occur in nested transforms, see hex-label-word-replacement, further +~ down. +: hex-memcopy-alternate + interpreter-flags @ 0x01 & { + ' hex-memory-slide-replacement entry-to-execution-token , + s" memcopy" find entry-to-execution-token , + } { + hex-memory-slide-replacement + s" memcopy" find entry-to-execution-token execute + } if-else ; make-immediate +: hex-memmove-alternate + interpreter-flags @ 0x01 & { + ' hex-memory-slide-replacement entry-to-execution-token , + s" memmove" find entry-to-execution-token , + } { + hex-memory-slide-replacement + s" memmove" find entry-to-execution-token execute + } if-else ; make-immediate + + +~ Similar to how we handle "allocate" as a replacement which is installed by +~ an alternate, we do the same for tilde, but for a different reason. The +~ semantics of ordinary, non-transformed tilde skip over comment text while +~ compiling, and discard it. We need to do processing of that text later, when +~ the comment's position would be reached in running the word it's part of, so +~ the alternate compiles it appropriately. +~ +~ Importantly, the replacement is only used for comments that have a special +~ comment syntax unique to the hex transform, as described in more detail in +~ the alternate, below. If it were used for all comments, it would interfere +~ with the distance of branches, which could get quite complex to work around. +~ It is the responsibility of words that use the hex-transform comment syntax +~ to avoid placing such comments within the scope of a branch. This applies +~ only to explicit, precomputed branches using the words "branch" and +~ "branch0". Fortunately, implicit branches that are part of high-level +~ flow-control words such as "if" and "while" will work fine, since the +~ substitution occurs before the flow control words start sliding code around, +~ and it updates "here" appropriately. +~ +~ Because hex-tilde-replacement is called in various situations during +~ various phases of compilation and interpreting, it can't take responsibility +~ for knowing how the string pointer it's given is allocated. It assumes the +~ string pointer will be valid indefinitely; it's the caller's responsibility +~ to make sure of that. +~ +~ (has non-space this line, string pointer --) +: hex-tilde-replacement + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point @ + swap + ~ (has non-space this line, data start, string pointer) + + ~ If the output wouldn't go in the label-loop buffer, don't do any of + ~ this. + ~ + ~ That may seem spurious, but remember, the same assembly instructions + ~ are used for compiling the final binary and defining words within the + ~ compiler. In particular, "variable" will hit this, and there are surely + ~ others. + over is-in-label-loop-buffer not { 3 ndrop exit } if + + ~ Copy the first space-separated word of the comment body into scratch + ~ space to see if it's a special instruction. To minimize interference with + ~ the program under transformation, we use the outer log's scratch space + ~ rather than the inner one's. + swap-transform-variables + dup + here @ + ~ (... source pointer, destination pointer) + { over 8@ dup 0x20 != && } { + swap unpack8 swap 3unroll pack8 + } while + 0 pack8 drop drop + + here @ + swap-transform-variables + + ~ (has non-space this line, data start, string pointer, + ~ first word string pointer) + dup read-integer 0 = { + ~ (has non-space, data start, string pointer, first word string pointer, + ~ data length) + 3unroll stringlen 1+ + + ~ (has non-space, data start, data length, adjusted string pointer) + 4 roll drop + 1 swap + ~ (data start, data length, is suffix, adjusted string pointer) + } { + drop 0 swap + ~ (has non-space, data start, data length, string pointer) + 4 roll swap + ~ (data start, data length, is suffix, string pointer) + } if-else + ~ (data start, data length, is suffix, adjusted string pointer) + + ~ Now look for instruction keywords. These keywords are expected to be the + ~ entire line, except that a length field can come before them. + dup s" adjust-length" stringcmp 0 = { + ~ Modify the most recent comment entry by adjusting its length. + drop drop swap drop adjust-latest-comment-metadata-entry-length + exit + } if + dup s" adjust-start" stringcmp 0 = { + ~ Modify the most recent output-producing entry by adjusting its start. + drop drop swap drop adjust-latest-output-producing-metadata-entry-start + exit + } if + dup s" set-output-point" stringcmp 0 = { + ~ Override the latest output point. + drop drop swap drop set-latest-output-point + exit + } if + dup s" adjust-output-point" stringcmp 0 = { + ~ Modify the latest output point. + drop drop swap drop adjust-latest-output-point + exit + } if + + dup s" data-adjust-length" stringcmp 0 = { + ~ Modify the most recent comment entry by adjusting its length, also + ~ using data from the most recent data entry. + drop drop swap drop data-adjust-latest-comment-metadata-entry-length + exit + } if + dup s" data-adjust-start" stringcmp 0 = { + ~ Modify the most recent output-producing entry by adjusting its start, + ~ also using data from the most recent data entry. + drop drop swap drop + data-adjust-latest-output-producing-metadata-entry-start + exit + } if + dup s" data-set-output-point" stringcmp 0 = { + ~ Override the latest output point, also using data from the most recent + ~ data entry. + drop drop swap drop data-set-latest-output-point + exit + } if + dup s" data-adjust-output-point" stringcmp 0 = { + ~ Modify the latest output point, also using data from the most recent + ~ data entry. + drop drop swap drop data-adjust-latest-output-point + exit + } if + + dup s" suppress" stringcmp 0 = { + ~ Suppress the next N entries, or adjust the remaining count of entries + ~ to suppress. + drop drop swap drop adjust-hex-output-suppression-count + exit + } if + + dup s" delete-first-comment-at-output-point" stringcmp 0 = { + 4 ndrop delete-first-comment-metadata-entry-at-output-point + exit + } if + + dup s" delete-last-comment-at-output-point" stringcmp 0 = { + 4 ndrop delete-latest-comment-metadata-entry-at-output-point + exit + } if + + dup s" fresh-line" stringcmp 0 = { + ~ Create a new fresh-line entry. + drop drop hex-output-metadata-entry-type-fresh-line 0 + add-hex-output-metadata-entry + exit + } if + + dup s" blank-line" stringcmp 0 = { + ~ Create a new blank-line entry. + drop drop hex-output-metadata-entry-type-blank-line 0 + add-hex-output-metadata-entry + exit + } if + + dup s" indent" stringcmp 0 = { + ~ Create a new indent entry with a positive indentation delta. + drop drop hex-output-metadata-entry-type-indent 2 + add-hex-output-metadata-entry + exit + } if + + dup s" deindent" stringcmp 0 = { + ~ Create a new indent entry with a negative indentation delta. + drop drop hex-output-metadata-entry-type-indent -2 + add-hex-output-metadata-entry + exit + } if + + ~ Now we have some commands for the various -provide-subitem- variants. + ~ Notice with all of these that we intentionally read one stack level deeper + ~ than anything of ours, which will be a value provided by the code the + ~ magic comment is embedded in. + dup s" provide-decimal" stringcmp 0 = { + ~ Create a new "push subitem decimal" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-decimal swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex" stringcmp 0 = { + ~ Create a new "push subitem hex" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex8" stringcmp 0 = { + ~ Create a new "push subitem hex8" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex8 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex16" stringcmp 0 = { + ~ Create a new "push subitem hex16" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex16 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex32" stringcmp 0 = { + ~ Create a new "push subitem hex32" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex32 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex64" stringcmp 0 = { + ~ Create a new "push subitem hex64" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex64 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-string" stringcmp 0 = { + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-string swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-string-copy" stringcmp 0 = { + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-string swap + swap-transform-variables here @ swap-transform-variables dup 3unroll + ~ (copy, original, copy) + over stringlen 1+ memcopy + swap-transform-variables allocate-string swap-transform-variables + add-hex-output-metadata-entry + exit + } if + dup s" provide-keyword" stringcmp 0 = { + ~ Create a new "push subitem string" entry given a keyword pointer. + drop drop + 2 pick execution-token-to-entry entry-to-name + hex-output-metadata-entry-type-push-subitem-string swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-data" stringcmp 0 = { + ~ Create a new "push subitem data" entry. + drop drop + 2 pick hex-output-metadata-entry-type-saved-data swap + add-hex-output-metadata-entry + exit + } if + + ~ Next are the subitem stack manipulation commands. These deal with the + ~ subitem entry stack, just as the provide-* commands do, but at this phase + ~ of processing the effect is just to create an entry in the entry array, + ~ not to do any actual stack manipulation, so their implementations are + ~ quite simple. + dup s" drop-subitem" stringcmp 0 = { + ~ Create a new "drop subitem" entry. + drop drop hex-output-metadata-entry-type-drop-subitem 0 + add-hex-output-metadata-entry + exit + } if + dup s" swap-subitems" stringcmp 0 = { + ~ Create a new "swap subitem" entry. + drop drop hex-output-metadata-entry-type-swap-subitems 0 + add-hex-output-metadata-entry + exit + } if + dup s" roll-subitems" stringcmp 0 = { + ~ Create a new "roll subitem" entry. The parameter goes in the content + ~ field, and the length is always zero. + drop drop 0 swap hex-output-metadata-entry-type-roll-subitems swap + add-hex-output-metadata-entry + exit + } if + + ~ If it's flagged as a suffix by the logic above, create a new + ~ suffix-comment entry. + swap { + hex-output-metadata-entry-type-suffix-comment swap + add-hex-output-metadata-entry + exit + } if + + ~ Create a new line-comment entry. + hex-output-metadata-entry-type-line-comment swap + add-hex-output-metadata-entry ; + + +~ We need to define a few helpers for use in +~ hex-read-magic-comment-introducer, below. The string pointers these return +~ are allocated in the manner described there. +~ +~ (first key -- body-string-pointer) +: hex-read-nonempty-comment-body + ~ This is the rare case in the transforms where we want to get into the + ~ nitty-gritty of lexing. Normally we rely on the upstream implementations, + ~ even when we have to go out of our way to do so, because we don't want to + ~ have to update the transforms every time there's a new syntax feature. + ~ Here, however, we've got a syntax that only has meaning to the transform, + ~ so there's no choice. + swap-transform-variables here @ swap-transform-variables + + ~ This little loop is a modified version of the original tilde loop. + swap { dup dup 0x0a != && } { pack8 key } while drop + + 0 pack8 + 8 packalign + + drop + swap-transform-variables here @ swap-transform-variables ; + +: hex-read-empty-comment-body + swap-transform-variables here @ swap-transform-variables + + 0 pack8 + 8 packalign + + drop + swap-transform-variables here @ swap-transform-variables ; + + +~ This is called from a tilde alternate (such as hex-tilde-alternate, but +~ there are several). Its purpose is to do the lexical analysis of the +~ sequence that introduces a magic comment; it assumes that the leading tilde +~ character has just been consumed from the main input, leaving the separating +~ space as the next character ready to be read. +~ +~ Recall that the delimiter for a regular comment is "~ " (the trailing +~ space is part of it for this purpose). The delimiter for a magic comment is +~ "~ : ". A regular comment may also have a linefeed instead of a space, +~ indicating that it's empty; magic comments likewise can be empty, by ending +~ the line immediately after the colon. +~ +~ This word does the necessary reading, then leaves the input pointing at +~ the body of the comment and returns a value indicating what type of comment +~ this is. A result code of 0 indicates it's a regular comment and the input +~ now points immediately after its ending delimiter; that is, to the start of +~ the next line of text. A value of 1 indicates it's a magic comment with +~ non-zero length and the input points immediately after the delimiter. A +~ value of 2 indicates it's a magic comment with zero length, and the input +~ again points to the start of the next line. +~ +~ Our caller will want to do things with the comment body, so we also return +~ a pointer to a string in temporary storage, for use in further processing. +~ This temporary storage is taken from the "real" log, outside the transform's +~ scope. It's not allocated, merely using the space right after "here", +~ because the caller may or may not wish to allocate it for the long term, and +~ may prefer that its long-term location be elsewhere. +~ +~ Some of the various magic-comment syntaxes care about spacing within the +~ comment body, so it's important to notice that only the first space after +~ the colon is consumed. Any subsequent spaces are part of the body. +~ +~ (-- body string pointer, result code) +: hex-read-magic-comment-introducer + ~ The original code goes byte-by-byte, checks that the value is nonzero + ~ and not equal to 0x0a (linefeed), and exits when either property fails. + ~ We want to do something different based on the very first characters of + ~ the comment body. So, we unroll the first few iterations of the loop so we + ~ can do that test before we fall back to the normal behavior. + ~ + ~ Specifically, we want to recognize a colon (0x3a) with a space (0x20) + ~ immediately after it. Since the interpeter peeked at the space delimiter, + ~ but didn't consume it, we also need to check for a space before the colon, + ~ for a total sequence of three bytes we need to match. We can't just skip + ~ over the space with "consume", because it might also be a linefeed, which + ~ would satisfy the exit criterion. We need to properly match it. + ~ + ~ We also recognize a colon followed immediately by a linefeed, as + ~ denoting an empty comment. + key dup dup 0x0a != && { + ~ If we got here, the first byte was not 0 or 0x0a. Now we check if it's + ~ colon. + 0x20 = { + ~ The first byte was 0x20. Now check the second. + key dup dup 0x0a != && { + dup 0x3a = { + ~ The second byte was 0x3a. Now check the third. + drop key dup { + ~ The third byte is not 0. + dup 0x20 = { + ~ We have a magic comment with a nonempty body. We must save + ~ the rest of it so we can return it. + drop key hex-read-nonempty-comment-body 1 + } { + ~ The third byte is not 0 or 0x20. + dup 0x0a = { + ~ We have a magic comment with an empty body, ending at a + ~ linefeed. As with nonempty ones, we prepare a temporary + ~ string to return. + drop hex-read-empty-comment-body 2 + } { + ~ The third byte was not 0, 0x0a, or 0x20. We got a space, + ~ a colon, and something else. So our special test failed, but + ~ the exit condition isn't met. So we're done unrolling. + hex-read-nonempty-comment-body 0 + } if-else + } if-else + } { + ~ We got a colon and a zero. This is a magic comment with an + ~ empty body, ending at the end of the file. + drop hex-read-empty-comment-body 2 + } if-else + } { + ~ Again, the special test failed but the exit condition isn't met. + hex-read-nonempty-comment-body 0 + } if-else + } { + ~ Again, the exit condition is met. + drop hex-read-empty-comment-body 0 + } if-else + } { + ~ Once more, the special test failed but the exit condition isn't met. + hex-read-nonempty-comment-body 0 + } if-else + } { + ~ For the last time, the exit condition is met. + drop hex-read-empty-comment-body 0 + } if-else ; + + + +~ The tilde alternate is a very important word for the hex transform; it has +~ the task of hooking comment processing to detect a special comment syntax +~ which can be used by words that generate binary output, to define comments +~ which will appear as part of the hex-dump version of that output, but which +~ will be ignored in normal execution. +~ +~ This mechanism allows us, for example, to avoid putting detailed knowledge +~ of the amd64 Evocation-assembly instructions in the hex transform; instead +~ all the details are kept in one place, the authoritative implementations of +~ those instructions. This will substantially improve the maintainability of +~ the code, especially when adding new architectures. +~ +~ This word hex-tilde-alternate only applies to code that is running +~ directly within the hex transform. When an inner transform runs within the +~ hex transform, the inner transform is responsible for lexical processing, so +~ this word never gets invoked. There is an additional variant word +~ hex-*-tilde-alternate for each inner transform that the hex transform +~ supports, responsible for conducting the analogous task within the rules of +~ that inner transform. +: hex-tilde-alternate + ~ The original tilde is already an immediate word, so we can take over + ~ those responsibilities directly without needing to do any extra work to + ~ check the mode we're in or anything like that. + hex-read-magic-comment-introducer + ~ (body string pointer, result code) + + { + ~ It's a magic comment, which may or may not be empty. We want to either + ~ compile or execute a call to hex-tilde-replacement. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. + ~ + ~ Fortunately, we can pack the string directly into the output buffer, + ~ so we don't need to mess around with accumulate-string. + s" lit" find entry-to-execution-token , + has-non-space-this-input-line@ , + + s" litstring" find entry-to-execution-token , + here @ + swap packstring + 8 packalign + here ! + + ' hex-tilde-replacement entry-to-execution-token , + } { + ~ We're in interpret mode. + has-non-space-this-input-line@ swap + hex-tilde-replacement + } if-else + } { + ~ If it's a regular comment, we just ignore it. + drop + } if-else + + ~ Regardless of what path we took, we just consumed a newline, so make + ~ note of the fact. + 0 has-non-space-this-input-line! + ; make-immediate + + +~ This word runs whenever the label transform, running inside the hex +~ transform, encounters a tilde. It completely replaces the normal invocation +~ of tilde, just as hex-tilde-alternate does. It has the same responsibilities +~ around magic comments as hex-tilde-alternate, but for code which is +~ lexically processed by label-transform-one rather than by hex-transform-one. +~ +~ The actions it takes upon finding various sorts of comments differ from +~ hex-tilde-alternate, because the behavior of the label transform is +~ different from the behavior of the hex transform. +~ +~ This is installed by hex-label-word-replacement, bypassing the label +~ transform's normal precedence rules, so there's no need for it to be +~ immediate. +~ +~ Installing this word is the most significant change the hex transform +~ makes to the behavior of the label transform. +: hex-label-tilde-alternate + hex-read-magic-comment-introducer + ~ (body string pointer, result code) + + { + ~ It's a magic comment, which may or may not be empty. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. We ignore magic comments in compile mode, + ~ because they shouldn't become part of the program being compiled. + drop + } { + ~ We're in interpret mode. We run the magic comment immediately. + has-non-space-this-input-line@ swap + swap-transform-variables allocate-string swap-transform-variables + hex-tilde-replacement + } if-else + } { + ~ If it's a regular comment, we just ignore it. + drop + } if-else + + ~ Regardless of what path we took, we just consumed a newline, so make + ~ note of the fact. + 0 has-non-space-this-input-line! ; + + +~ This word runs whenever the log-load transform, running inside the hex +~ transform, encounters a tilde. It completely replaces the normal invocation +~ of tilde, just as hex-tilde-alternate does. It has the same responsibilities +~ around magic comments as hex-tilde-alternate, but for code which is +~ lexically processed by log-load-transform-one rather than by +~ hex-transform-one. +~ +~ The actions it takes upon finding various sorts of comments differ from +~ hex-tilde-alternate, because the behavior of the log-load transform is +~ different from the behavior of the hex transform. +~ +~ This is installed by hex-log-load-word-replacement, bypassing the log-load +~ transform's normal precedence rules, so there's no need for it to be +~ immediate. +~ +~ Installing this word is the most significant change the hex transform +~ makes to the behavior of the log-load transform. +: hex-log-load-tilde-alternate + hex-read-magic-comment-introducer + ~ (body string pointer, result code) + + { + ~ It's a magic comment, which may or may not be empty. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. We ignore magic comments in compile mode, + ~ because they shouldn't become part of the program being compiled. + drop + } { + ~ We're in interpret mode. We run the magic comment immediately. + has-non-space-this-input-line@ swap + swap-transform-variables allocate-string swap-transform-variables + hex-tilde-replacement + } if-else + } { + ~ If it's a regular comment, we just ignore it. + drop + } if-else + + ~ Regardless of what path we took, we just consumed a newline, so make + ~ note of the fact. + 0 has-non-space-this-input-line! ; + + +~ This input helper is a very unusual thing: It's used by hex-transform-one, +~ hex-label-word-replacement, and hex-log-load-word-replacement to skip the +~ space between words. That's necessary because we need to keep track of +~ whether we've had any non-blank stuff on each line yet, so that the tilde +~ replacement can figure out certain cases where a magic comment needs to be a +~ suffix comment rather than a line comment. +: hex-skip-space + { peek dup is-space } + { consume + ~ This will set the flag once for each newline, if we have multiple + ~ consecutive ones or something like that, but that's harmless. + 0x0a = { 0 has-non-space-this-input-line! } if + } while drop ; + + + +~ This word is installed into label-transform-one by the hex-word-alternate, +~ when the label transform runs inside the hex transform. It has the job of +~ performing substantive changes to the label transform's behavior, as +~ required by the hex transform. +~ +~ The most important changes to the base language that this word makes are +~ to call hex-label-tilde-alternate any time a tilde is encountered as a word, +~ and to call hex-skip-space before reading a word. +~ +~ This word is also responsible for invoking hex-memory-slide-replacement +~ when memcopy or memmove are encountered in immediate mode. Note that this +~ really pushes right up against the limit of what it's possible for a +~ transform to do without altering the compilation's output; invoking the +~ replacement in compile mode would do so. +: hex-label-word-replacement + hex-skip-space + word + + value@ + dup s" ~" stringcmp 0 = { + ~ We won't be going back to label-transform-one; clear away its state. + drop dropstring + + hex-label-tilde-alternate + + ~ Return directly to label-transform, faking the "not done" return value + ~ from label-transform-one. + 0 + 2 nexit + } if + dup s" memcopy" stringcmp 0 = { + interpreter-flags @ 0x01 & not { + drop hex-memory-slide-replacement exit + ~ Fall through, returning control to label-transform-one. + } if + } if + dup s" memmove" stringcmp 0 = { + interpreter-flags @ 0x01 & not { + drop hex-memory-slide-replacement exit + ~ Fall through, returning control to label-transform-one. + } if + } if + drop ; + + +~ This word is installed into log-load-transform-one by the +~ hex-word-alternate, when the log-load transform runs inside the hex +~ transform. It has the job of performing substantive changes to the log-load +~ transform's behavior, as required by the hex transform. +~ +~ The most important changes to the base language that this word makes are +~ to call hex-log-load-tilde-alternate any time a tilde is encountered as a +~ word, and to call hex-skip-space before reading a word. +: hex-log-load-word-replacement + hex-skip-space + word + + value@ + dup s" ~" stringcmp 0 = { + ~ We won't be going back to log-load-transform-one; clear away its state. + drop dropstring + + hex-log-load-tilde-alternate + + ~ Return directly to log-load-transform, faking the "not done" return + ~ value from log-load-transform-one. + 0 + 2 nexit + } if + drop ; + + +~ Just as hex-allocate-alternate has the job of installing +~ hex-allocate-replacement in only one single spot, so hex-word-alternate has +~ the job of installing hex-label-word-replacement. It gets installed when +~ "word" is called from lexically within label-transform-one, and at no other +~ time. +~ +~ Notice how the job of each transform's inner bits can be thought of as +~ calling "word" and doing something with the result, with all the lexical +~ processing delegated to "word". This makes "word" a good place to install a +~ modification to the transform's behavior. +~ +~ Its structure is highly similar to that of hex-allocate-alternate. +: hex-word-alternate + interpreter-flags @ 0x01 & { + ~ Compile mode. + latest @ entry-to-name + + dup s" label-transform-one" stringcmp 0 = { + drop + ' hex-label-word-replacement entry-to-execution-token , + exit + } if + + dup s" log-load-transform-one" stringcmp 0 = { + drop + ' hex-log-load-word-replacement entry-to-execution-token , + exit + } if + + ~ Not in a word we install stuff into. + drop + s" word" find entry-to-execution-token , + } { + ~ Immediate mode. + s" word" find + dup { entry-to-execution-token execute } { drop allocate } if-else + } if-else ; make-immediate + + +~ This runs instead of "interpret" in code under the hex transform. The +~ proximate effect of that is to make "include" work. Note, however, that this +~ replacement only applies directly under the hex transform. It isn't a +~ sensible approach under the log-load transform at all, and under the label +~ transform it would have such strange behavior that it isn't a good idea +~ either. +: hex-interpret-replacement + ~ This is a forward reference, so we need to look it up. + s" hex-transform-one" + swap-transform-variables find swap-transform-variables + entry-to-execution-token execute + + ~ We ignore the EOF indication, on the assumption something else will + ~ detect it and return to the outer loop, the one that's ours. For example, + ~ look at "include", in language/dynamic/files.e. + drop ; + + +~ This installs hex-interpret-replacement, compiling it in compile mode and +~ executing it in immediate mode. +: hex-interpret-alternate + interpreter-flags @ 0x01 & { + ' hex-interpret-replacement entry-to-execution-token , + } { + hex-interpret-replacement + } if-else ; make-immediate + + +~ This implements the hex transform for a single word. It is directly +~ analogous to "interpret", and reading language/dynamic/interpret.e may help +~ in understanding it, though it's meant to still make sense on its own. +~ +~ The hex transform runs code immediately. Whereas most transforms alter +~ what the transformed code compiles into, the hex transform alters what it +~ outputs. It's assumed that the output is a binary file of some sort; the +~ binary is output as hexadecimal, interspersed with comments describing the +~ code that produced it, including descriptions of what was executed, along +~ with any comments from the original code. +~ +~ The hex transform's alternates take priority over words defined under +~ the transform when running immediately, but for compilation, words defined +~ under the transform take precedence. In the event that neither an alternate +~ nor an entry in the inner dictionary is found, the outer dictionary is +~ checked; otherwise it's irrelevant. +~ +~ The point of this precedence rule is that string literals, which require +~ special treatment, will be using the inner implementation by the time it +~ gets to actually generating an executable image. It's important that there +~ not be any alternates altering the generated code, only the program actually +~ being compiled. Other literal syntaxes, such as tick, don't have alternates +~ at all (the hex transform manages to be more parsimonious with alternates +~ than other transforms), and will always be using inner versions. +~ +~ The precedence rule does fail to have the desired effect for label +~ references. For these, the alternates take the unusual step of manually +~ calling the inner versions when they exist. +~ TODO think through whether the precedence rule is actually doing anything... +~ +~ It expects to be called from "hex-transform", below, which loops. +~ +~ (-- done) +: hex-transform-one + hex-skip-space + word + + ~ If no word was returned, end the transformation. + dup 0 = { drop 1 exit } if + + ~ The string is on the top of the stack, so to get a pointer to it we get + ~ the stack address. + ~ (string) + value@ + + ~ If it's anything but tilde, set the input state flag accordingly. + dup s" ~" stringcmp 0 != { 1 has-non-space-this-input-line! } if + + ~ Check whether it's one of the words we have alternates for, and look up + ~ the alternate if so. + 0 swap + ~ (name as stack string, placeholder, name pointer) + dup s" self-codeword" stringcmp 0 = { + swap drop ' hex-self-codeword-alternate swap } if + ~ It is nontrivial to construct a string with a double-quote in it. + dup ' s" entry-to-name stringcmp 0 = { + swap drop ' hex-string-alternate swap } if + dup ' ." entry-to-name stringcmp 0 = { + swap drop ' hex-dot-string-alternate swap } if + dup s" create" stringcmp 0 = { swap drop ' hex-create-alternate swap } if + dup s" :" stringcmp 0 = { swap drop ' hex-colon-alternate swap } if + dup s" ;" stringcmp 0 = { swap drop ' hex-semicolon-alternate swap } if + dup s" ;asm" stringcmp 0 = { + swap drop ' hex-semicolon-assembly-alternate swap } if + dup s" L@'" stringcmp 0 = { swap drop ' hex-L@'-alternate swap } if + dup s" L!'" stringcmp 0 = { swap drop ' hex-L!'-alternate swap } if + dup s" bye" stringcmp 0 = { swap drop ' hex-bye-alternate swap } if + dup s" allocate" stringcmp 0 = { + swap drop ' hex-allocate-alternate swap } if + dup s" memcopy" stringcmp 0 = { swap drop ' hex-memcopy-alternate swap } if + dup s" memmove" stringcmp 0 = { swap drop ' hex-memmove-alternate swap } if + dup s" word" stringcmp 0 = { swap drop ' hex-word-alternate swap } if + dup s" ~" stringcmp 0 = { swap drop ' hex-tilde-alternate swap } if + dup s" interpret" stringcmp 0 = { + swap drop ' hex-interpret-alternate swap } if + ~ (name as stack string, 0 or alternate entry pointer, name pointer) + + find + ~ (stack string, 0 or alternate entry pointer, 0 or inner entry pointer) + + interpreter-flags @ 0x01 & { + ~ We're in compile mode. An alternate immediate entry has the highest + ~ precedence; an inner entry of any kind has second-highest. + over { + ~ An alternate entry exists; check its flags. + over entry-flags@ 0x01 & { + ~ It's an immediate entry, so it has precedence, regardless of + ~ what's up with the inner entry. Execute it. + drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ The alternate is not immediate, so check if there's an inner entry. + dup { + ~ There is also an inner entry. Check its flags. + dup entry-flags@ 0x01 & { + ~ The inner entry is immediate, so it has precedence. Execute it. + swap drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ The inner entry is not immediate, so the alternate has + ~ precedence. Compile it. + ~ + ~ Watch this space closely for correctness issues, it's a rare + ~ codepath. + drop dropstring-with-result + entry-to-execution-token , + 0 exit + } if-else + } { + ~ There's no inner entry. Compile the alternate. + ~ + ~ This path, too, is rare and should get close scrutiny for + ~ correctness. + drop dropstring-with-result + entry-to-execution-token , + 0 exit + } if-else + } if-else + } { + ~ There is no alternate entry; check for an inner entry. + dup { + ~ An inner entry exists; check its flags. + dup entry-flags@ 0x01 & { + ~ It's an immediate entry. Execute it. + swap drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ It's not an immediate entry. Compile it. + swap drop dropstring-with-result + entry-to-execution-token , + 0 exit + } if-else + } if + ~ If we got here, there's no inner or alternate entry; fall through. + } if-else + } { + ~ We're in immediate mode. An alternate entry of any kind has precedence. + over { + ~ There's an alternate entry. Execute it. + drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ There's no alternate entry. Check for an inner entry. + dup { + ~ An inner entry exists. Execute it. + swap drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } if + ~ If we got here, there's no inner or alternate; fall through. + } if-else + } if-else + drop drop + ~ (stack string) + + ~ As a final fallback, we also check the outer dictionary, for immediate + ~ use only. This will allow things like assembly words to work. + value@ + swap-transform-variables + find + swap-transform-variables + dup { + ~ There's an outer entry; check the mode. + interpreter-flags @ 0x01 & { + ~ We're in compile mode; check the outer entry's flags. + dup entry-flags@ 0x01 & { + ~ It's an immediate word; execute it. + dropstring-with-result + entry-to-execution-token + execute + 0 exit + } { + ~ It's not an immediate word. Pretend it doesn't exist, and fall + ~ through. + drop + } if-else + } { + ~ We're in immediate mode. Execute the outer entry. + dropstring-with-result + entry-to-execution-token + execute + 0 exit + } if-else + } { + ~ There's no outer entry. Fall through. + drop + } if-else + ~ (stack string) + + ~ Check whether it's a number literal. + value@ read-integer 0 = { + ~ It's a number. + ~ + ~ (name as stack string, integer value) + dropstring-with-result + ~ (integer value) + + interpreter-flags @ 0x01 & { + ~ TODO this probably needs a lit alternate (!) + ' lit entry-to-execution-token , , + 0 exit + } if + + 0 exit + } if + ~ (stack string) + + ." No such word: " value@ emitstring newline dropstring 0 ; + + +~ This implements the hex transform for all words in a region given as +~ an input string. It is directly analogous to "quit", in +~ language/dynamic/interpret.e, but is more complex. +~ +~ (output metadata buffer start, output buffer start, output point, +~ input string pointer -- output buffer start, output point) +: hex-transform + main-input-buffer dup push-input-buffer + swap attach-string-to-input-buffer + ~ (output metadata buffer start, output buffer start, output point) + + ~ Save the old values of "here" and "latest", and set the initial values + ~ of the internal ones. These values need to persist across iterations, + ~ 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 other fields of + ~ transformation-state. While it might be nice to do these in some sort of + ~ logical order, it gets unreadable quickly, so we initialize them in the + ~ most convenient order given how we received our parameters. + here @ transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest ! + here ! + 0 latest ! + transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + transformation-state transformation-state-output-metadata ! + ~ Now the stack has nothing of ours on it, so client code can do its thing. + + ~ We don't have the real values yet, so we can't create the initial + ~ entries in the output metadata, but we can and should zero it out to make + ~ sure everything else operating on it finds it well-formed. + zero-hex-output-metadata + + ~ The code under the hex transform never gets a real copy of warm-start, + ~ so it doesn't have the globals "here" and so on. It wants to have the + ~ globals, but it can't, not without our help. Why aren't we helping? + ~ + ~ Oh, right, we're helping right here. We just write them into the inner + ~ log and dictionary directly, by using our outer copy of "variable". These + ~ definitions don't have to do anything special; we point them to the same + ~ addresses as the outer ones. Note though that the actual values the + ~ transformed code sees sees are the wrapped, inner ones, since we swapped + ~ the values out elsewhere. + ~ + ~ If we provided these as alternates instead, that would work for code + ~ that doesn't have a nested transform, but the inner transforms want to be + ~ able to look them up by name. + swap-transform-variables log swap-transform-variables s" log" variable + swap-transform-variables s0 swap-transform-variables s" s0" variable + swap-transform-variables r0 swap-transform-variables s" r0" variable + swap-transform-variables latest swap-transform-variables s" latest" variable + swap-transform-variables here swap-transform-variables s" here" variable + + ~ It's important that the stack has nothing of ours on it that persists + ~ across iterations, so that client code can add and remove stuff there as + ~ it sees fit. + { hex-transform-one + ~ (done) + + ~ When the loop is done, get the real values of "here" and "latest" + ~ back. The internal "here" is also the output point, and will become our + ~ return value. The internal "latest" is discarded. + { transformation-state transformation-state-output-buffer-start @ + here @ + transformation-state transformation-state-saved-here @ here ! + transformation-state transformation-state-saved-latest @ latest ! + ~ (output point) + + ~ Though we don't actually use transformation-state outside of this + ~ invocation, for tidiness we zero it out. + 0 transformation-state transformation-state-saved-here ! + 0 transformation-state transformation-state-saved-latest ! + 0 transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + + ~ Also put the input source back how it was. + main-input-buffer pop-input-buffer + + exit } if } forever ; + |