evocation/transform.e
2026-09-24 17:47:58 +03:00

6471 lines
266 KiB
Text

~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
~ ~~ 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
~ 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 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 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 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 execution.e), whose overall job is to get Evocation into a state where
~ it can freely work with dynamically-allocated data on the log whose address
~ isn't known at compile time. Therefore, necessarily, the log-load routine
~ itself cannot assume access to any scratch space; the value stack is the
~ only place it can store anything it needs, most crucially including the log
~ address.
~
~ Fortunately, it is possible for the transform's own generated code to
~ cooperate with the transformed code so that they can both share the stack,
~ as long as the log transform knows what the transformed code is doing with
~ it. Unfortunately, there's no general way to know that. We achieve it by
~ hard-coding a delta value for every single possible word, and looking up
~ that delta at transform-time, based on the word's name. Yes, that is quite a
~ thing to have to do, but it does mean we don't have to think about this
~ while writing the code we're transforming.
~
~ It's worth noticing that the delta only applies to things that happen
~ immediately. It does not apply to compiled words because they run later, and
~ it does not apply to alternates because they run too soon. Feel free to
~ contemplate how confusing it is that transformation-time is sooner than
~ "immediate".
~
~ (name pointer -- delta value)
: transform-get-stack-delta
~ From core.e.
dup s" docol" stringcmp 0 = { drop 1 exit } if
dup s" exit" stringcmp 0 = { drop 0 exit } if
dup s" swap" stringcmp 0 = { drop 0 exit } if
dup s" drop" stringcmp 0 = { drop -1 exit } if
dup s" 2drop" stringcmp 0 = { drop -2 exit } if
~ The following are deliberate omissions: roll, unroll.
dup s" 3roll" stringcmp 0 = { drop 0 exit } if
dup s" 3unroll" stringcmp 0 = { drop 0 exit } if
dup s" dup" stringcmp 0 = { drop 1 exit } if
dup s" 2dup" stringcmp 0 = { drop 2 exit } if
dup s" +" stringcmp 0 = { drop -1 exit } if
dup s" -" stringcmp 0 = { drop -1 exit } if
dup s" *" stringcmp 0 = { drop -1 exit } if
dup s" /%" stringcmp 0 = { drop 0 exit } if
dup s" 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 unix-like-syscalls.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 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 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" neg-reg64" stringcmp 0 = { drop -1 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 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 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 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 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 linux-dynamic.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 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 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 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 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 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 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 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 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 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 dynamic.e, which absolutely
~ cannot be loaded yet at the time we output docol at the very beginning of
~ 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 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
~ 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
~ 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 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 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 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 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 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 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 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
~ 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 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 implements the hex transform for a single word. It is directly
~ analogous to "interpret", and reading interpret.e may help in understanding
~ it, though it's meant to still make sense on its own.
~
~ 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
~ (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 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 ;