From 77e8ce989010fbd94080e780fb0b5cb6c10434e8 Mon Sep 17 00:00:00 2001 From: Irene Knapp Date: Mon, 28 Sep 2026 18:07:52 -0700 Subject: move all the source files into subdirectories and rename one, linux-dynamic.e to language/dynamic/linux.e. also make sure all references in comments and documentation refer to the new locations and names. this directory structure reflects code organization which had existed in Irenes' head, but was likely not obvious to other readers. now hopefully it is more discoverable. Force-Push: yes Change-Id: Icfef3eae812a50fe20202191999e68e1f7db445a --- README.txt | 79 +- amd64.e | 1382 -------- compilation/elf.e | 179 + compilation/execution.e | 593 ++++ compilation/labels.e | 296 ++ compilation/transform.e | 6512 +++++++++++++++++++++++++++++++++++ core.e | 1370 -------- dynamic.e | 559 --- elf.e | 179 - evoke.e | 44 +- execution-support.e | 111 - execution.e | 592 ---- files.e | 161 - flow-control.e | 151 - hex.e | 6 +- input.e | 289 -- inscribe-evoke.e | 38 +- inscribe-hex.e | 34 +- interpret.e | 596 ---- labels.e | 296 -- language/dynamic/dynamic.e | 560 +++ language/dynamic/files.e | 161 + language/dynamic/flow-control.e | 151 + language/dynamic/input.e | 289 ++ language/dynamic/interpret.e | 599 ++++ language/dynamic/linux.e | 359 ++ language/static/amd64.e | 1383 ++++++++ language/static/core.e | 1371 ++++++++ language/static/execution-support.e | 111 + language/static/linux.e | 153 + language/static/log-load.e | 547 +++ language/static/output.e | 252 ++ linux-dynamic.e | 359 -- linux.e | 152 - log-load.e | 542 --- output.e | 252 -- transform.e | 6500 ---------------------------------- 37 files changed, 13618 insertions(+), 13590 deletions(-) delete mode 100644 amd64.e create mode 100644 compilation/elf.e create mode 100644 compilation/execution.e create mode 100644 compilation/labels.e create mode 100644 compilation/transform.e delete mode 100644 core.e delete mode 100644 dynamic.e delete mode 100644 elf.e delete mode 100644 execution-support.e delete mode 100644 execution.e delete mode 100644 files.e delete mode 100644 flow-control.e delete mode 100644 input.e delete mode 100644 interpret.e delete mode 100644 labels.e create mode 100644 language/dynamic/dynamic.e create mode 100644 language/dynamic/files.e create mode 100644 language/dynamic/flow-control.e create mode 100644 language/dynamic/input.e create mode 100644 language/dynamic/interpret.e create mode 100644 language/dynamic/linux.e create mode 100644 language/static/amd64.e create mode 100644 language/static/core.e create mode 100644 language/static/execution-support.e create mode 100644 language/static/linux.e create mode 100644 language/static/log-load.e create mode 100644 language/static/output.e delete mode 100644 linux-dynamic.e delete mode 100644 linux.e delete mode 100644 log-load.e delete mode 100644 output.e delete mode 100644 transform.e diff --git a/README.txt b/README.txt index 55ba61b..ce7a254 100644 --- a/README.txt +++ b/README.txt @@ -129,7 +129,8 @@ lexer feature for that sort of thing. Evocation doesn't do that, because eventually fancy syntax and grammar will be implemented at a higher layer, using the experimental parsing formalism that doesn't exist yet. If you want to see where this feature would be if it were implemented in the simpler way, -you can read the definition of the word named "word", in interpret.e. +you can read the definition of the word named "word", in +language/dynamic/interpret.e. If you went to look at that and you're wondering: Yeah, Evocation's lexer really is that short and simple. Part of why it's able to be that easy is that @@ -207,45 +208,47 @@ evoke.e. It's really short, and worth a quick glance right now. It lists all the other source files and the order they get loaded in and how they're processed. - The files that do the work to make Evocation run at all are execution.e and -core.e. It's worth reading through both of them slowly. After you've read -core.e, you'll know a lot of basic words that can be used as commands within -Evocation. + The files that do the work to make Evocation run at all are +compilation/execution.e and language/static/core.e. It's worth reading through +both of them slowly. After you've read core.e, you'll know a lot of basic +words that can be used as commands within Evocation. A lot of Evocation is written in Evocation's version of assembly language. -The file amd64.e is the one that implements all the assembly instructions. -Writing a real program in assembly also requires resolving labels, which are -a special syntax that gives names to addresses. The behavior of labels is all -implemented in labels.e. - - On the assembly language front, there's also linux.e which contains assembly -words for doing things specific to the Linux operating system, such as reading -input, and there's elf.e which contains words for outputting the special file -headers that let the operating system understand that a file is an executable -program. - - In terms of the Forth-y bits, input.e and output.e are concerned with -getting text into and out of the language. The infrastructure to define words -is in dynamic.e, and the syntax for it is in interpret.e. The high-level flow -control words are in flow-control.e. Some of the features of execution.e had -to be separated out into their own file, because of details about how the -compiler works; that stuff is in execution-suport.e. +The file language/static/amd64.e is the one that implements all the assembly +instructions. Writing a real program in assembly also requires resolving +labels, which are a special syntax that gives names to addresses. The behavior +of labels is all implemented in compilation/labels.e. + + On the assembly language front, there's also language/static/linux.e which +contains assembly words for doing things specific to the Linux operating +system, such as reading input, and there's compilation/elf.e which contains +words for outputting the special file headers that let the operating system +understand that a file is an executable program. + + In terms of the Forth-y bits, language/dynamic/input.e and +language/static/output.e are concerned with getting text into and out of the +language. The infrastructure to define words is in language/dynamic/dynamic.e, +and the syntax for it is in language/dynamic/interpret.e. The high-level flow +control words are in language/dynamic/flow-control.e. Some of the features of +compilation/execution.e had to be separated out into their own file, because +of details about how the compiler works; that stuff is in +language/static/execution-suport.e. So, there's all those relatively normal compiler internals in those various files, which are all fairly self-contained... and then there's the transformation facility. This is Evocation's most unique architectural -decision, and it's in transform.e. It's well documented, but it's also -extremely conceptually dense. Feel free to give it a skim, that's the only way -to build familiarity with these things, but you should probably have a solid -understanding of the rest of the internals before you place any high +decision, and it's in compilation/transform.e. It's well documented, but it's +also extremely conceptually dense. Feel free to give it a skim, that's the +only way to build familiarity with these things, but you should probably have +a solid understanding of the rest of the internals before you place any high expectations on yourself around understanding the transformation facility. It's okay, you can benefit from it before you understand it: Transformation provides the core tricks that make it possible to compile Forth code into standalone executables. The call to label-transform in evoke.e, and the call -to log-load-transform in execution.e, are the two spots where compilation is -handed off to the transformation facility, and you can pretty much just take -it for granted that it works, until you feel ready. +to log-load-transform in compilation/execution.e, are the two spots where +compilation is handed off to the transformation facility, and you can pretty +much just take it for granted that it works, until you feel ready. If you want examples of programs that are smaller than Evocation itself, quine.e is a tiny program written in proper Evocation that outputs its own @@ -305,13 +308,13 @@ created. The binary bootstrapping strategy rests on something called the "hex transform", the most complex of the transformations provided as part of -Evocation's transformation facility in transform.e. The hex transform has the -task of transforming an entire compilation process, which would otherwise -produce an executable binary, and instead output a commented hex dump of that -binary which describes its internals and their purpose, byte by byte, in -sufficient detail to allow a human reader to audit their correctness. It will -do this by passing through comments and call-stack information from the -compilation process to the resulting output. +Evocation's transformation facility in compilation/transform.e. The hex +transform has the task of transforming an entire compilation process, which +would otherwise produce an executable binary, and instead output a commented +hex dump of that binary which describes its internals and their purpose, byte +by byte, in sufficient detail to allow a human reader to audit their +correctness. It will do this by passing through comments and call-stack +information from the compilation process to the resulting output. In order to turn this commented hex dump into a binary, there is a tiny program called "hex" which handles comments in Evocations ~ syntax, and @@ -359,8 +362,8 @@ do in the near future, now that bootstrapping is complete. Nearly all of this runtime is attributable to the log-load transform; if you're working on something that doesn't involve the log-load transform, you may find it useful to temporarily comment out the call to log-load-transform -in execution.e, replacing it with two invocations of drop. This will not -produce a working compiler, but it will finish faster. +in compilation/execution.e, replacing it with two invocations of drop. This +will not produce a working compiler, but it will finish faster. Now get debugging! :) diff --git a/amd64.e b/amd64.e deleted file mode 100644 index 20f140c..0000000 --- a/amd64.e +++ /dev/null @@ -1,1382 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Assembly language for the AMD64 architecture ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ This is also often called the x86-64 architecture, but Intel didn't -~ invent it (they had their chance) and there's no reason to name it after -~ their product line. We have a bunch of assembler words that, taken as a -~ whole, form a sort of assembly language inside of the Forth-style language. -~ -~ It's all backwards and stuff. -~ -~ Okay, but seriously, the convention is: target on the top of the stack, -~ source behind it. This is similar to how the Forth "!" and "@" words work. -~ -~ These routines use the binary packing routines such as pack64, defined in -~ core.e. They're called in the same way: an output address which we call the -~ "output point", followed by data items specific to what's being output. They -~ also chain together in the same way, returning the updated output point. -~ -~ TODO cite the Intel reference manual here and explain the notation used -~ for the section citations below -~ -~ TODO define instructions, assembly code, machine code, opcodes. if we ever -~ also want to recommend a childrens' introduction to binary, this might be -~ the place to do it. -~ -~ -~ Hex-transformed output -~ ~~~~~~~~~~~~~~~~~~~~~~ -~ -~ In addition to the actual semantics of the assembly words, there's an -~ important layer of meaning atop them. The hex transform, described in detail -~ in transform.e, modifies a compilation process to produce a commented hex -~ dump instead of a binary. It includes a magic-comment feature which allows -~ words that have opinions on what their output's hex dump should look like to -~ express them. -~ -~ The code in this file makes extensive use of the magic-comment feature. -~ Any comment which starts with : as its first word is a magic comment meant -~ for the hex transform. When the hex transform is not in use, these are -~ ordinary comments and are ignored. When it is in use, they create and modify -~ metadata annotations in a complex way. -~ -~ The magic comments in this file follows two important conventions: First, -~ entries are created by whichever word directly corresponds to a top-level -~ assembly instruction from the perspective of someone programming with it, -~ at some point prior to calling any word which might pack output. Second, -~ output bytes are accounted for by whichever word directly calls a pack* word -~ for them. -~ -~ Thus, for example, the word "syscall" has a comment which creates an entry -~ describing its length as 2 bytes, which never varies. -~ -~ The word "mov-reg64-imm32", on the other hand, has a comment which -~ creates an entry describing is length as 5 bytes - the opcode and the -~ immediate value, which are output with calls to pack8 and pack32 in that -~ word. However, the actual length of the instruction is 5 bytes. When -~ mov-reg64-imm32 calls rex-w, a magic comment there modifies the most recent -~ entry in-place, marking it as being one byte longer. Subsequently, -~ mov-reg64-imm32 calls addressing-reg64, which calls modrm, which again -~ modifies the same entry. Notice that addressing-reg64 didn't need to do -~ anything, because it isn't directly responsible for any packing. -~ -~ Notice that when an entry is modified in place, it needs to have been -~ created first. Attempting to do it in the wrong order will have an -~ undesired effect, most likely editing the entry of an unrelated instruction. -~ The hex transform doesn't have detailed knowledge of assembly, and isn't in -~ a position to know that the edits that are happening are sensible. -~ -~ Hopefully these examples show why an accounting convention is needed. The -~ good news is that the convention is quite robust and needs essentially no -~ play-by-play commentary, just this explainer at the top. - - -~ Keywords -~ ~~~~~~~~ -~ -~ We define a bunch of keywords, which evaluate to their own codeword -~ addresses. We use these to refer to registers and condition codes by name. -~ -~ -~ On registers -~ ~~~~~~~~~~~~ -~ -~ The x86 architecture has been around a while, it has been through -~ several transitions from smaller word sizes to larger ones. Therefore it -~ has different names for the "same" registers, depending on how much of -~ them you're using. -~ -~ TODO there's more to write here - -~ The names of the 64-bit registers. The second half of these are considered -~ "extended" registers because they don't correspond to 32-bit registers in -~ the way the first eight do. -s" :rax" keyword -s" :rcx" keyword -s" :rdx" keyword -s" :rbx" keyword -s" :rsp" keyword -s" :rbp" keyword -s" :rsi" keyword -s" :rdi" keyword -s" :r8" keyword -s" :r9" keyword -s" :r10" keyword -s" :r11" keyword -s" :r12" keyword -s" :r13" keyword -s" :r14" keyword -s" :r15" keyword - -~ The names of the 32-bit registers. The processor treats these as being -~ alternate names for the low halves of the 64-bit registers. There is a -~ very finicky distinction about what that means in different settings: Some -~ instructions operate on a 32-bit source or target, while others merely -~ accept a 32-bit value that gets sign-extended to 64 bits. We've taken pains -~ to clarify these cases in the instruction-specific notes, as they come up. -s" :eax" keyword -s" :ecx" keyword -s" :edx" keyword -s" :ebx" keyword -s" :esp" keyword -s" :ebp" keyword -s" :esi" keyword -s" :edi" keyword - -~ The names of the 16-bit registers. Similarly, the processor treats these -~ as being alternate names for the low halves of the 32-bit registers. -s" :ax" keyword -s" :cx" keyword -s" :dx" keyword -s" :bx" keyword -s" :sp" keyword -s" :bp" keyword -s" :si" keyword -s" :di" keyword - -~ The names of the 8-bit registers. The pattern here is a little bit -~ different; these come in "low" and "high" pairs, where for example :al is -~ the low half of :ax and :ah is the high half. Yes, this architecture grows -~ like a tree, with all the old things being still present, surrounded in the -~ new ones. -s" :al" keyword -s" :cl" keyword -s" :dl" keyword -s" :bl" keyword -s" :ah" keyword -s" :ch" keyword -s" :dh" keyword -s" :bh" keyword - -~ The condition codes. Yes, there sure is a lot of duplication in these -~ names. The names are based on Intel's documented mnemonics... -~ -~ "Above" and "below" are for unsigned comparisons. "Greater" and "less" are -~ for signed comparisons. -~ -~ This is documented on the individual opcode pages, and also in B.1.4.7. -s" :cc-overflow" keyword -s" :cc-no-overflow" keyword -s" :cc-below" keyword -s" :cc-above-equal" keyword -s" :cc-equal" keyword -s" :cc-not-equal" keyword -s" :cc-below-equal" keyword -s" :cc-above" keyword -s" :cc-sign" keyword -s" :cc-not-sign" keyword -s" :cc-even" keyword -s" :cc-odd" keyword -s" :cc-less" keyword -s" :cc-greater-equal" keyword -s" :cc-less-equal" keyword -s" :cc-greater" keyword - - -~ Bits and pieces -~ ~~~~~~~~~~~~~~~ -~ -~ Here, we have a bunch of helpers which generate specific encoded -~ representations that are part of many instructions. We start with the -~ trivial ones that handle individual fields, then work up to combinations of -~ fields. -~ -~ When we say that a word accepts a register as a parameter, what we mean -~ is it accepts the name keyword for that register. When we say that a word -~ accepts a scale factor, what we mean is that it accepts a byte count for -~ that scale factor. In the cases where we mean the encoded form, we'll say -~ "encoded value" or "value". -~ -~ (register -- 3-bit encoded value for register) -: reg64 - ~ : provide-keyword - dup :rax = { drop 0 exit } if - dup :rcx = { drop 1 exit } if - dup :rdx = { drop 2 exit } if - dup :rbx = { drop 3 exit } if - dup :rsp = { drop 4 exit } if - dup :rbp = { drop 5 exit } if - dup :rsi = { drop 6 exit } if - dup :rdi = { drop 7 exit } if - ." Parameter to reg64 is not a reg64." 1 sys-exit ; - -~ (register -- 3-bit encoded value for register) -: extrareg64 - ~ : provide-keyword - dup :r8 = { drop 0 exit } if - dup :r9 = { drop 1 exit } if - dup :r10 = { drop 2 exit } if - dup :r11 = { drop 3 exit } if - dup :r12 = { drop 4 exit } if - dup :r13 = { drop 5 exit } if - dup :r14 = { drop 6 exit } if - dup :r15 = { drop 7 exit } if - ." Parameter to extrareg64 is not an extrareg64." 1 sys-exit ; - -~ (register -- 3-bit encoded value for register) -: reg32 - ~ : provide-keyword - dup :eax = { drop 0 exit } if - dup :ecx = { drop 1 exit } if - dup :edx = { drop 2 exit } if - dup :ebx = { drop 3 exit } if - dup :esp = { drop 4 exit } if - dup :ebp = { drop 5 exit } if - dup :esi = { drop 6 exit } if - dup :edi = { drop 7 exit } if - ." Parameter to reg32 is not a reg32." 1 sys-exit ; - -~ (register -- 3-bit encoded value for register) -: reg16 - ~ : provide-keyword - dup :ax = { drop 0 exit } if - dup :cx = { drop 1 exit } if - dup :dx = { drop 2 exit } if - dup :bx = { drop 3 exit } if - dup :sp = { drop 4 exit } if - dup :bp = { drop 5 exit } if - dup :si = { drop 6 exit } if - dup :di = { drop 7 exit } if - ." Parameter to reg16 is not a reg16." 1 sys-exit ; - -~ (register -- 3-bit encoded value for register) -: reg8 - ~ : provide-keyword - dup :al = { drop 0 exit } if - dup :cl = { drop 1 exit } if - dup :dl = { drop 2 exit } if - dup :bl = { drop 3 exit } if - dup :ah = { drop 4 exit } if - dup :ch = { drop 5 exit } if - dup :dh = { drop 6 exit } if - dup :bh = { drop 7 exit } if - ." Parameter to reg8 is not a reg8." 1 sys-exit ; - - -~ There's a packed format called the SIB byte, which we'll get to in a -~ second. One of its bitfields is called the scale field. This word produces -~ an encoded value for that field. -~ -~ The input value is a byte count; the output value is suitable for use in -~ the SIB byte. -~ -~ (scale factor -- 2-bit encoded value) -: scalefield - ~ : provide-decimal - dup 1 = { drop 0 exit } if - dup 2 = { drop 1 exit } if - dup 4 = { drop 2 exit } if - dup 8 = { drop 3 exit } if - ." Parameter to scalefield is not 1, 2, 4, or 8." 1 sys-exit ; - - -~ [Intel] volume 2D, appendix B, section B-1.4.7, table B-10. Also see the -~ individual opcode pages. -~ -~ Every instruction has an "opcode", a specific byte or sequence of bytes -~ which uniquely identifies the combination of operation, addressing mode, -~ and certain miscellaneous characteristics. This is not just another way of -~ referring to the entire sequence of bytes corresponding to the instruction; -~ the opcode is a specific part within that, as distinct from ie. the rex -~ byte, the SIB byte, the Mod/RM byte, and various immediate values and other -~ rare tidbits. -~ -~ Some of these opcodes have bitfields within them, to specify condition -~ codes. This word produces an encoded value for that condition-code field. -~ -~ (condition -- 4-bit encoded value) -: condition-code - ~ : provide-keyword - dup :cc-overflow = { drop 0 exit } if - dup :cc-no-overflow = { drop 1 exit } if - dup :cc-below = { drop 2 exit } if - dup :cc-above-equal = { drop 3 exit } if - dup :cc-equal = { drop 4 exit } if - dup :cc-not-equal = { drop 5 exit } if - dup :cc-below-equal = { drop 6 exit } if - dup :cc-above = { drop 7 exit } if - dup :cc-sign = { drop 8 exit } if - dup :cc-not-sign = { drop 9 exit } if - dup :cc-even = { drop 10 exit } if - dup :cc-odd = { drop 11 exit } if - dup :cc-less = { drop 12 exit } if - dup :cc-greater-equal = { drop 13 exit } if - dup :cc-less-equal = { drop 14 exit } if - dup :cc-greater = { drop 15 exit } if - ." Parameter to condition-code is not a condition code." 1 sys-exit ; - - -~ The "rex" byte appears before an opcode to modify its behavior in various -~ ways. It has four distinct bits within it, leading to sixteen variations, -~ as you can see. -~ -~ The way these are all spelled out like this is slightly ridiculous, there -~ must be a better way. We only ever use rex-w and rex-wb, so it's tempting to -~ get rid of the rest, but they're worth having so that our future selves -~ don't have to revisit this topic. -~ -~ (output point -- output point) -: rex-0 - ~ : 1 adjust-length - 0x40 pack8 ; -: rex-w - ~ : 1 adjust-length - 0x48 pack8 ; -: rex-r - ~ : 1 adjust-length - 0x44 pack8 ; -: rex-x - ~ : 1 adjust-length - 0x42 pack8 ; -: rex-b - ~ : 1 adjust-length - 0x41 pack8 ; -: rex-wr - ~ : 1 adjust-length - 0x4C pack8 ; -: rex-wx - ~ : 1 adjust-length - 0x4A pack8 ; -: rex-wb - ~ : 1 adjust-length - 0x49 pack8 ; -: rex-rx - ~ : 1 adjust-length - 0x46 pack8 ; -: rex-rb - ~ : 1 adjust-length - 0x45 pack8 ; -: rex-xb - ~ : 1 adjust-length - 0x43 pack8 ; -: rex-wrx - ~ : 1 adjust-length - 0x4E pack8 ; -: rex-wrb - ~ : 1 adjust-length - 0x4D pack8 ; -: rex-wxb - ~ : 1 adjust-length - 0x4B pack8 ; -: rex-rxb - ~ : 1 adjust-length - 0x47 pack8 ; -: rex-wrxb - ~ : 1 adjust-length - 0x4F pack8 ; - - -~ Some opcodes use their low three bits as a field to give a register name. -~ This is usually in addition to a register name given in a Mod/RM byte, -~ serving a different role for the instruction. -~ -~ This word accepts an opcode byte with those three bits clear, and combines -~ it with a register value, then outputs the resulting byte. Each opcode -~ accepts some specific kind of register; to allow different kinds, here we -~ expect the step of converting the register name to the encoded bits to have -~ already been done. -~ -~ (output point, 3-bit encoded value for register, opcode byte -~ -- output point) -: opcodereg - ~ : 1 adjust-length - | pack8 ; - - -~ Some opcodes use their low four bits as a field to give a condition code. -~ This word accepts an opcode byte with those four bits clear, and combines it -~ with a condition code value, then outputs the resulting byte. For -~ consistency with opcodereg, we expect the step of converting the condition -~ code name to the encoded bits to have already been done. -~ -~ (output point, 4-bit encoded value for condition code, opcode byte -~ -- output point) -: opcodecc - ~ : 1 adjust-length - | pack8 ; - - -~ A Mod/RM byte ("mode / register-or-memory") is part of the encoding of -~ many instructions. It's divided into three fields: "mod" (mode), -~ register/opcode, and register/memory ("RM"). -~ -~ This word outputs a Mod/RM byte given fully-processed, numeric values for -~ its fields. Most code will want to call one of the higher-level -~ addressing-* words, instead. -~ -~ (output point, mod field, register/opcode field, register/memory field -~ -- output point) -: modrm - ~ : 1 adjust-length - swap 8 * | swap 64 * | pack8 ; - -~ An SIB byte ("scale, index, base") is part of the encoding of many -~ instructions. It's divided into three fields, with the names you've already -~ guessed. -~ -~ This word outputs an SIB byte given fully-processed, numeric values for -~ its fields. -~ -~ (output point, scale field, index field, base field -- output point) -: sib - ~ : 1 adjust-length - swap 8 * | swap 64 * | pack8 ; - - -~ Addressing modes -~ ~~~~~~~~~~~~~~~~ -~ -~ These are higher-level words meant to be easier to use than the bits and -~ pieces above. Each corresponds to some specific addressing mode. When -~ applicable, they accept keywords rather than pre-encoded values. -~ -~ That's not all the time, because there are cases, such as the reg/op -~ field, where the meaning is up to the individual instruction. In those -~ cases, these words do accept fully-processed, numeric values. -~ -~ The general rule is that the responsibility of these addressing-mode words -~ is for the parts that are common to all instructions using that addressing -~ mode. - - -~ The simplest of the addressing modes: Direct register addressing. There -~ are no special cases to check. -~ -~ It's important to notice that the R/M field may describe either a source, -~ or a target, depending on what the instruction is. So, this helper doesn't -~ get to know that. It also doesn't get to know whether the value in the -~ reg/op field describes a register, or if instead it's an extension of the -~ opcode. The caller is responsible for figuring that all out. -~ -~ (output point, reg/op field value, reg/mem field register -~ -- output point) -: addressing-reg64 reg64 3 3unroll modrm ; -: addressing-reg8 reg8 3 3unroll modrm ; - - -~ This is a helper for assembly instructions that want to do a form of -~ addressing that requires a value of 1 in the modrm byte's mode field, and -~ do not want to do any indexing. That's the indirect mode, which takes a -~ 64-bit register, treats it as an address, and looks up the 64-bit value it -~ points to. -~ -~ The helper's main responsibility is to deal with the scenario that -~ requires an SIB byte, which happens when the R/M field has a value of 4, -~ which would otherwise refer to the register rsp. In that situation, it also -~ generates an SIB byte which indicates a scale of 1, no indexing, and rsp as -~ the base register. -~ -~ When the register is :rbp, the only modes available also have -~ displacement; we disallow that. For that case, use an instruction that -~ uses a disp8 mode, and set a displacement of 0. -~ -~ In understanding this, pay close attention to the Op/En column in the -~ opcode table. The "RM" variant means the ModRM byte's R/M field (the third -~ one) is the source, while its reg field (the middle one) is the target. This -~ is what we want, because the R/M field is the one that gets indirection -~ applied to it. Opcode 0x8B with an REX.W prefix is the all-64-bit RM -~ variant. [Intel] volume 2B, chapter 4, section 4-3, "MOV". -~ -~ For the indirection modes, don't be confused by the many similar tables. -~ 64-bit mode is encoded the same as 32-bit mode except for adding a REX.W -~ prefix, as per 2.2.1.1, so you want table 2-2 to understand the ModRM byte. -~ The presence or absence of an SIB byte is determined by where in that table -~ we fall, and we aren't using a mode that has one. [Intel] volume 2A, -~ chapter 2, section 2-1.5, table 2-2. -~ -~ (output point, reg/op field value, reg/mem field register -~ -- output point) -: addressing-indirect-reg64 - ~ Exit with an error if the R/M register is :rbp. - dup :rbp != { - ~ Check whether the R/M register is :rsp. Save the test result for later. - dup :rsp = 4 unroll - ~ (equality result, output point, reg/op value, reg/mem name) - reg64 0 3unroll modrm - ~ (equality result, output point) - ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. - swap { - 0 4 :rsp reg64 - ~ : drop-subitem - sib - } if - exit - } if - ." R/M parameter to addressing-indirect-reg64 is :rbp." 1 sys-exit ; - -~ (output point, reg/op field value, reg/mem field register, -~ displacement value -- output point) -: addressing-disp8-reg64 - ~ This mode can do :rbp fine, so no need to check for that. - ~ Check whether the R/M register is :rsp. Save the test result for later. - swap dup :rsp = 5 unroll swap - ~ Stash the displacement value out of the way, too. - 4 unroll - reg64 1 3unroll modrm - ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. - 3roll { - 0 4 :rsp reg64 - ~ : drop-subitem - sib - } if - - ~ The displacement byte. - ~ - ~ When addressing-disp8-reg64 references a source, as in - ~ lea-reg64-disp8-reg64, the first two parameters of the assembly word - ~ calling it are the source register and the source displacement value. When - ~ it references a target or destination, as in mov-disp8-reg64-reg64, the - ~ LAST two parameters are the target registera and target displacement - ~ value. - ~ - ~ In both cases, the register comes first and the displacement value - ~ comes second. When these are used in a comment template without any other - ~ rearranging going on, whichever is on the top of the stack will be popped - ~ off first. So, we swap them here, thus putting the register on the top. - swap - ~ : 1 adjust-length - ~ : provide-hex8 - ~ : swap-subitems - pack8 ; - -~ (output point, reg/op field value, reg/mem field register, -~ displacement value -- output point) -: addressing-disp32-reg64 - ~ This mode can do :rbp fine, so no need to check for that. - ~ Check whether the R/M register is :rsp. Save the test result for later. - swap dup :rsp = 5 unroll swap - ~ Stash the displacement value out of the way, too. - 4 unroll - reg64 2 3unroll modrm - ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. - 3roll { - 0 4 :rsp reg64 - ~ : drop-subitem - sib - } if - - ~ The displacement value. This is subject to the same considerations as in - ~ addressing-disp8-reg64. - swap - ~ : 4 adjust-length - ~ : provide-hex32 - ~ : swap-subitems - pack32 ; - -~ (output point, reg/op field value, -~ scale factor, index register, base field register -~ -- output point) -: addressing-indexed-reg64 - ~ Exit with an error if the base register is :rbp. - dup :rbp != { - ~ Reg/mem value 4 means to use an SIB byte (at least, with this mode). - 5 roll 0 6 roll 4 modrm 4 unroll - reg64 3unroll reg64 3unroll scalefield 3unroll - ~ We want the scale factor to show after the registers, so we put it - ~ last on the stack. We also want the base register to show before the - ~ index register, so the base comes first. - ~ - ~ Importantly, we have to do this before the sib so it'll count as being - ~ inside the span the assembly word's description attaches to. - ~ - ~ : -3 roll-subitems - ~ : swap-subitems - sib - exit - } if - ." Base parameter to addressing-indexed-reg64 is :rbp." 1 sys-exit ; - -~ (output point, reg/op field value, -~ scale factor, index register, base field register, -~ displacement value -- output point) -: addressing-disp8-indexed-reg64 - ~ This mode can do :rbp fine, so no need to check for that. - ~ Reg/mem value 4 means to use an SIB byte (at least, with this mode). - 6 roll 1 7 roll 4 modrm 5 unroll - 5 unroll reg64 3unroll reg64 3unroll scalefield 3unroll sib - swap - ~ : 1 adjust-length - ~ : provide-hex8 - ~ - ~ We want the parameters to be shown in the order: - ~ - ~ base register, index register, index scale factor, displacement - ~ - ~ So, we put them on the stack in the opposite of that order. - ~ - ~ Importantly, we have to do this before the pack8 so it'll count as being - ~ inside the span the assembly word's description attaches to. - ~ - ~ : -4 roll-subitems - ~ : -3 roll-subitems - ~ : swap-subitems - pack8 - ; - - -~ Easy instructions -~ ~~~~~~~~~~~~~~~~~ -~ -~ It's not worth pretending there's a coherent category behind this -~ grouping. These are the ones that were easy to deal with. - -~ (output point -- output point) -: cld - ~ : 1 cld - 0xFC pack8 ; -: std - ~ : 1 std - 0xFD pack8 ; -: syscall - ~ : 2 syscall - 0x0F pack8 0x05 pack8 ; -: hlt - ~ : 1 hlt - 0xF4 pack8 ; - -~ (output point, source register -- output point) -: push-reg64 - ~ : 0 # push-reg64 - reg64 0x50 opcodereg ; -: push-extrareg64 - ~ : 0 # push-extrareg64 - swap rex-b swap extrareg64 0x50 opcodereg ; - ~ Note the use of the B rex bit here; this instruction puts the register - ~ number in the opcode field, so it uses Table 3-1. - -~ (output point, target register -- output point) -: pop-reg64 - ~ : 0 # pop-reg64 - reg64 0x58 opcodereg ; -: pop-extrareg64 - ~ : 0 # pop-extrareg64 - swap rex-b swap extrareg64 0x58 opcodereg ; - ~ Note the use of the B rex bit here; this instruction puts the register - ~ number in the opcode field, so it uses Table 3-1. - -~ (output point, immediate value -- output point) -: push-imm32-extended64 - ~ : 5 # push-imm32-extended64 - swap 0x68 pack8 swap - ~ : provide-hex - pack32 ; - -~ (output point, source register, source displacement value, target register -~ -- output point) -: lea-reg64-disp8-reg64 - ~ : 1 # # # lea-reg64-disp8-reg64 - 4 roll rex-w 0x8D pack8 4 unroll - reg64 3unroll addressing-disp8-reg64 ; - -~ (output point, source register, source displacement value, target register -~ -- output point) -: lea-reg64-disp32-reg64 - ~ : 1 # # # lea-reg64-disp32-reg64 - 4 roll rex-w 0x8D pack8 4 unroll - reg64 3unroll addressing-disp32-reg64 ; - -~ (output point, -~ source base register, source index register, source index scale factor, -~ target register -- output point) -: lea-reg64-indexed-reg64 - ~ : 1 # # # # lea-reg64-indexed-reg64 - 5 roll rex-w 0x8D pack8 5 unroll - reg64 4 unroll 3unroll swap addressing-indexed-reg64 ; - -~ (output point, -~ source base register, source index register, source index scale factor, -~ source displacement value, -~ target register -- output point) -: lea-reg64-disp8-indexed-reg64 - ~ : 1 # # # # # lea-reg64-disp8-indexed-reg64 - 6 roll rex-w 0x8D pack8 6 unroll - reg64 5 unroll 3 roll 4 roll 3 roll addressing-disp8-indexed-reg64 ; - - -~ Move instructions -~ ~~~~~~~~~~~~~~~~~ -~ -~ These are, like, MOST of what we care about, so they get their own -~ section. Although it's very much the case that almost every two-operand -~ instruction offers this many distinct modes, we don't care about most of -~ those and don't yet implement them. We do care about all the modes for move -~ instructions. -~ -~ Someday perhaps we'll have extra-high-level features which generate all -~ the distinct versions of each instruction in a concise way, but that is not -~ this day. - -~ (output point, immediate value, register -- output point) -: mov-reg64-imm32 - ~ : 5 # # mov-reg64-imm32 - 3roll - rex-w 0xC7 pack8 swap - 0 swap addressing-reg64 - swap - ~ : provide-hex - pack32 ; -: mov-reg64-imm64 - ~ : 8 # # mov-reg64-imm64 - 3roll rex-w swap reg64 0xB8 opcodereg swap - ~ : provide-hex - pack64 ; -: mov-extrareg64-imm64 - ~ : 8 # # mov-extrareg64-imm64 - ~ Note the use of the B rex bit here; this instruction puts the register - ~ number in the opcode field, so it uses Table 3-1. - 3roll rex-wb swap extrareg64 0xB8 opcodereg swap - ~ : provide-hex - pack64 ; - -~ (output point, source register, target register -- output point) -: mov-reg64-reg64 - ~ : 1 # # mov-reg64-reg64 - 3roll rex-w 0x89 pack8 3unroll - swap reg64 swap addressing-reg64 - ~ : swap-subitems - ; -: mov-indirect-reg64-reg64 - ~ : 1 # # mov-indirect-reg64-reg64 - 3roll rex-w 0x89 pack8 3unroll - swap reg64 swap addressing-indirect-reg64 - ~ : swap-subitems - ; - -~ (output point, source register, target register, target displacement value -~ -- output point) -: mov-disp8-reg64-reg64 - ~ : 1 # # # mov-disp8-reg64-reg64 - 4 roll rex-w 0x89 pack8 4 unroll - 3roll reg64 3unroll addressing-disp8-reg64 - ~ : 3 roll-subitems - ; - -~ (output point, source register, target register -- output point) -: mov-reg64-indirect-reg64 - ~ : 1 # # mov-reg64-indirect-reg64 - 3roll rex-w 0x8B pack8 3unroll - reg64 swap addressing-indirect-reg64 ; - -~ (output point, source register, source displacement value, target register -~ -- output point) -: mov-reg64-disp8-reg64 - ~ : 1 # # # mov-reg64-disp8-reg64 - 4 roll rex-w 0x8B pack8 4 unroll - reg64 3unroll addressing-disp8-reg64 ; -: mov-reg64-disp32-reg64 - ~ : 1 # # # mov-reg64-disp32-reg64 - 4 roll rex-w 0x89 pack8 4 unroll - 3roll reg64 swap 3roll addressing-disp32-reg64 - ~ : swap-subitems - ~ : 3 roll-subitems - ; - -~ (output point, -~ source base register, source index register, source index scale factor, -~ target register -- output point) -: mov-reg64-indexed-reg64 - ~ : 1 # # # # mov-reg64-indexed-reg64 - 5 roll rex-w 0x8B pack8 5 unroll - reg64 4 unroll 3unroll swap addressing-indexed-reg64 ; - -~ (output point, source register, -~ target base register, target index register, target index scale factor -~ -- output point) -: mov-indexed-reg64-reg64 - ~ : 1 # # # # mov-indexed-reg64-reg64 - 5 roll rex-w 0x89 pack8 5 unroll - 4 roll reg64 4 unroll - 3unroll swap addressing-indexed-reg64 - ~ : 4 roll-subitems - ; - -~ (output point, source register, target register -- output point) -: mov-indirect-reg64-reg32 - ~ : 1 # # mov-indirect-reg64-reg32 - 3roll 0x89 pack8 3unroll - swap reg32 swap addressing-indirect-reg64 - ~ : swap-subitems - ; - -~ (output point, source register, target register, target displacement value -~ -- output point) -: mov-disp8-reg64-reg32 - ~ : 1 # # # mov-disp8-reg64-reg32 - 4 roll 0x89 pack8 4 unroll - 3roll reg32 3unroll addressing-disp8-reg64 - ~ : 3 roll-subitems - ; - -~ (output point, source register, target register -- output point) -: mov-reg32-indirect-reg64 - ~ : 1 # # mov-reg32-indirect-reg64 - 3roll 0x8B pack8 3unroll - reg32 swap addressing-indirect-reg64 ; - -~ (output point, source register, source displacement value, target register -~ -- output point) -: mov-reg32-disp8-reg64 - ~ : 1 # # # mov-reg32-disp8-reg64 - 4 roll 0x8B pack8 4 unroll - reg32 3unroll addressing-disp8-reg64 ; - -~ (output point, source register, target register -- output point) -: mov-indirect-reg64-reg16 - ~ : 2 # # mov-indirect-reg64-reg16 - 3roll 0x66 pack8 0x89 pack8 3unroll - swap reg16 swap addressing-indirect-reg64 - ~ : swap-subitems - ; - -~ (output point, source register, target register, target displacement value -~ -- output point) -: mov-disp8-reg64-reg16 - ~ : 2 # # # mov-disp8-reg64-reg16 - 4 roll 0x66 pack8 0x89 pack8 4 unroll - 3roll reg16 3unroll addressing-disp8-reg64 - ~ : 3 roll-subitems - ; - -~ (output point, source register, target register -- output point) -: mov-reg16-indirect-reg64 - ~ : 2 # # mov-reg16-indirect-reg64 - 3roll 0x66 pack8 0x8B pack8 3unroll - reg16 swap addressing-indirect-reg64 ; - -~ (output point, source register, target displacement value, target register -~ -- output point) -: mov-reg16-disp8-reg64 - ~ : 2 # # # mov-reg16-disp8-reg64 - 4 roll 0x66 pack8 0x8B pack8 4 unroll - reg16 3unroll addressing-disp8-reg64 ; - -~ (output point, source register, target register -- output point) -: mov-indirect-reg64-reg8 - ~ : 1 # # mov-indirect-reg64-reg8 - 3roll 0x88 pack8 3unroll - swap reg8 swap addressing-indirect-reg64 - ~ : swap-subitems - ; - -~ (output point, source register, target register, target displacement value -~ -- output point) -: mov-disp8-reg64-reg8 - ~ : 1 # # # mov-disp8-reg64-reg8 - 4 roll 0x88 pack8 4 unroll - 3roll reg8 3unroll addressing-disp8-reg64 - ~ : 3 roll-subitems - ; - -~ (output point, source register, target register -- output point) -: mov-reg8-indirect-reg64 - ~ : 1 # # mov-reg8-indirect-reg64 - 3roll 0x8A pack8 3unroll - reg8 swap addressing-indirect-reg64 ; - -~ (output point, source register, source displacement value, target register -~ -- output point) -: mov-reg8-disp8-reg64 - ~ : 2 # # # mov-reg8-disp8-reg64 - 4 roll 0x8A pack8 4 unroll - reg8 3unroll addressing-disp8-reg64 ; - -~ (output point, source register, target register -- output point) -: mov-reg8-reg8 - ~ : 1 # # mov-reg8-reg8 - 3roll 0x88 pack8 3unroll - swap reg8 swap addressing-reg8 - ~ : swap-subitems - ; - - -~ String instructions -~ ~~~~~~~~~~~~~~~~~~~ -~ -~ These are in their own section because there's an awful lot of -~ combinations, and fortunately they are very uniform in structure. -~ -~ What makes these useful is that they take their parameters from certain -~ fixed registers, which are chosen such that the operations chain into each -~ other well. Thus you can use them to build various block-memory and string -~ operations, and even if you need unusual forms of loop unrolling or -~ alignment tweaking, the code will end up uniform in structure. On modern -~ processors, this is even the high-performance approach, due to highly -~ optimized microcode, though these operations were inefficient when they -~ were first invented. -~ -~ We break with the Intel mnemonics, which follow the pattern -~ movsb/movsw/movsd/movsq, because this would otherwise be the only place we -~ use the b/w/d/q thing instead of 8/16/32/64. Tradition and pronounceability -~ are both nice things, but approachability to newcomers is important, too. -~ -~ Some of these are repeatable; whether you view the repeatable variants -~ as different instructions is up to you. At any rate the machine code -~ representation of the repeatable variants is the same as for the regular -~ variants with an extra prefix, so we define them together. -~ -~ This is a proper superset of the flatassembler implementations of string -~ instructions. The wisdom of that is questionable, but at least it's noted -~ here... - -~ (output point -- output point) -: movs8 - ~ : 1 movs8 - 0xA4 pack8 ; -: movs16 - ~ : 2 movs16 - 0x66 pack8 0xA5 pack8 ; -: movs32 - ~ : 1 movs32 - 0xA5 pack8 ; -: movs64 - ~ : 1 movs64 - rex-w 0xA5 pack8 ; -: rep-movs8 - ~ : 2 rep-movs8 - 0xF3 pack8 0xA4 pack8 ; -: rep-movs16 - ~ : 3 rep-movs16 - 0xF3 pack8 0x66 pack8 0xA5 pack8 ; -: rep-movs32 - ~ : 2 rep-movs32 - 0xF3 pack8 0xA5 pack8 ; -: rep-movs64 - ~ : 2 rep-movs64 - 0xF3 pack8 rex-w 0xA5 pack8 ; - -~ (output point -- output point) -: lods8 - ~ : 1 lods8 - 0xAC pack8 ; -: lods16 - ~ : 2 lods16 - 0x66 pack8 0xAd pack8 ; -: lods32 - ~ : 1 lods32 - 0xAD pack8 ; -: lods64 - ~ : 1 lods64 - rex-w 0xAD pack8 ; -: rep-lods8 - ~ : 2 rep-lods8 - 0xF3 pack8 0xAC pack8 ; -: rep-lods16 - ~ : 3 rep-lods16 - 0xF3 pack8 0x66 pack8 0xAD pack8 ; -: rep-lods32 - ~ : 2 rep-lods32 - 0xF3 pack8 0xAD pack8 ; -: rep-lods64 - ~ : 2 rep-lods64 - 0xF3 pack8 rex-w 0xAD pack8 ; - -~ (output point -- output point) -: stos8 - ~ : 1 stos8 - 0xAA pack8 ; -: stos16 - ~ : 2 stos16 - 0x66 pack8 0xAB pack8 ; -: stos32 - ~ : 1 stos32 - 0xAB pack8 ; -: stos64 - ~ : 1 stos64 - rex-w 0xAB pack8 ; -: rep-stos8 - ~ : 2 rep-stos8 - 0xF3 pack8 0xAA pack8 ; -: rep-stos16 - ~ : 3 rep-stos16 - 0xF3 pack8 0x66 pack8 0xAB pack8 ; -: rep-stos32 - ~ : 2 rep-stos32 - 0xF3 pack8 0xAB pack8 ; -: rep-stos64 - ~ : 2 rep-stos64 - 0xF3 pack8 rex-w 0xAB pack8 ; - -~ (output point -- output point) -: cmps8 - ~ : 1 cmps8 - 0xA6 pack8 ; -: cmps16 - ~ : 2 cmps16 - 0x66 pack8 0xA7 pack8 ; -: cmps32 - ~ : 1 cmps32 - 0xA7 pack8 ; -: cmps64 - ~ : 1 cmps64 - rex-w 0xA7 pack8 ; -: repz-cmps8 - ~ : 2 repz-cmps8 - 0xF3 pack8 0xA6 pack8 ; -: repz-cmps16 - ~ : 3 repz-cmps16 - 0xF3 pack8 0x66 pack8 0xA7 pack8 ; -: repz-cmps32 - ~ : 2 repz-cmps32 - 0xF3 pack8 0xA7 pack8 ; -: repz-cmps64 - ~ : 2 repz-cmps64 - 0xF3 pack8 rex-w 0xA7 pack8 ; -: repnz-cmps8 - ~ : 2 repnz-cmps8 - 0xF2 pack8 0xA6 pack8 ; -: repnz-cmps16 - ~ : 3 repnz-cmps16 - 0xF2 pack8 0x66 pack8 0xA7 pack8 ; -: repnz-cmps32 - ~ : 2 repnz-cmps32 - 0xF2 pack8 0xA7 pack8 ; -: repnz-cmps64 - ~ : 2 repnz-cmps64 - 0xF2 pack8 rex-w 0xA7 pack8 ; - -~ (output point -- output point) -: scas8 - ~ : 1 scas8 - 0xA8 pack8 ; -: scas16 - ~ : 2 scas16 - 0x66 pack8 0xAF pack8 ; -: scas32 - ~ : 1 scas32 - 0xAF pack8 ; -: scas64 - ~ : 1 scas64 - rex-w 0xAF pack8 ; -: repz-scas8 - ~ : 2 repz-scas8 - 0xF3 pack8 0xAE pack8 ; -: repz-scas16 - ~ : 3 repz-scas16 - 0xF3 pack8 0x66 pack8 0xAF pack8 ; -: repz-scas32 - ~ : 2 repz-scas32 - 0xF3 pack8 0xAF pack8 ; -: repz-scas64 - ~ : 2 repz-scas64 - 0xF3 pack8 rex-w 0xAF pack8 ; -: repnz-scas8 - ~ : 2 repnz-scas8 - 0xF2 pack8 0xAE pack8 ; -: repnz-scas16 - ~ : 3 repnz-scas16 - 0xF2 pack8 0x66 pack8 0xAF pack8 ; -: repnz-scas32 - ~ : 2 repnz-scas32 - 0xF2 pack8 0xAF pack8 ; -: repnz-scas64 - ~ : 2 repnz-scas64 - 0xF2 pack8 rex-w 0xAF pack8 ; - - -~ Arithmetic instructions -~ ~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ Operations between two registers always have the target register as the -~ last parameter. Operations between a register and an immediate ALSO have the -~ target register as the last parameter, which is obvious for add-reg64-imm8 -~ but can be confusing for sub-reg64-imm8 or cmp-reg64-imm8. Also note what -~ this means for sub-reg64-reg64 and cmp-reg64-reg64. -~ -~ Every possible convention here leads to counterintuitive behavior in some -~ cases. This one has proven to be more memorable than the other obvious -~ choices, and that'll have to be enough. - -~ (output point, source register, target register -- output point) -: add-reg64-reg64 - ~ : 1 # # add-reg64-reg64 - 3roll rex-w 0x01 pack8 3unroll - swap reg64 swap addressing-reg64 - ~ : swap-subitems - ; - -~ (output point, source register, target register -- output point) -: add-indirect-reg64-reg64 - ~ : 1 # # add-indirect-reg64-reg64 - 3roll rex-w 0x01 pack8 3unroll - swap reg64 swap addressing-indirect-reg64 - ~ : swap-subitems - ; - -~ (output point, source register, target register -- output point) -: add-reg64-indirect-reg64 - ~ : 1 # # add-reg64-indirect-reg64 - 3roll rex-w 0x03 pack8 3unroll - reg64 swap addressing-indirect-reg64 ; - -~ (output point, immediate value, target register -- output point) -: add-reg64-imm8 - ~ : 2 # # add-reg64-imm8 - 3roll rex-w 0x83 pack8 swap 0 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ See above re: parameter order. -~ -~ (output point, source register, target register -- output point) -: sub-reg64-reg64 - ~ : 1 # # sub-reg64-reg64 - 3roll rex-w 0x2B pack8 3unroll - reg64 swap addressing-reg64 ; - -~ (output point, source register, target register -- output point) -: sub-indirect-reg64-reg64 - ~ : 1 # # sub-indirect-reg64-reg64 - 3roll rex-w 0x2B pack8 3unroll - swap reg64 swap addressing-indirect-reg64 - ~ : swap-subitems - ; - -~ See above re: parameter order. -~ -~ (output point, immediate value, target register -- output point) -: sub-reg64-imm8 - ~ : 2 # # sub-reg64-imm8 - 3roll rex-w 0x83 pack8 swap 5 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ See above re: parameter order. -~ -~ (output point, source register, target register -- output point) -: sbb-reg64-imm8 - ~ : 2 # # sbb-reg64-imm8 - 3roll rex-w 0x83 pack8 swap 3 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ The target register is always rax. -~ -~ (output point, source register -- output point) -: mul-reg64 - ~ : 1 # mul-reg64 - swap rex-w 0xF7 pack8 swap - 4 swap addressing-reg64 ; - -~ The dividend is 128 bits, and is formed from rdx as the high half and rax -~ as the low half. The divisor is a specified register. The quotient is -~ returned in rax, truncated towards zero. The remainder is in rdx. This -~ entire process is unsigned. -~ -~ The official mnemonic for this is "div", but divmod is what it does. -~ -~ (output point, divisor register -- output point) -: divmod-reg64 - ~ : 1 # divmod-reg64 - swap rex-w 0xF7 pack8 swap - 6 swap addressing-reg64 ; - -~ Same as divmod, but signed. -~ -~ (output point, divisor register -- output point) -: idivmod-reg64 - ~ : 1 # idivmod-reg64 - swap rex-w 0xF7 pack8 swap - 7 swap addressing-reg64 ; - -~ (output point, target register -- output point) -: inc-reg64 - ~ : 1 # inc-reg64 - swap rex-w 0xFF pack8 swap 0 swap addressing-reg64 ; - -~ (output point, target register -- output point) -: dec-reg64 - ~ : 1 # dec-reg64 - swap rex-w 0xFF pack8 swap 1 swap addressing-reg64 ; - -~ (output point, source register, target register -- output point) -: and-reg64-reg64 - ~ : 1 # # and-reg64-reg64 - 3roll rex-w 0x23 pack8 3unroll - reg64 swap addressing-reg64 ; - -~ (output point, source value, target register -- output point) -: and-reg64-imm8 - ~ : 2 # # and-reg64-imm8 - 3roll rex-w 0x83 pack8 swap - 4 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ (output point, source register, target register -- output point) -: or-reg64-reg64 - ~ : 1 # # or-reg64-reg64 - 3roll rex-w 0x0B pack8 3unroll - reg64 swap addressing-reg64 ; - -~ (output point, source value, target register -- output point) -: or-reg64-imm8 - ~ : 2 # # or-reg64-imm8 - 3roll rex-w 0x83 pack8 swap - 1 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ (output point, source register, target register -- output point) -: xor-reg64-reg64 - ~ : 1 # # xor-reg64-reg64 - 3roll rex-w 0x33 pack8 3unroll - reg64 swap addressing-reg64 ; - -~ (output point, target register -- output point) -: not-reg64 - ~ : 1 # not-reg64 - swap rex-w 0xF7 pack8 - swap 2 swap addressing-reg64 ; - -~ (output point, bit count, target register -- output point) -: rol-reg64-imm8 - ~ : 2 # # rol-reg64-imm8 - 3roll rex-w 0xC1 pack8 swap - 0 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ (output point, bit count, target register -- output point) -: rol-reg8-imm8 - ~ : 2 # # rol-reg8-imm8 - 3roll 0xC0 pack8 swap - 0 swap addressing-reg8 - swap - ~ : provide-hex - pack8 ; - -~ (output point, bit count, target register -- output point) -: ror-reg64-imm8 - ~ : 1 # # ror-reg64-imm8 - 3roll rex-w 0xC1 pack8 swap - 1 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - -~ (output point, bit count, target register -- output point) -: ror-reg8-imm8 - ~ : 2 # # ror-reg8-imm8 - 3roll 0xC0 pack8 swap - 1 swap addressing-reg64 - swap - ~ : provide-hex - pack8 ; - - -~ Control flow instructions -~ ~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ The comparator instructions cmp and test follow the same argument-order -~ conventions as the arithmetic instructions: The target register always comes -~ last. See the arithmetic section for more discussion. - -~ Pretend to subtract right from left, and set the flags the same way as if -~ we actually had. -~ -~ (output point, left register, right register -- output point) -: cmp-reg64-reg64 - ~ : 1 # # cmp-reg64-reg64 - 3roll rex-w 0x3B pack8 3unroll - reg64 swap addressing-reg64 ; - -~ See above re: parameter order. -~ -~ (output point, immediate value, target register -- output point) -: cmp-reg64-imm8 - ~ : 2 # # cmp-reg64-imm8 - 3roll rex-w 0x83 pack8 - ~ (immediate value, register, output point) - swap 7 swap addressing-reg64 - ~ ( output point, immediate value) - swap - ~ : provide-hex - pack8 ; - -~ Pretend to bitwise-and left with right, and set the flags the same way as -~ if we actually had. -~ -~ The names of the condition codes can be a little confusing when using them -~ after "test", because they're really premised on the idea that you did -~ "cmp". -~ -~ (output point, left register, right register -- output point) -: test-reg64-reg64 - ~ : 1 # # test-reg64-reg64 - 3roll rex-w 0x85 pack8 3unroll - swap reg64 swap addressing-reg64 - ~ : swap-subitems - ; - -~ (output point, condition code, target register -- output point) -: set-reg8-cc - ~ : 1 # # set-reg8-cc - 3roll 0x0F pack8 - 3roll condition-code 0x90 opcodecc - swap reg8 3 0 3roll modrm - ~ : swap-subitems - ; - -~ (output point, address offset value, condition code -- output point) -: jmp-cc-rel-imm8 - ~ : 1 # # jmp-cc-rel-imm8 - 3roll swap condition-code 0x70 opcodecc - swap - ~ : provide-hex - pack8 ; - -~ (output point, address offset value, condition code -- output point) -: jmp-cc-rel-imm32 - ~ : 5 # # jmp-cc-rel-imm32 - 3roll 0x0F pack8 - swap condition-code 0x70 opcodecc - swap - ~ : provide-hex - pack32 ; - -~ (output point, register -- output point) -: jmp-abs-indirect-reg64 - ~ : 1 # jmp-abs-indirect-reg64 - swap 0xFF pack8 swap - 4 swap addressing-indirect-reg64 ; - -~ (output point, address offset value -- output point) -: jmp-rel-imm8 - ~ : 2 # jmp-rel-imm8 - swap 0xEB pack8 - swap - ~ : provide-hex - pack8 ; - -~ (output point, address offset value -- output point) -: jmp-rel-imm32 - ~ : 5 # jmp-rel-imm32 - swap 0xE9 pack8 - swap - ~ : provide-hex - pack32 ; - -~ This is technically a "near" call. The name intentionally doesn't say so. -~ -~ (output point, address offset value -- output point) -: call-rel-imm32 - ~ : 5 # call-rel-imm32 - swap 0xE8 pack8 - swap - ~ : provide-hex - pack32 ; - -~ Similarly, this is a "near" return. -~ -~ (output point) -: ret - ~ : 1 ret - 0xC3 pack8 ; - diff --git a/compilation/elf.e b/compilation/elf.e new file mode 100644 index 0000000..f39a1a0 --- /dev/null +++ b/compilation/elf.e @@ -0,0 +1,179 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Executable file format ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Before we do anything specific to the actual program we're building, we +~ do a lot of ELF-specific stuff to ensure that our output is in a format +~ Linux knows how to run. +~ +~ This relies on the label facility defined in compilation/labels.e. Make +~ sure to load that first. +~ +~ This file makes use of magic comments for the hex transform, described in +~ detail in compilation/transform.e, but its use is trivial and doesn't +~ require accounting conventions. + +~ ~~~~~~~~~~~~~~~~~~~~~ +~ ~~ ELF file header ~~ +~ ~~~~~~~~~~~~~~~~~~~~~ +~ +~ First, we output ELF's top-level file header. This header describes the +~ entire file. An ELF always has exactly one of this header, which is always +~ at the start of the file. +~ +~ The program we're building should call this word as the first output it +~ generates. +~ +~ The most interesting thing here is the entry pointer. +~ +~ It's also worth noticing that we set the ABI version to 3. An ABI version +~ of 0 (for the System V ABI) would work fine too, but 3 allows FreeBSD's +~ Linux compatibility features to kick in. + +: elf-file-header + ~ : blank-line + ~ : ELF file header + ~ : indent + ~ : * denotes mandatory fields according to breadbox + current-offset 3unroll + + ~ : 1 suppress + 0x7f pack8 s" ELF" pack-raw-string ~ : -4 *magic number + 2 pack8 ~ : -1 64-bit + 1 pack8 ~ : -1 little-endian + 1 pack8 ~ : -1 ELF header format v1 + 3 pack8 ~ : -1 Linux ABI + 0 pack64 ~ : -8 (padding) + ~ : blank-line + + 2 pack16 ~ : -2 *executable + 0x3e pack16 ~ : -2 *Intel x86-64 + 1 pack32 ~ : -4 ELF format version + ~ : blank-line + + L@' cold-start L@' origin + pack64 ~ : -8 *entry point + ~ This includes the origin, intentionally. + + L@' elf-program-header pack64 ~ : -8 *program header offset + ~ We place the program header immediately after the ELF header. This + ~ offset is from the start of the file. + 0 pack64 ~ : -8 section header offset + 0 pack32 ~ : -4 processor flags + ~ : blank-line + + L@' elf-header-size pack16 ~ : -2 ELF header size + L@' elf-program-header-size pack16 ~ : -2 *program header entry size + 1 pack16 ~ : -2 *number of program header entries + 0 pack16 ~ : -2 section header entry size + 0 pack16 ~ : -2 number of section header entries + 0 pack16 ~ : -2 section name string table index + + ~ Though hardcoding the size of this header would work fine, it's easier + ~ to use the label system to keep track of its size. The only place this is + ~ actually referenced is right here in the header. + current-offset 4 roll - L!' elf-header-size + L' elf-header-size set-label-non-offset + ~ : deindent + ; + + +~ ~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ ELF program header ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Second, we output ELF's program header, which lists the memory regions +~ ("segments") we want to have and where we want them to come from. There may +~ be any number of these entries, one per segment, , and they may be anywhere +~ in the file as long as they're consecutive. +~ +~ We list just a single region, which is the entire contents of the ELF file +~ from disk, and we put the program header immediately after the file header. +~ The program we're building should call this word as the second output it +~ generates. +~ +~ It would be more typical to use this header to ask the loader to give us +~ separate code and data segments, and perhaps a stack or heap, but this keeps +~ things simple, and we can create those things for ourselves later. +~ +~ We do have a little stack space available, though we don't explicitly +~ request any; the kernel allocates it for us as part of exec() so that it can +~ pass us argc and argv (which we ignore). That stack space will be at a +~ random address, different every time, because of ASLR; that's a neat +~ security feature, so we leave it as-is. Note that ASLR doesn't happen when +~ you run under gdb, so if you aren't seeing it, that's probably why. + +~ ~~ +: elf-program-header + ~ : blank-line + ~ : ELF program header + ~ : indent + ~ * denotes mandatory fields according to breadbox + current-offset L!' elf-program-header + current-offset 3unroll + + 1 pack32 ~ : -4 *"loadable" segment type + 0x05 pack32 ~ : -4 *read+execute permission + 0 pack64 ~ : -8 *offset in file + L@' origin pack64 ~ : -8 *virtual address + ~ required, but can be anything, subject to alignment + 0 pack64 ~ : -8 physical address (ignored) + ~ : blank-line + + L@' total-size pack64 ~ : -8 *size in file + L@' total-size pack64 ~ : -8 *size in memory + ~ : blank-line + + 0 pack64 ~ : -8 segment alignment + ~ for relocation, but this doesn't apply to us + + ~ As with the file header, we use the label system to keep track of the + ~ program header's size. + current-offset 4 roll - L!' elf-program-header-size + L' elf-program-header-size set-label-non-offset + ~ : deindent + ; + + +~ This alternate version of the program header isn't used by evoke.e, but +~ may be useful for other programs, such as hex.e. Its only difference from +~ the base version is that it adds the write permission. +: elf-program-header-writable + ~ : blank-line + ~ : ELF program header + ~ : indent + ~ * denotes mandatory fields according to breadbox + current-offset L!' elf-program-header + current-offset 3unroll + + 1 pack32 ~ : -4 *"loadable" segment type + 0x07 pack32 ~ : -4 *read+write+execute permission + 0 pack64 ~ : -8 *offset in file + L@' origin pack64 ~ : -8 *virtual address + ~ required, but can be anything, subject to alignment + 0 pack64 ~ : -8 physical address (ignored) + ~ : blank-line + + L@' total-size pack64 ~ : -8 *size in file + L@' total-size pack64 ~ : -8 *size in memory + ~ : blank-line + + 0 pack64 ~ : -8 segment alignment + ~ for relocation, but this doesn't apply to us + + ~ As with the file header, we use the label system to keep track of the + ~ program header's size. + current-offset 4 roll - L!' elf-program-header-size + L' elf-program-header-size set-label-non-offset + ~ : deindent + ; + +~ ~~~~~~~~~~~~~~~~ +~ ~~ That's it! ~~ +~ ~~~~~~~~~~~~~~~~ +~ +~ ELF is a simple format, really. Now you can output your own machine code +~ that you generate however you want; make sure to define the labels "origin" +~ and "cold-start". Origin will control the address the code loads at; +~ cold-start will be the first thing that runs. The origin is arbitrary, but +~ can't be zero. + diff --git a/compilation/execution.e b/compilation/execution.e new file mode 100644 index 0000000..ecf5ec4 --- /dev/null +++ b/compilation/execution.e @@ -0,0 +1,593 @@ +~ ~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Execution model ~~ +~ ~~~~~~~~~~~~~~~~~~~~~ +~ +~ We use Forth-style dual stacks, one for values and one for control. We +~ use rsp for values, just like C does. We use rbp for the control stack, +~ which is a special Forth-y stack: These are pointers into the bodies of +~ Forth words, not return addresses. +~ +~ The choice of rsp and rbp for the stack pointers imitates Jonesforth; +~ I'm hopeful that it gives us convenient addressing modes, and will report +~ back about that when I feel that I understand the implications. +~ +~ In Forth, everything is a "word", including mutable variables. +~ Conceptually, a word is a unit of execution, which may be implemented +~ either in machine code or as an array of pointer to other words. +~ +~ This polymorphism is implemented by having each word's contents begin +~ with a "codeword", which is a pointer to machine code that "interprets" +~ the rest of the contents. In the case of words implemented in machine +~ code, the codeword points directly to that code, which is normally right +~ next to it. +~ +~ Variables, to Forth, are simply one more thing that can be executed; the +~ effect of executing a variable is to push its address onto the value +~ stack. +~ +~ We adopt this model of words, codewords, and variables-as-words. It's +~ really nice how it doesn't force anything else on us, not even a heap, +~ though we do end up using the log as a sort-of heap. +~ +~ We specifically implement a version of calling and returning that Forth +~ calls indirect threaded code: The control stack is a stack of pointers +~ into the middle of interpreted words. The interpreter snippet, called +~ docol, implements calling. Each word is responsible for making sure +~ returning works properly. Interpreted words accomplish this by ending with +~ the word "exit", while machine-code words accomplish it by ending with a +~ verbatim snippet called "next". +~ +~ Conceptually, "next" returns, but more specifically it accomplishes this +~ by doing the caller's next dispatch for it; thus control never actually +~ goes back to the caller's interpreter after initial setup. For performance +~ reasons, "next" is always inlined, so we define it as a macro. +~ +~ The docol routine is just ordinary code, not a macro. It's defined later +~ in this file, as a label. +~ +~ Notionally, we could consider not having a dictionary, and not giving +~ our words names. However, it feels silly to stop when we're so close to +~ being a full Forth, and using names for things solves a bootstrapping +~ problem related to log management - see the write-up of cold-start about +~ how the log is created, below. So, we add an additional header before the +~ codeword for this purpose. +~ +~ The Forth dictionary is usually a linked list of every word that has +~ ever been defined, with the newest at the head; the names of words are +~ stored in string fields, often right next to the link pointer. We adopt +~ this model, with the field sizes and order shown in the quick reference +~ below. We break with Forth tradition in one way: Rather than having a +~ length field, we use a null-terminated string. Thus, there's no length +~ limit on names. This necessitates breaking out the flags (to be explained +~ later) into their own byte, rather than taking bits from the length field +~ for them. +~ +~ There's an important performance consideration: Executable words +~ reference each other by pointers to their respective codewords. However, +~ dictionary entries reference each other by pointers to their respective +~ link fields. Traversing from the link field to the codeword is easy, +~ though it's a non-constant-time operation: Just walk the string. In order +~ to make Forth words easy to "decompile", it would be nice to also have a +~ way to traverse backwards. We solve this by making the name field be +~ null-terminated at both ends. Fun, yeah? +~ +~ +~ +~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ Quick Reference +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The layout of an interpreted word: +~ +~ (overall start) +~ 0x00 - 0x07 Link (to next-oldest word) +~ 0x08 - 0x08 HM00000I Flags +~ H - hidden +~ M - metadata +~ I - immediate +~ all other bits reserved +~ (name start) +~ 0x09 - 0x09 Null byte (terminates name) +~ 0x0a - name-end - 1 Name, as UTF-8 +~ name-end - name-end Null byte (terminates name) +~ (padding start) +~ name-end + 1 - codeword-start - 1 Zero-pad to 8-byte boundary +~ (it's possible this will be zero bytes long) +~ (codeword start) +~ ... + 0x00 - ... + 0x08 Codeword (ie. address of docol) +~ (8-byte chunks) Addresses of other words +~ - ... (end) Address of "exit" word +~ +~ The layout of a machine-code word is different only from the codeword on: +~ +~ ... + 0x00 - ... + 0x08 Addresss of next byte +~ ... + 0x08 - ???? Arbitrary machine code +~ - ... (end) Inlined implementation of next +~ +~ Also, words always start at 8-byte boundaries. +~ +~ +~ REGISTER usage conventions: +~ +~ * rsi is the "instruction pointer" for the "interpreter". +~ That is, it points to some word-pointer inside an array of +~ word-pointers inside the content of the word they're part of. It always +~ points to the next word that should be executed, whose execution hasn't +~ begun yet. +~ +~ * rbp points to the top of the control stack +~ These are former values of rsi, to eventually be returned to, from +~ successively older callers as you look further up the stack. The stack +~ grows downwards in memory. Since values are kept separately, the only +~ thing on the control stack is return addresses, one per layer of call. +~ +~ * rsp points to the top of the value stack +~ The value stack has no specific format, but it grows downwards in +~ memory. In particular there's no concept of stack frames, because items +~ on the stack don't belong to any particular word; the value stack in +~ Forth is in part a mechanism for passing values between words. +~ +~ Additionally, immediately after beginning execution of a word: +~ +~ * rax points to the address of the codeword being executed +~ The value of rax is purely for the callee's benefit, and does not need +~ to be preserved. +~ +~ Other registers are purely discretionary, and are not preserved across +~ calls. +~ +~ +~ FLAG usage: +~ +~ * DF should be 0 +~ We use lodsq extensively and that makes it increment rsi after using it. +~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +~ The macros next, beforenext, pushcontrol, and popcontrol are implemented +~ in language/static/execution-support.e. It's a good idea to go read about +~ them now. +~ +~ TODO the following high-level summary should go... somewhere? +~ When a docol word is invoked, it immediately does pushcontrol (see +~ execution-support.e) to push rsi onto the control stack, whose top is +~ indicated by rbp. When an assembly word is invoked, it leaves rsi and rbp +~ alone; assembly words don't normally call other words, so there's no need +~ for them to appear on the control stack at all. +~ +~ When an assembly word returns, it looks for an execution token pointed +~ to by rsi, increments rsi, and invokes that word as if calling it. This +~ is the threaded calling approach to Forth execution. When a docol word +~ returns, it calls exit, which needs to remove itself from the control +~ stack, so exit pops the top of the control stack into rsi to get back into +~ its caller's context, then does the same steps an assembly word would do. + + +~ Constants +~ ~~~~~~~~~ +~ +~ These are used in cold-start, just below. + +: log-requested-address 0x0000001000000000 ; ~ (very arbitrary) +: log-size 0x0000000001000000 ; ~ 16 MiB +: control-stack-size 0x10000 ; ~ 64 KiB + + +~ Routine cold-start +~ ~~~~~~~~~~~~~~~~~~ +~ +~ This is the entry point of the whole program, the very first code we +~ actually execute. Linkers traditionally call this _start, but let's live a +~ little. Anyway, the ELF header points to it and exec() jumps to it; from the +~ kernel's perspective, there's no such thing as names. Also, though this code +~ could be anywhere in the code part of the output, in order to make the +~ hexdump pretty we put it at the start. +~ +~ The kernel gives us most registers zeroed, and rsp pointing to the +~ command-line stuff (argc, argv, envp), which is at an ASLR'd address with +~ some stack space allocated for us, despite the fact we didn't request any. +~ It also gives us all the flags clear except IF, but we don't rely on that. +~ Lastly, of course, it loads our code segment and sets the instruction +~ pointer where we asked; we don't need to check what those addresses are, +~ because they're not randomized. +~ +~ Notably, though cold-start points rbp to the control stack, it leaves +~ the control stack empty, so trying to return will pop a value that doesn't +~ exist, and crash. Eventually, the bottom value on the control stack will +~ be the word "quit", which loops forever and is the closest thing Forth has +~ to a "main" word, but it's up to warm-start to make that happen. +~ +~ Cold-start is really only responsible for one-time initialization. +~ +~ +~ +~ Registers in: +~ +~ * rsp points to the logical top of the value stack +~ The kernel sets this up for us, and we need to save it somewhere so +~ Forth can use it. +~ +~ Registers out: +~ +~ * rsi points within "warm-start" +~ * rsp points to the top of the value stack +~ * rbp points to the top of the control stack +~ +~ Stack in: +~ +~ * argc, argv, envp in the usual Unix way +~ We ignore them, though. +~ +~ Stack out: +~ +~ * The value of "log", as a pointer +~ The meaning of this will be explained below. +~ +~ Registers within: +~ +~ * rdi points to the base the log was allocated at, once it exists +~ This is the same value that "log" will hold, once we reach a point +~ where we have variables. Of course, variables are stored on the log, +~ hence this temporary measure. +~ +~ We also take this opportunity to define soeme memory layout parameters +~ that this routine will be responsible for doing something with: +~ +~ (output memory start, current output point +~ -- output memory start, current output point) +: output-cold-start + ~ : blank-line + ~ : blank-line + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~ : blank-line + ~ : This is the start of the cold-start routine, which is the first code + ~ : of any kind the executable runs. It has the responsibility of creating + ~ : the Forth execution environment, then invoking the warm-start routine, + ~ : which is defined below. + ~ : blank-line + ~ : indent + + current-offset L' cold-start set-label + cld ~ clear the DF flag + + ~ Prepare the log. + ~ + ~ We could ask for a data segment in the program header, but where's the + ~ fun in that? Instead, we call mmap(). + ~ + ~ If we wanted the kernel to do ASLR for us, passing address zero would + ~ cause it to pick somewhere at random, but instead we choose our own + ~ location. It's still not guaranteed to be where we ask for, so we still + ~ do the work to record where it wound up. We could pass the "fixed" flag + ~ and the kernel would trust us, but this gives us more options for + ~ interoperating with other runtimes. + ~ + 9 :rax mov-reg64-imm64 ~ : mmap() + log-requested-address :rdi mov-reg64-imm64 + ~ : 0 address (very arbitrary) + log-size :rsi mov-reg64-imm64 ~ : size (one meg) + 0x07 :rdx mov-reg64-imm64 + ~ : 0 protection (read+write+exec) + 0x22 :r10 mov-extrareg64-imm64 ~ : flags (private+anonymous) + 0 :r8 mov-extrareg64-imm64 ~ : file descriptor (ignored) + 0 :r9 mov-extrareg64-imm64 ~ : offset (ignored) + syscall + + ~ The return value of the system call is in rax, we'll use it in a sec. + ~ We need to save this somewhere in case we ever want to munmap() it; + ~ there's no widely-used name for it so we have to make one up. S0 and r0 + ~ are widely-used names for the physical tops (logical bottoms) of the + ~ value and control stacks, respectively, and we will eventually set those + ~ up as well, so we should keep those names in mind. The control stack + ~ lives within the log, while the value stack is its own segment. This + ~ value, though, is the physical bottom of the segment, meaning that it + ~ stays the same even as we allocate and deallocate things within it. This + ~ is unlike the two stack pointers, so we give it a name that doesn't + ~ suggest similarity: "log". + ~ + ~ Once Forth is fully set up, its internal variables will be accessed + ~ through variable-words like any other Forth data, including "log". To + ~ get to that point, though, we need to be able to hold onto variable data + ~ between now and then. In fact, if we don't have at least one of "log" + ~ and "here" (its counterpart which points to the logical top end), all + ~ our efforts to hold onto anything seem a bit doomed. + ~ + ~ So, we temporarily dedicate rdi to "log" - only within this routine - + ~ and store everything else in ways that let us find things by reference + ~ to it. We choose rdi because it works with the indexing modes we care + ~ about, and its name suggests its function. + ~ + ~ The strategy Jonesforth uses is not applicable to us; Jonesforth + ~ takes advantage of the linker to let its code segment refer to specific, + ~ pre-allocated objects in the data segment. We are our own linker, and we + ~ don't care to have a data segment. Hence, this approach. + ~ + ~ Keying things off "log" is the fundamental decision, but to make sure + ~ our variables are accessible both during early bootstrapping, and later, + ~ we also have to be thoughtful about data structures. More on that in a + ~ moment. + ~ + :rax :rdi mov-reg64-reg64 + + ~ We also initialize rbp. We could hold off and let "quit" do this, but + ~ doing it now is the easiest way to initialize the r0 variable, since + ~ there's no instruction that moves a 64-bit immediate to memory. + ~ + ~ This is the moment at which we decide where the control stack starts! + ~ Fun, right? "Allocation" is just a fancy word for picking where we want + ~ something, then being consistent about it - like placing furniture in + ~ your home. See below for a little more thought about why here in + ~ particular. + ~ + :rdi control-stack-size :rbp lea-reg64-disp32-reg64 + + ~ Now we save some stuff onto the log. These are the locations that + ~ will eventually be the backing stores of the Forth variables, but we + ~ don't create the word headers yet, since there's no requirement that + ~ they be next to the backing stores. We'll do that later, once we have + ~ word-writing infrastructure in place. For now, we just use their offsets + ~ relative to the physical bottom of the log, which are fixed. + ~ + ~ These will be the permanent homes of these values, though we have + ~ copies of them elsewhere while we're still in this routine. + ~ + :rdi control-stack-size 0x00 + :rdi mov-reg64-disp32-reg64 ~ log + :rsp control-stack-size 0x08 + :rdi mov-reg64-disp32-reg64 ~ s0 + :rbp control-stack-size 0x10 + :rdi mov-reg64-disp32-reg64 ~ r0 + L@' final-word-name :rax mov-reg64-imm64 + :rax control-stack-size 0x18 + :rdi mov-reg64-disp32-reg64 ~ latest + :rdi control-stack-size 0x28 + :rax lea-reg64-disp32-reg64 + :rax control-stack-size 0x20 + :rdi mov-reg64-disp32-reg64 ~ here + ~ + ~ * "log" is the physical bottom of the log + ~ The log grows upwards in memory, so this is also the logical + ~ bottom. This comes from the address mmap() just returned to us. + ~ * "s0" is the logical bottom of the value stack + ~ The value stack grows downwards in memory, so this is the physical + ~ top of it. This comes from the stack pointer the kernel initialized us + ~ with. + ~ * "r0" is the logical bottom of the control stack + ~ The control stack also grows downwards, so this is its pysical top + ~ as well. We allocate this dedicated space within the log right here, + ~ in this routine, through our choice of where to put things. + ~ * "here" is the physical start of the unallocated space in the log + ~ We allocate log space from bottom to top, by incrementing this + ~ value. So, it would also be accurate to say that it points immediately + ~ after the physical top of the allocated space. At any rate, the + ~ address it points to is the first one that hasn't been used yet. + ~ * "latest" is the address of the most-recently-defined word's header + ~ Defining new words changes this value. + ~ + ~ s0 and r0 are mostly used when we want to initialize or reinitialize + ~ their respective stacks - that is, discard all their contents at once. + ~ + ~ The value of r0 is the same address these variables start at, so + ~ you'll want to do a close read of the implementation of pushcontrol + ~ and convince yourself that it only ever writes things just below the rbp + ~ address it receives, never right on top of it. + ~ + ~ As an aside, by the way, please notice that strictly speaking, r0 + ~ could be a constant... but it isn't known until runtime, so we might as + ~ well make it a variable. That will play nicely with any astonishing + ~ memory shenanigans someone might wish to do in the future. + ~ + ~ Notice also that "here" points immediately after itself. This is just + ~ a convenience, making it the last one like that so that the concern is + ~ dealt with in a single place and is easy to keep up-to-date with code + ~ changes. + ~ + ~ A little more detail about why we offset everything by + ~ control_stack_size: We're carving out some space at the bottom of the + ~ log - which grows low-to-high - to be the control stack - which grows + ~ high-to-low. So the control stack is allocated out of the log as a + ~ fixed-size, one-time thing, and then the variables come immediately + ~ after that. We do need to use 32-bit displacement indexing to access + ~ them this way, but that's no big deal. + ~ + ~ This is perhaps questionable, they should maybe be separate segments + ~ created with separate calls to mmap(), but for now we're not worried + ~ about overflow so we use the same allocation for both. + ~ + ~ We'll come back to these variables a bit later and generate the word + ~ headers that point at them, but now we're almost ready to switch to + ~ proper threaded-execution, so we finish that setup first... + + ~ Push the value of "log" onto the value stack so that it can be the + ~ breadcrumb the threaded code needs to find... the backing store of + ~ "log". Yes, self-reference can be weird like that sometimes. There's + ~ nothing stopping "quit" from reading rdi, it just violates the + ~ abstraction... + :rdi push-reg64 + + ~ We are about to set up rsi, we did rbp already, and rsp came to us + ~ already set up. That's all that "next" needs, so take it away! + L@' warm-start L@' origin + :rsi mov-reg64-imm64 + pack-next + ~ : deindent + ; + + +~ Routine warm-start +~ ~~~~~~~~~~~~~~~~~~ +~ +~ This routine runs as Forth code. That is, indirect threaded execution has +~ been initialized, and the structure of this routine is an array of codeword +~ pointers. It was directly jumped to from cold-start. There's nowhere to +~ return to, so it needs to never return. +~ +~ (output buffer start, output point, input string pointer +~ -- output buffer start, output point) +: output-warm-start + ~ : blank-line + ~ : blank-line + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~ : blank-line + ~ : This is the start of the warm-start routine, which is the first Forth + ~ : code the executable runs, after the cold-start routine has created the + ~ : Forth execution environment. + ~ : + ~ : It does some initial setup here at the top; then the vast bulk of it + ~ : is actually the log-load routine, directly included; then finally there + ~ : is a small amount of finishing work done at the tail end of the + ~ : warm-start routine. + ~ : + ~ : The routine's body is interpreted Forth code, meaning that it is an + ~ : an array of pointers to the codewords of Forth words, occasionally + ~ : interspersed with literal values. + ~ : + ~ : The codeword pointers were located by using the label system, which + ~ : means the labels they reference must have been defined somewhere else, + ~ : normally by the label transform. The label-transformed code normally + ~ : occurs after the warm-start routine in the executable, which means these + ~ : are forward references to words defined far below. + ~ : blank-line + ~ : indent + + ~ While it's not actually a requirement that codeword pointers be + ~ word-aligned, it's highly likely that it helps performance. (Whether it + ~ does is up to Intel's microcode.) + 3unroll + 8 packalign + current-offset L!' warm-start + ~ (input string pointer, output buffer start, output point) + + ~ Before handing off to us, cold-start pushed a single value onto the + ~ stack, a pointer to the beginning of the log. Now, we load our entire + ~ Forth implementation onto that log, beginning with the minimal set of + ~ words needed to define more words. We do this because we need variables as + ~ infrastructure so we can eventually have dynamic definitions. + ~ + ~ There's something non-obvious here: words implemented statically as + ~ part of the executable image can't contain things that vary at runtime. + ~ That means that even if these words tried to implement some sort of + ~ dynamic lookup, they would have no way to find the root of whatever + ~ dynamic data structure they use. Dynamism needs to be bootstrapped. + ~ + ~ In a more traditional C-style program, static code could look up + ~ variables based on fixed addresses that are the same on every run. + ~ Failing that, we could dedicate a register to it, though that's a + ~ considerable expense. We chose not to do either of those things, because + ~ we want the versatility that comes with not being picky about our + ~ address space: It allows us to contemplate future improvements such as + ~ ASLR, or embedding into other processes that impose their own addressing + ~ constraints, or even coexisting with multiple versions of ourselves. + ~ That choice does mean we have the hard version of this bootstrapping + ~ problem, and copying ourselves to the log is how we solve it. + ~ + ~ We do have the log address right now, though that won't last. In case + ~ it's unclear why not: keeping it on the stack would require all future + ~ references to walk the stack, and somehow know when they've reached the + ~ bottom. The stack is a good place to keep things with clearly delimited + ~ lifetimes and visibility, but when we want something to live for our + ~ entire program and be easy to find from any code within it, we need to + ~ do something else. Anyway, since we have the address, we can use it for + ~ the next little bit of setup. We have a bunch of helper words, from + ~ language/static/log-load.e, which make this easier. + ~ + ~ The first few words we define are our variables, which hardcode the + ~ addresses they will return - but since we're doing this at runtime, + ~ "hardcoding" can reflect where our log is. This is the fundamental + ~ trick that makes the log usable. + ~ + ~ One more thing to notice: We already allocated the backing stores of + ~ these variables, and populated their initial values, in cold-start. The + ~ words we're defining return those same addresses for the same backing + ~ stores. So, we have continuity: Stuff defined in terms of the + ~ variable-words we're defining now will interoperate with the stuff that + ~ we define using the log-load helpers, which includes those very words. + ~ Both the log-load code and the later code are dealing with the same data + ~ structures, they're just using a different technique to find them. + ~ + ~ This is the only hardcoding we need to do; by building on top of it, + ~ we will soon reach a point where the rest of the system can be defined + ~ within itself. + + L@' log-load-log offset-to-target-address-space pack64 + ~ : -8 log-load-log #-- (codeword pointer) + L@' litstring offset-to-target-address-space pack64 + ~ : -8 litstring #-- (codeword pointer) + s" log" packstring 8 packalign + L@' log-load-variable offset-to-target-address-space pack64 + ~ : -8 log-load-variable #-- (codeword pointer) + + L@' log-load-s0 offset-to-target-address-space pack64 + ~ : -8 log-load-s0 #-- (codeword pointer) + L@' litstring offset-to-target-address-space pack64 + ~ : -8 litstring #-- (codeword pointer) + s" s0" packstring 8 packalign + L@' log-load-variable offset-to-target-address-space pack64 + ~ : -8 log-load-variable #-- (codeword pointer) + + L@' log-load-r0 offset-to-target-address-space pack64 + ~ : -8 log-load-r0 #-- (codeword pointer) + L@' litstring offset-to-target-address-space pack64 + ~ : -8 litstring #-- (codeword pointer) + s" r0" packstring 8 packalign + L@' log-load-variable offset-to-target-address-space pack64 + ~ : -8 log-load-variable #-- (codeword pointer) + + L@' log-load-latest offset-to-target-address-space pack64 + ~ : -8 log-load-latest #-- (codeword pointer) + L@' litstring offset-to-target-address-space pack64 + ~ : -8 litstring #-- (codeword pointer) + s" latest" packstring 8 packalign + L@' log-load-variable offset-to-target-address-space pack64 + ~ : -8 log-load-variable #-- (codeword pointer) + + L@' log-load-here offset-to-target-address-space pack64 + ~ : -8 log-load-here #-- (codeword pointer) + L@' litstring offset-to-target-address-space pack64 + ~ : -8 litstring #-- (codeword pointer) + s" here" packstring 8 packalign + L@' log-load-variable offset-to-target-address-space pack64 + ~ : -8 log-load-variable #-- (codeword pointer) + + ~ Having done that, nothing else needs to be defined in an unusual way, so + ~ we can go ahead and dispatch to the log-load transform, and do the rest of + ~ the code through that. + + ~ (input string pointer, output buffer start, output point) + 3roll log-load-transform + ~ (output buffer start, output point) + + ~ : blank-line + ~ : We're now done with the log-load routine; the next little bit of code + ~ : here is the final bit of the warm-start routine. + + ~ Now everything we need has been added to the log and we're almost ready + ~ to jump into it. It's inconvenient for code under the log-load transform + ~ to interact with the label system, so if we want to point + ~ main-input-buffer at a string, this is the place to do it. + + ~ The next layer is built now, so let's move on to it. + L@' litstring offset-to-target-address-space pack64 + ~ : -8 litstring #-- (codeword pointer) + s" quit" packstring 8 packalign + L@' log-load-find-execution-token offset-to-target-address-space pack64 + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + L@' swap offset-to-target-address-space pack64 + ~ : -8 swap #-- (codeword pointer) + ~ : Get rid of that heap pointer on the stack, we're finally done with it! + L@' drop offset-to-target-address-space pack64 + ~ : -8 drop #-- (codeword pointer) + L@' execute offset-to-target-address-space pack64 + ~ : -8 execute #-- (codeword pointer) + ~ : deindent + ; + + +~ Where next? +~ ~~~~~~~~~~~ +~ +~ The definitions of "docol" and "exit" are very tightly bound up with the +~ execution model. They're defined and explained in language/static/core.e, +~ because they need to be part of the build process in two different ways, +~ like the other core functionality. + diff --git a/compilation/labels.e b/compilation/labels.e new file mode 100644 index 0000000..2a02a4c --- /dev/null +++ b/compilation/labels.e @@ -0,0 +1,296 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Machine label facility ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Compilers and assemblers always have a need to resolve symbolic names for +~ parts of their code to numeric values. Usually, these symbolic names are +~ called labels. +~ +~ It's a surprisingly deep problem. The output itself can end up depending +~ on the actual values, for a variety of reasons. For example, the size of +~ a relative-jump instruction may vary depending on how far away its target +~ is, which changes the position of everything after. Or, there may be a size +~ limit on some particular segment and code may have to be entirely +~ reorganized to make things fit, splitting it into pieces or adding +~ trampolines. +~ +~ Often, this winds up being a hidden layer with immense complexity, +~ implemented as part of a linker, that even compiler maintainers find obscure +~ and confusing. +~ +~ It's Irenes' position that we should engage with complexity rather than +~ encysting it. So, in Evocation we take a different approach, heavily +~ inspired by the semantics of a tool called flatassembler. We provide +~ downstream code with the basic operations set-label and use-label which it +~ can combine in whatever order it wants. We also provide a harness, +~ label-loop, which takes an execution token for the downstream code +~ generator and runs it over and over, computing the mathematical fixed point +~ of the label assignments. +~ +~ On the first pass, label-loop guesses a value of zero for any label that's +~ used before it's set. On subsequent passes, each label starts with the value +~ it had on the previous pass. When we have a pass where labels end with the +~ same value they started with, we say they've converged, and we announce +~ success. If a hundred passes go by without convergence, we fail instead. +~ +~ Importantly, the label facility does not have an opinion on where or how +~ the values of labels should be output, nor does it have concepts of +~ dependency tracking or topological sorting. It only cares about the sequence +~ of set- and use-operations. Code relying on the facility is free to make +~ arbitrarily complex decisions about the layout, size, contents etc of its +~ output, and to use label values as part of those decisions. It is the +~ responsibility of this relying code to ensure the process converges, by +~ whatever means it wishes. +~ +~ Since the label facility is not directly involved in output, it is also +~ permissible for code relying on it to make retroactive changes to the +~ output, as long as all such changes are completed before returning control +~ to label-loop. +~ +~ Most of the time, the shorthand words L@' and L!' will be all you need to +~ use from your own code. + +~ The labels data structure is a linked list of dictionary entries, with +~ the same header format as the main Evocation dictionary, but instead of +~ being executable, each holds two words of data: status bits, and a value, +~ in that order. There's no "docol" pointer or anything of the sort. +~ +~ Status is a bit field: +~ bit zero is whether it's been used +~ bit one is whether it's been defined +~ bit two is whether it was used before being defined +~ bit three is whether the guessed value wound up equaling the actual value +~ +~ Just as the Evocation dictionary uses the global variable "latest" as a +~ handle (a pointer to a pointer) beginning a linked list of entries, so the +~ label dictionary also uses a handle variable, named "labels". We initialize +~ it here. +8 allocate s" labels" variable 0 labels ! + +~ This is analogous to word-heading, but prints label information. +~ (entry pointer --) +: label-heading + dup entry-to-name dup emitstring space + stringlen 1+ 54 swap - 0 max indent + entry-to-execution-token dup 8 + @ .hex64 space @ .hex8 + newline ; + +~ This prints the headings for all the labels that have been created. Note +~ that labels that have been created once stay in the dictionary forever, even +~ if subsequent passes neither use nor define them. That's because the control +~ loop has no way to know if they're still important; it's up to downstream +~ code to decide that. Everything has been carefully set up so that disused +~ labels don't hurt anything. +: list-labels + labels oldest-entry-in { dup } + { dup label-heading labels next-newer-entry-in } while drop ; + +~ This looks up a label by name if it exists, or returns 0 if it doesn't. +~ The return value if it's found is an entry pointer. +~ +~ Keep in mind that this is a pointer to the entry in the label dictionary, +~ not the label's value. It's common for a label's value to itself be a +~ pointer to a dictionary entry, in the program being compiled, so it's easy +~ to confuse that. +~ +~ (name string pointer -- label entry pointer) +: find-label labels swap find-in ; + +~ This creates a new label given a name for it, initializing its value and +~ status to zero and adding it to the label dictionary. This is responsible +~ for the initial guess of zero on the first pass. +~ +~ (name string pointer -- ) +: new-label labels create-in 0 , 0 , ; + +~ These helpers take a label entry pointer and return pointers to the status +~ and value fields. +: label-status entry-to-execution-token ; +: label-value entry-to-execution-token 8 + ; + +~ This looks up a label by name if it exists, or creates it if it doesn't. +~ Either way, it returns an entry pointer. It's named after the function +~ "intern" that many Lisp dialects have. +~ +~ (name string pointer -- label entry pointer) +: intern-label + dup find-label + dup { swap drop } + { drop dup new-label labels swap find-in } if-else ; + +~ This returns the value of a label, also doing all necessary status checks +~ and updates to keep track of the circumstances under which it was used. The +~ label loop relies on all read accesses going through this word. +~ +~ (label entry pointer -- label value) +: use-label + ~ If it hasn't been defined yet, mark it used-before-set. + dup label-status dup @ dup 0x02 & not + { 0x04 | swap ! } { drop drop } if-else + + ~ Mark it used. It's faster to just do this than to check if it's needed. + dup label-status dup @ 0x01 | swap ! + + ~ TODO putting a provide-label magic comment command here would be lovely + + ~ Return the guessed value. + label-value @ ; + +~ This overwrites the value of a label, also doing all necessary status +~ checks and updates to keep track of the cirumstances under which it was +~ set. The label loop relies on all write accesses going through this word. +~ +~ (new label value, label entry pointer --) +: set-label + dup label-status @ + ~ (new value, entry, initial status) + + ~ Exit, and print a diagnostic, if the label was already set on this pass. + ~ + ~ Without cooperation from user code, there's no great way to communicate + ~ up the call stack that execution should stop, so we don't try to. + dup 0x02 & { drop swap drop + ." Failed by attempting to redefine " + entry-to-name emitstring newline exit } if + + ~ We always set the defined bit to true. We leave the other status bits + ~ as-is, except that we check whether it's unused up to now, and whether + ~ the previous value equals the new value. If either of those holds, we set + ~ the guessed-equals-actual bit to true. + 0x02 | + ~ (new value, entry, updated status) + 3unroll dup 4 unroll label-value @ swap dup 3unroll = + ~ (entry, updated status, new value, equality) + 3roll dup 4 unroll 0x01 & not + ~ (entry, updated status, new value, equality, unused) + || { swap 0x08 | swap } if + ~ (entry, updated status, new value) + 3roll dup 3unroll + ~ (updated status, entry, new value, entry) + label-value ! label-status ! ; + +~ Since labels have dictionary entry headers but aren't in the main +~ dictionary, we get to use the entry flag bits for other things. The only one +~ we have right now is a feature that acts as a hint to anything trying to +~ display metadata about labels, to the effect that this one represents +~ something other than an offset in the file. +~ +~ (label entry pointer --) +: set-label-non-offset dup entry-flags@ 0x01 | swap entry-flags! ; +~ (label entry pointer -- boolean) +: is-label-non-offset entry-flags@ 0x01 & ; + +~ This is a convenience helper which downstream code can use to check how +~ many bytes it has output thus-far. +~ (output memory start, current output point +~ -- output memory start, current output point, offset) +: current-offset 2dup swap - ; + +~ This is a concise syntax for referencing the entry pointer of a label, +~ when you know its name statically. It reads a word of text input and calls +~ intern-label on it. +: L' + word value@ + interpreter-flags @ 0x01 & + { ' litstring entry-to-execution-token , + here @ swap packstring 8 packalign here ! + ' intern-label entry-to-execution-token , + dropstring } + { intern-label dropstring-with-result } if-else + ; make-immediate + +~ This is a concise syntax for calling use-label with a label whose name +~ you know statically. It performs L', then calls use-label. +: L@' + ' L' entry-to-execution-token execute + interpreter-flags @ 1 & + { ' use-label entry-to-execution-token , } + { use-label } if-else + ; make-immediate + +~ This is a concise syntax for calling set-label with a label whose name +~ you know statically. It performs L', then calls set-label. +: L!' + ' L' entry-to-execution-token execute + interpreter-flags @ 1 & + { ' set-label entry-to-execution-token , } + { set-label } if-else + ; make-immediate + +~ This is an internal helper that label-loop uses to check if a specific +~ label entry has "converged", based on its status bits. Downstream code won't +~ need to call this directly. +~ +~ For a label to have "converged", at least one of the following must be +~ true: +~ +~ 1. The label must never have been used (bit zero clear); +~ 2. The label was both used and defined, but not used before it was defined +~ (bits zero and one set; bit two clear); +~ 3. The label was both used and defined, and the guessed value equalled the +~ actual value (bits zero, one, and three set). +~ +~ (label entry pointer -- boolean) +: check-label-converged + label-status @ + dup 0x01 & not swap + dup 0x03 & 0x03 = swap dup 0x04 & not swap 3unroll && swap + 0x0b & 0x0b = + || || ; + +~ This is an internal helper that label-loop uses to check if the overall +~ label assignments have converged, based on their status bits. Downstream +~ code won't need to call this directly. +~ +~ This returns true if and only if check-label-converged returns true for +~ all the labels that have been created. +~ +~ (-- boolean) +: check-labels-converged + 1 + labels @ { dup } + { dup check-label-converged 3roll && swap + @ } while drop ; + +~ This is an internal helper that label-loop calls between passes, to update +~ the status bits and get ready for the next one. Downstream code won't need +~ to call this directly. +~ +: reset-labels + labels @ { dup } + { dup label-status 0 swap ! + @ } while drop ; + +~ This is the top-level word that invokes the entire label system. All the +~ code generation happens inside it. +~ +~ The execution token it's passed should have the interface: +~ +~ (output start, current output pointer +~ -- output start, current output pointer) +~ +~ In general, this is the same interface that code generation words should +~ use to communicate with each other. For example, all the words in +~ compilation/elf.e use this interface. +~ +~ (execution token -- output start, output length) +: label-loop + 0 swap + ~ TODO every time you double this to fix a crash, you must publicly + ~ apologize for deferring a real fix. those are the rules + 0x80000 allocate dup + ~ (iteration count, execution token, output start, output point) + { 3 pick 100 > } + { 2 pick execute 4 roll 1+ 4 unroll + + check-labels-converged + { 4 roll drop + 3 roll drop + current-offset swap drop + exit } if + drop dup + reset-labels } while + ~ TODO run some analysis on the labels to detect labels that are never + ~ defined, but are referenced. List them. + drop drop drop ." Failed after " . ." iterations." newline ; + diff --git a/compilation/transform.e b/compilation/transform.e new file mode 100644 index 0000000..80ef98b --- /dev/null +++ b/compilation/transform.e @@ -0,0 +1,6512 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Code transformation facility ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The process of producing an executable binary out of Evocation involves +~ various bootstrapping phases during which code operates under different +~ constraints, and must be written with different styles. In some cases, +~ substantially the same code must be output multiple times in slightly +~ different ways, and it would be both arduous and verbose to write each of +~ these directly. +~ +~ To solve this problem, this file implements a concept of code +~ transformation. There are two transforms, the label transform and the +~ log-load transform, each of which takes a string containing Evocation source +~ code and produces compiled code that has been modified to operate in a +~ specific way. The transforms rely on the label facility provided by +~ compilation/labels.e, and expect to run from within label-loop. +~ +~ The label transform produces code that uses one label per word it defines, +~ to statically reference everything. Thus, when output to an executable +~ binary, this code will function without external dependencies. The tradeoff +~ is that it has no way to reference data that exists only at runtime. +~ +~ The log-load transform relies on labels, but doesn't add any of its own. +~ It produces a compiled routine which, when run, dynamically looks up all the +~ references in the log, and appends the original code to the log. This adds +~ work that must be done when the runtime starts up, but the benefit is that +~ it can reference data that doesn't exist at compile-time. Most crucially, +~ it can reference the "here" and "latest" pointers in the log, which are +~ required for all the usual word-definition stuff to work, and whose +~ addresses are not known until runtime. +~ +~ The log-load transform may also be useful for experimental tasks such as +~ creating additional, independent logs, or injecting Evocation into another +~ process's address space. +~ +~ Please notice that both these transforms, in different ways, navigate the +~ same underlying design tension: The Forth compilation model hardcodes +~ references at the time compilation happens, and Evocation makes the choice +~ to not decide the address of the log until runtime. Thus the label transform +~ can't be sufficient on its own. Other Forths avoid this problem by +~ hardcoding an address for the log, or by using OS-provided load-time +~ symbol relocation. Evocation, however, does it on hard mode, mostly for fun. +~ +~ Because it was clear from early on that the label transform couldn't stand +~ alone, and that another one would be necessary, we've refrained from adding +~ too many features to it. Since we have multiple transforms, they should each +~ be kept simple and well-defined, so that they can be composed in creative +~ new ways down the line. When adding additional behavior, always give thought +~ to whether it belongs in an existing transform or a new one. +~ +~ +~ About the label transform +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The label transform operates on code that compiles itself, and ensures +~ that the result of the compilation is suitable to be included in an +~ executable binary as words that are statically referenced by their +~ addresses. To achieve this, it causes each newly-defined word to have a +~ corresponding label whose value is the offset of its codeword, and it causes +~ all compiled invocations of other words to be resolved by using these labels. +~ The label transform is suitable for code that must be directly invoked by +~ the warm-start routine provided by compilation/execution.e. +~ +~ The most fundamental technique the label transform performs is to separate +~ words that run in compile mode from words that run immediately. There is no +~ distinction made between words running in immediate mode, and words declared +~ as immediate. Immediate words are looked up and executed based on their +~ "real", currently-executing definitions. Compiled words, including +~ literals, are looked up via the label facility. +~ +~ Since the label facility is able to resolve forward references, there is +~ no hard requirement that everything in the file be topologically sorted. +~ However, the transform will refuse to create forward references to compiled +~ words. If you want them, you can create them by hand by calling use-label +~ yourself. This restriction is in place because allowing forward references +~ would be a significant difference from un-transformed code that could easily +~ become confusing, and because it simplifies the implementation a bit. +~ +~ Compilation words do make extensive reference to the global variables +~ "here" and "latest". In particular, flow-control words such as if-else +~ expect the log to have recent compilation outputs on it, and to be able to +~ mutate them in-place. In order to make this work, we provide temporary +~ values of these two variables which point to the location of the output +~ buffer. This allows pointer resolution to work correctly without additional +~ effort, but notice that the buffer's address will differ from the address +~ the resulting program loads itself at. There's no simple way to avoid this +~ concern, since the variables must point to one of those addresses or the +~ other, not both. +~ +~ We resolve the issue by running our own, alternate versions of most of the +~ critical word-defining words, including for example "create", ":", and ";". +~ These alternates run instead of the normal versions of these words, and use +~ the label facility to compute the addresses that will be needed at runtime. +~ The code being compiled is responsible for not doing anything else that +~ would rely on "here" and "latest" matching their runtime addresses, though +~ it is otherwise allowed to modify and rely on them in all the usual ways. +~ The alternate versions are defined in this file as their own words, +~ "label-create-alternate" and so on. +~ +~ Note that these alternates are applied via a purely lexical +~ transformation: when a word would be looked up in the dictionary to +~ interpret, first check if it's one of these. That means the transformation +~ won't apply to indirect callers of these words, nor to tick-quotes of them. +~ The code being compiled is responsible for not doing either of those things. +~ +~ Notably, the transformation uses the same "interpreter-flags" variable as +~ the rest of Evocation. There's no need to keep it separate like there is +~ with the other variables. This makes it easy to change modes. +~ +~ The label transformation and its alternates rely on various labels, all of +~ which must be defined elsewhere, lest the label loop fail to converge: +~ "lit", "origin", "docol", "exit", ":", ";", and ";asm". +~ +~ All of these limitations result in the compiled code being, in effect, +~ written in a dialect which is like Evocation, but more restricted. This is +~ acceptable, because the label transform is intended for compiling code that +~ is an early part of Evocation itself, and the necessary code has all been +~ written to follow these restrictions. +~ +~ +~ About the log-load transform +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The log-load transform also operates on code that compiles itself; it +~ produces a compiled routine which, when run, appends the original code to +~ the log. As the routine is run, each reference to another word is resolved +~ by looking up the name of the target word in the log. Furthermore, these +~ lookups are done using log-load-find, defined in language/static/log-load.e, +~ which accepts a pointer to the log's base address as a parameter. See that +~ file for more explanation of what the log is and why it's important. Thus, +~ unlike normal accesses to the log, this routine doesn't rely on already +~ having the log's base address hardcoded into it at the time of its own +~ compilation. The log-load transform is suitable for implementing the core +~ responsibilities of the warm-start routine provided by +~ compilation/execution.e, relying on only a few specific words that it +~ statically references via labels. +~ +~ Much like the label transform, the log-load transform provides alternate +~ versions of certain immediate words used in word definition. Also like the +~ label transform, it provides its own copies of "here" and "latest". +~ +~ The log-load transform provides alternates for a significantly broader set +~ of words than the label transform, including all the flow-control words such +~ as if-else. It runs its own alternates immediately, but unlike the label +~ transform, immediate execution for the log-load transform is not actually +~ immediate; it is compiled into words which will have those immediate effects +~ at the time the generated routine is run. The generated routine can itself +~ be thought of as a compilation process, producing its output on the log, so +~ doing things later for us still means doing them immediately during the +~ routine. +~ +~ The log-load transform does impose a no-forward-references requirement, +~ though it is applied at the time the routine is run, rather than at the time +~ of the transformation. +~ +~ The log-load transformation and its alternates rely on the following +~ labels, all of which must be defined elsewhere: TODO +~ +~ +~ About the hex transform +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The hex transform's role is a bit different. Whereas the label and +~ log-load transforms are used as part of generating an executable binary, the +~ hex transform produces a commented hex dump that, when later processed by +~ the "hex" tool, produces that same binary. It achieves this by modifying +~ various words which are core parts of Evocation to keep track of appropriate +~ comments and other metadata, and modifying the output facility to output a +~ hex dump with any attached comments, rather than raw bytes. +~ +~ By its nature, the hex transform needs to be able to cope with other +~ transforms running inside itself; that is, the transformation facility needs +~ to be reentrant. The other transforms don't have to cope with that, since +~ the code they run is mostly just about creating word definitions, but the +~ code given to the hex transform will normally include a call to label-loop, +~ all the memory manipulation that happens as part of binary generation, and +~ various output words. +~ +~ While the label and log-load transforms allow Evocation to be a +~ self-hosting compiler, the hex transform attains the even higher bar of +~ making Evocation a "self-bootstrapping" compiler, able to create a running +~ copy of itself without having any sort of pre-existing compiler at all, only +~ a hex converter or similar small tool. The idea is that the hex converter is +~ small and simple enough that it's easy to perform a BINARY audit on, and +~ that there need be no other binary artifacts in the chain of trust. +~ +~ This is not a new concept, but as far as Irenes are aware this name for it +~ is a new coinage. The approach of using a hex-to-binary conversion tool as +~ the initial bootstrapping stage is due to MesCC, which is quite inspiring in +~ that regard. +~ +~ The key insight is that, some sense, the difference between source code +~ and binary is the ability to have comments. +~ +~ The hex transform keeps some large, complex state as it runs, unlike the +~ label and log-load transforms, which only require very simple state. This +~ state is called the "output metadata". Entries in the output metadata are +~ created and modified as the code under transform runs, by "magic comments" +~ embedded within it. There is a complex command language for these comments, +~ which must be understood to write code designed to make good use of the hex +~ transform. Fortunately, that's really just assembly-language +~ implementations. +~ +~ It's quite an intense topic, and many readers may wish only to know that +~ the hex transform exists, not how it's structured. So, details on the output +~ metadata and the magic comments are described below, under "hex transform +~ implementation", rather than here. +~ +~ The hex transform DOES NOT WORK yet. It's still in development. +~ TODO update this note when it does work + + +~ Address-management helpers +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The facilities in this section are used as helper code in the +~ implementations of all three transforms. + + +~ We have a bunch of accessors for the transformation state structure, which +~ are all functions from pointers to pointers. We also define a global +~ variable which points to the transformation state. +: transformation-state-saved-here ; +: transformation-state-saved-latest 8 + ; +: transformation-state-output-buffer-start 2 8 * + ; +: transformation-state-user-stack-depth 3 8 * + ; +: transformation-state-label-scratch 4 8 * + ; +: transformation-state-output-metadata 5 8 * + ; +: allocate-transformation-state + 6 8 * allocate + dup transformation-state-saved-here 0 swap ! + dup transformation-state-saved-latest 0 swap ! + dup transformation-state-output-buffer-start 0 swap ! + dup transformation-state-user-stack-depth 0 swap ! + dup transformation-state-label-scratch 0 swap ! + dup transformation-state-output-metadata 0 swap ! ; +allocate-transformation-state s" transformation-state" variable + + +~ When calling the label facility during a transformation, it's necessary +~ to use the real, non-wrapped "here" and "latest". +: swap-transform-variables + here @ transformation-state transformation-state-saved-here @ + here ! transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest @ + latest ! transformation-state transformation-state-saved-latest ! ; + +~ We deal with a few address spaces. There's the "host" address space, the +~ space this process performing the compilation is using for itself. There's +~ the "target" address space, the address space that will exist later, when +~ the program we've compiled is running. +~ +~ Then there's "offsets", which are relative to the start of the output +~ buffer. For clarity's sake, we always refer to these as offsets, rather than +~ as addresses. +~ +~ When we define labels for compiled words, we set their values to be +~ offsets pointing to the generated codeword. This is done by +~ label-create-alternate. We then need to convert them either to the host or +~ the target address space, depending on how we're using them. +~ +~ There's no approach here that isn't confusing, but the hope is that by +~ using offsets, so that we always have to convert them regardless of what +~ we're doing with them, we won't miss a spot where conversion needs to +~ happen. +~ +~ (output offset -- target address) +: offset-to-target-address-space + ~ Don't transform null pointers. + dup { swap-transform-variables L@' origin swap-transform-variables + } if ; + +~ (target address -- output offset) +: target-address-space-to-offset + ~ Don't transform null pointers. + dup { swap-transform-variables L@' origin swap-transform-variables - } if ; + +~ (output offset -- host address) +: offset-to-host-address-space + ~ Don't transform null pointers + dup { transformation-state transformation-state-output-buffer-start @ + } if ; + +~ (host address --output offset) +: host-address-space-to-offset + ~ Don't transform null pointers + dup { transformation-state transformation-state-output-buffer-start @ - } if ; + +~ (host address inside the output buffer -- target address) +: host-address-space-to-target + host-address-space-to-offset offset-to-target-address-space ; + +~ (target address -- host address) +: target-address-space-to-host + target-address-space-to-offset offset-to-host-address-space ; + + +: describe-transformation + ." active here " here @ .hex64 space + ." latest " latest @ .hex64 newline + ." saved here " transformation-state transformation-state-saved-here + @ .hex64 space + ." latest " transformation-state transformation-state-saved-latest + @ .hex64 newline + ." output start " + transformation-state transformation-state-output-buffer-start + @ .hex64 newline + ." user stack depth " + transformation-state transformation-state-user-stack-depth + @ .hex64 newline ; + + +~ User stack depth tracking helper +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The transformation facility offers a feature which specific transforms can +~ use, or not, as they prefer, called user stack depth tracking. The log-load +~ transform uses it; the label transform does not. The most difficult part of +~ the tracking is the heler word below; it also relies on the user-stack-depth +~ field of the transformation-state variable. +~ +~ What does user stack depth mean? Well, for every transform there's some +~ notion of running a word "immediately"; for the log-load transform, it means +~ that the word runs at the time the generated log-load routine executes. Each +~ time a word runs, it interacts with the value stack in some way. Some words +~ are neutral; others result in a net increase or decrease in its depth, which +~ we call the delta. The running total of these deltas is what we call the +~ user stack depth. By "user" we mean that these are values which were created +~ by and for the code being transformed, which the code doing the transforming +~ must be careful not to interfere with. +~ +~ Why do we need to do this? Recall that the log-load routine is given the +~ log address as the only value on the stack when it begins, and any time it +~ does something that requires looking at the log, it needs to be able to find +~ that address. The log-load routine runs as part of the warm-start routine +~ (see compilation/execution.e), whose overall job is to get Evocation into a +~ state where it can freely work with dynamically-allocated data on the log +~ whose address isn't known at compile time. Therefore, necessarily, the +~ log-load routine itself cannot assume access to any scratch space; the value +~ stack is the only place it can store anything it needs, most crucially +~ including the log address. +~ +~ Fortunately, it is possible for the transform's own generated code to +~ cooperate with the transformed code so that they can both share the stack, +~ as long as the log transform knows what the transformed code is doing with +~ it. Unfortunately, there's no general way to know that. We achieve it by +~ hard-coding a delta value for every single possible word, and looking up +~ that delta at transform-time, based on the word's name. Yes, that is quite a +~ thing to have to do, but it does mean we don't have to think about this +~ while writing the code we're transforming. +~ +~ It's worth noticing that the delta only applies to things that happen +~ immediately. It does not apply to compiled words because they run later, and +~ it does not apply to alternates because they run too soon. Feel free to +~ contemplate how confusing it is that transformation-time is sooner than +~ "immediate". +~ +~ (name pointer -- delta value) +: transform-get-stack-delta + ~ From language/static/core.e. + dup s" docol" stringcmp 0 = { drop 1 exit } if + dup s" exit" stringcmp 0 = { drop 0 exit } if + dup s" swap" stringcmp 0 = { drop 0 exit } if + dup s" drop" stringcmp 0 = { drop -1 exit } if + dup s" 2drop" stringcmp 0 = { drop -2 exit } if + ~ The following are deliberate omissions: roll, unroll. + dup s" 3roll" stringcmp 0 = { drop 0 exit } if + dup s" 3unroll" stringcmp 0 = { drop 0 exit } if + dup s" dup" stringcmp 0 = { drop 1 exit } if + dup s" 2dup" stringcmp 0 = { drop 2 exit } if + dup s" +" stringcmp 0 = { drop -1 exit } if + dup s" -" stringcmp 0 = { drop -1 exit } if + dup s" *" stringcmp 0 = { drop -1 exit } if + dup s" /%" stringcmp 0 = { drop 0 exit } if + dup s" 1+" stringcmp 0 = { drop 0 exit } if + dup s" 1-" stringcmp 0 = { drop 0 exit } if + dup s" =" stringcmp 0 = { drop -1 exit } if + dup s" !=" stringcmp 0 = { drop -1 exit } if + dup s" >" stringcmp 0 = { drop -1 exit } if + dup s" <" stringcmp 0 = { drop -1 exit } if + dup s" >=" stringcmp 0 = { drop -1 exit } if + dup s" <=" stringcmp 0 = { drop -1 exit } if + dup s" >unsigned" stringcmp 0 = { drop -1 exit } if + dup s" =unsigned" stringcmp 0 = { drop -1 exit } if + dup s" <=unsigned" stringcmp 0 = { drop -1 exit } if + dup s" &" stringcmp 0 = { drop -1 exit } if + dup s" |" stringcmp 0 = { drop -1 exit } if + dup s" xor" stringcmp 0 = { drop -1 exit } if + dup s" invert" stringcmp 0 = { drop 0 exit } if + dup s" lit" stringcmp 0 = { drop 1 exit } if + dup s" litstring" stringcmp 0 = { drop 1 exit } if + dup s" !" stringcmp 0 = { drop -2 exit } if + dup s" @" stringcmp 0 = { drop 0 exit } if + dup s" +!" stringcmp 0 = { drop -2 exit } if + dup s" -!" stringcmp 0 = { drop -2 exit } if + dup s" 8!" stringcmp 0 = { drop -2 exit } if + dup s" 8@" stringcmp 0 = { drop 0 exit } if + dup s" 16!" stringcmp 0 = { drop -2 exit } if + dup s" 16@" stringcmp 0 = { drop 0 exit } if + dup s" 32!" stringcmp 0 = { drop -2 exit } if + dup s" 32@" stringcmp 0 = { drop 0 exit } if + dup s" control!" stringcmp 0 = { drop -1 exit } if + dup s" control@" stringcmp 0 = { drop 1 exit } if + dup s" value!" stringcmp 0 = { drop -1 exit } if + dup s" value@" stringcmp 0 = { drop 1 exit } if + dup s" memcopy" stringcmp 0 = { drop -3 exit } if + dup s" memmove" stringcmp 0 = { drop -3 exit } if + dup s" stringlen" stringcmp 0 = { drop 0 exit } if + dup s" reverse-stringlen" stringcmp 0 = { drop 0 exit } if + dup s" reverse-padding-len" stringcmp 0 = { drop 0 exit } if + dup s" stringcmp" stringcmp 0 = { drop -1 exit } if + dup s" branch" stringcmp 0 = { drop 0 exit } if + dup s" 0branch" stringcmp 0 = { drop 0 exit } if + ~ This is kind of a big assumption. + dup s" execute" stringcmp 0 = { drop -1 exit } if + dup s" entry-to-execution-token" stringcmp 0 = { drop 0 exit } if + dup s" execution-token-to-entry" stringcmp 0 = { drop 0 exit } if + dup s" entry-flags@" stringcmp 0 = { drop 0 exit } if + dup s" entry-flags!" stringcmp 0 = { drop -2 exit } if + dup s" entry-to-name" stringcmp 0 = { drop 0 exit } if + dup s" pack64" stringcmp 0 = { drop -1 exit } if + dup s" pack32" stringcmp 0 = { drop -1 exit } if + dup s" pack16" stringcmp 0 = { drop -1 exit } if + dup s" pack8" stringcmp 0 = { drop -1 exit } if + dup s" packstring" stringcmp 0 = { drop -1 exit } if + dup s" packalign" stringcmp 0 = { drop -1 exit } if + dup s" unpack64" stringcmp 0 = { drop 1 exit } if + dup s" unpack32" stringcmp 0 = { drop 1 exit } if + dup s" unpack16" stringcmp 0 = { drop 1 exit } if + dup s" unpack8" stringcmp 0 = { drop 1 exit } if + dup s" align-size" stringcmp 0 = { drop -1 exit } if + dup s" unpackalign" stringcmp 0 = { drop -1 exit } if + dup s" crash" stringcmp 0 = { drop 0 exit } if + dup s" max" stringcmp 0 = { drop -1 exit } if + dup s" min" stringcmp 0 = { drop -1 exit } if + dup s" over" stringcmp 0 = { drop 1 exit } if + dup s" pick" stringcmp 0 = { drop 0 exit } if + ~ The following are deliberate omissions: ndrop, ndup. + dup s" 3drop" stringcmp 0 = { drop -3 exit } if + dup s" 3dup" stringcmp 0 = { drop 3 exit } if + dup s" &&" stringcmp 0 = { drop -1 exit } if + dup s" ||" stringcmp 0 = { drop -1 exit } if + dup s" not" stringcmp 0 = { drop 0 exit } if + dup s" negate" stringcmp 0 = { drop 0 exit } if + dup s" align-floor" stringcmp 0 = { drop -1 exit } if + + ~ From language/static/linux.e. + dup s" sys-exit" stringcmp 0 = { drop -1 exit } if + dup s" sys-write" stringcmp 0 = { drop -2 exit } if + dup s" sys-read" stringcmp 0 = { drop -2 exit } if + + ~ From language/static/output.e. + dup s" emitstring" stringcmp 0 = { drop -1 exit } if + dup s" space" stringcmp 0 = { drop 0 exit } if + dup s" newline" stringcmp 0 = { drop 0 exit } if + dup s" pow" stringcmp 0 = { drop 2 exit } if + dup s" logfloor" stringcmp 0 = { drop 2 exit } if + dup s" logceil" stringcmp 0 = { drop 2 exit } if + dup s" .base-unsigned" stringcmp 0 = { drop -3 exit } if + dup s" .base" stringcmp 0 = { drop -2 exit } if + dup s" ." stringcmp 0 = { drop -1 exit } if + dup s" .hex" stringcmp 0 = { drop -1 exit } if + dup s" .hex8" stringcmp 0 = { drop -1 exit } if + dup s" .hex16" stringcmp 0 = { drop -1 exit } if + dup s" .hex32" stringcmp 0 = { drop -1 exit } if + dup s" .hex64" stringcmp 0 = { drop -1 exit } if + dup s" .hexn" stringcmp 0 = { drop -2 exit } if + + ~ From language/static/amd64.e. + dup s" :rax" stringcmp 0 = { drop 1 exit } if + dup s" :rcx" stringcmp 0 = { drop 1 exit } if + dup s" :rdx" stringcmp 0 = { drop 1 exit } if + dup s" :rbx" stringcmp 0 = { drop 1 exit } if + dup s" :rsp" stringcmp 0 = { drop 1 exit } if + dup s" :rbp" stringcmp 0 = { drop 1 exit } if + dup s" :rsi" stringcmp 0 = { drop 1 exit } if + dup s" :rdi" stringcmp 0 = { drop 1 exit } if + dup s" :r8" stringcmp 0 = { drop 1 exit } if + dup s" :r9" stringcmp 0 = { drop 1 exit } if + dup s" :r10" stringcmp 0 = { drop 1 exit } if + dup s" :r11" stringcmp 0 = { drop 1 exit } if + dup s" :r12" stringcmp 0 = { drop 1 exit } if + dup s" :r13" stringcmp 0 = { drop 1 exit } if + dup s" :r14" stringcmp 0 = { drop 1 exit } if + dup s" :r15" stringcmp 0 = { drop 1 exit } if + dup s" :eax" stringcmp 0 = { drop 1 exit } if + dup s" :ecx" stringcmp 0 = { drop 1 exit } if + dup s" :edx" stringcmp 0 = { drop 1 exit } if + dup s" :ebx" stringcmp 0 = { drop 1 exit } if + dup s" :esp" stringcmp 0 = { drop 1 exit } if + dup s" :ebp" stringcmp 0 = { drop 1 exit } if + dup s" :esi" stringcmp 0 = { drop 1 exit } if + dup s" :edi" stringcmp 0 = { drop 1 exit } if + dup s" :ax" stringcmp 0 = { drop 1 exit } if + dup s" :cx" stringcmp 0 = { drop 1 exit } if + dup s" :dx" stringcmp 0 = { drop 1 exit } if + dup s" :bx" stringcmp 0 = { drop 1 exit } if + dup s" :sp" stringcmp 0 = { drop 1 exit } if + dup s" :bp" stringcmp 0 = { drop 1 exit } if + dup s" :si" stringcmp 0 = { drop 1 exit } if + dup s" :di" stringcmp 0 = { drop 1 exit } if + dup s" :al" stringcmp 0 = { drop 1 exit } if + dup s" :cl" stringcmp 0 = { drop 1 exit } if + dup s" :dl" stringcmp 0 = { drop 1 exit } if + dup s" :bl" stringcmp 0 = { drop 1 exit } if + dup s" :ah" stringcmp 0 = { drop 1 exit } if + dup s" :ch" stringcmp 0 = { drop 1 exit } if + dup s" :dh" stringcmp 0 = { drop 1 exit } if + dup s" :bh" stringcmp 0 = { drop 1 exit } if + dup s" :cc-overflow" stringcmp 0 = { drop 1 exit } if + dup s" :cc-no-overflow" stringcmp 0 = { drop 1 exit } if + dup s" :cc-below" stringcmp 0 = { drop 1 exit } if + dup s" :cc-above-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-not-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-below-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-above" stringcmp 0 = { drop 1 exit } if + dup s" :cc-sign" stringcmp 0 = { drop 1 exit } if + dup s" :cc-not-sign" stringcmp 0 = { drop 1 exit } if + dup s" :cc-even" stringcmp 0 = { drop 1 exit } if + dup s" :cc-odd" stringcmp 0 = { drop 1 exit } if + dup s" :cc-less" stringcmp 0 = { drop 1 exit } if + dup s" :cc-greater-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-less-equal" stringcmp 0 = { drop 1 exit } if + dup s" :cc-greater" stringcmp 0 = { drop 1 exit } if + dup s" reg64" stringcmp 0 = { drop 0 exit } if + dup s" extrareg64" stringcmp 0 = { drop 0 exit } if + dup s" reg32" stringcmp 0 = { drop 0 exit } if + dup s" reg16" stringcmp 0 = { drop 0 exit } if + dup s" reg8" stringcmp 0 = { drop 0 exit } if + dup s" scalefield" stringcmp 0 = { drop 0 exit } if + dup s" condition-code" stringcmp 0 = { drop 0 exit } if + dup s" rex-0" stringcmp 0 = { drop 0 exit } if + dup s" rex-w" stringcmp 0 = { drop 0 exit } if + dup s" rex-r" stringcmp 0 = { drop 0 exit } if + dup s" rex-x" stringcmp 0 = { drop 0 exit } if + dup s" rex-b" stringcmp 0 = { drop 0 exit } if + dup s" rex-wr" stringcmp 0 = { drop 0 exit } if + dup s" rex-wx" stringcmp 0 = { drop 0 exit } if + dup s" rex-wb" stringcmp 0 = { drop 0 exit } if + dup s" rex-rx" stringcmp 0 = { drop 0 exit } if + dup s" rex-rb" stringcmp 0 = { drop 0 exit } if + dup s" rex-xb" stringcmp 0 = { drop 0 exit } if + dup s" rex-wrx" stringcmp 0 = { drop 0 exit } if + dup s" rex-wrb" stringcmp 0 = { drop 0 exit } if + dup s" rex-wxb" stringcmp 0 = { drop 0 exit } if + dup s" rex-rxb" stringcmp 0 = { drop 0 exit } if + dup s" rex-wrxb" stringcmp 0 = { drop 0 exit } if + dup s" opcodereg" stringcmp 0 = { drop -2 exit } if + dup s" opcodecc" stringcmp 0 = { drop -2 exit } if + dup s" modrm" stringcmp 0 = { drop -3 exit } if + dup s" sib" stringcmp 0 = { drop -3 exit } if + dup s" addressing-reg64" stringcmp 0 = { drop -2 exit } if + dup s" addressing-reg8" stringcmp 0 = { drop -2 exit } if + dup s" addressing-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" addressing-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" addressing-disp32-reg64" stringcmp 0 = { drop -3 exit } if + dup s" addressing-indexed-reg64" stringcmp 0 = { drop -4 exit } if + dup s" addressing-disp8-indexed-reg64" stringcmp 0 = { drop -5 exit } if + dup s" cld" stringcmp 0 = { drop 0 exit } if + dup s" std" stringcmp 0 = { drop 0 exit } if + dup s" syscall" stringcmp 0 = { drop 0 exit } if + dup s" hlt" stringcmp 0 = { drop 0 exit } if + dup s" push-reg64" stringcmp 0 = { drop -1 exit } if + dup s" push-extrareg64" stringcmp 0 = { drop -1 exit } if + dup s" pop-reg64" stringcmp 0 = { drop -1 exit } if + dup s" pop-extrareg64" stringcmp 0 = { drop -1 exit } if + dup s" push-imm32-extended64" stringcmp 0 = { drop -1 exit } if + dup s" lea-reg64-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" lea-reg64-disp32-reg64" stringcmp 0 = { drop -3 exit } if + dup s" lea-reg64-indexed-reg64" stringcmp 0 = { drop -4 exit } if + dup s" lea-reg64-disp8-indexed-reg64" stringcmp 0 = { drop -5 exit } if + dup s" mov-reg64-imm32" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg64-imm64" stringcmp 0 = { drop -2 exit } if + dup s" mov-extrareg64-imm64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg64-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg64-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg64-disp32-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg64-indexed-reg64" stringcmp 0 = { drop -4 exit } if + dup s" mov-indexed-reg64-reg64" stringcmp 0 = { drop -4 exit } if + dup s" mov-indirect-reg64-reg32" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg32" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg32-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg32-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-indirect-reg64-reg16" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg16" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg16-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg16-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-indirect-reg64-reg8" stringcmp 0 = { drop -2 exit } if + dup s" mov-disp8-reg64-reg8" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg8-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" mov-reg8-disp8-reg64" stringcmp 0 = { drop -3 exit } if + dup s" mov-reg8-reg8" stringcmp 0 = { drop -2 exit } if + dup s" movs8" stringcmp 0 = { drop 0 exit } if + dup s" movs16" stringcmp 0 = { drop 0 exit } if + dup s" movs32" stringcmp 0 = { drop 0 exit } if + dup s" movs64" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs8" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs16" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs32" stringcmp 0 = { drop 0 exit } if + dup s" rep-movs64" stringcmp 0 = { drop 0 exit } if + dup s" lods8" stringcmp 0 = { drop 0 exit } if + dup s" lods16" stringcmp 0 = { drop 0 exit } if + dup s" lods32" stringcmp 0 = { drop 0 exit } if + dup s" lods64" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods8" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods16" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods32" stringcmp 0 = { drop 0 exit } if + dup s" rep-lods64" stringcmp 0 = { drop 0 exit } if + dup s" stos8" stringcmp 0 = { drop 0 exit } if + dup s" stos16" stringcmp 0 = { drop 0 exit } if + dup s" stos32" stringcmp 0 = { drop 0 exit } if + dup s" stos64" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos8" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos16" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos32" stringcmp 0 = { drop 0 exit } if + dup s" rep-stos64" stringcmp 0 = { drop 0 exit } if + dup s" cmps8" stringcmp 0 = { drop 0 exit } if + dup s" cmps16" stringcmp 0 = { drop 0 exit } if + dup s" cmps32" stringcmp 0 = { drop 0 exit } if + dup s" cmps64" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps8" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps16" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps32" stringcmp 0 = { drop 0 exit } if + dup s" repz-cmps64" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps8" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps16" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps32" stringcmp 0 = { drop 0 exit } if + dup s" repnz-cmps64" stringcmp 0 = { drop 0 exit } if + dup s" scas8" stringcmp 0 = { drop 0 exit } if + dup s" scas16" stringcmp 0 = { drop 0 exit } if + dup s" scas32" stringcmp 0 = { drop 0 exit } if + dup s" scas64" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas8" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas16" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas32" stringcmp 0 = { drop 0 exit } if + dup s" repz-scas64" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas8" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas16" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas32" stringcmp 0 = { drop 0 exit } if + dup s" repnz-scas64" stringcmp 0 = { drop 0 exit } if + dup s" add-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" add-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" add-reg64-indirect-reg64" stringcmp 0 = { drop -2 exit } if + dup s" add-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" sub-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" sub-indirect-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" sub-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" sbb-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" mul-reg64" stringcmp 0 = { drop -1 exit } if + dup s" divmod-reg64" stringcmp 0 = { drop -1 exit } if + dup s" idivmod-reg64" stringcmp 0 = { drop -1 exit } if + dup s" inc-reg64" stringcmp 0 = { drop -1 exit } if + dup s" dec-reg64" stringcmp 0 = { drop -1 exit } if + dup s" and-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" and-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" or-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" or-reg64-imm8" stringcmp 0 = { drop -2 exit } if + dup s" xor-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" not-reg64" stringcmp 0 = { drop -1 exit } if + dup s" cmp-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" test-reg64-reg64" stringcmp 0 = { drop -2 exit } if + dup s" set-reg8-cc" stringcmp 0 = { drop -2 exit } if + dup s" jmp-cc-rel-imm8" stringcmp 0 = { drop -2 exit } if + dup s" jmp-cc-rel-imm32" stringcmp 0 = { drop -2 exit } if + dup s" jmp-abs-indirect-reg64" stringcmp 0 = { drop -1 exit } if + dup s" jmp-rel-imm8" stringcmp 0 = { drop -1 exit } if + dup s" jmp-rel-imm32" stringcmp 0 = { drop -1 exit } if + + ~ From language/static/execution-support.e. + dup s" pack-next" stringcmp 0 = { drop 0 exit } if + dup s" pack-beforenext" stringcmp 0 = { drop -1 exit } if + dup s" pack-pushcontrol" stringcmp 0 = { drop -1 exit } if + dup s" pack-popcontrol" stringcmp 0 = { drop -1 exit } if + + ~ From language/dynamic/dynamic.e. + dup s" stack" stringcmp 0 = { drop 0 exit } if + dup s" stackhex" stringcmp 0 = { drop 0 exit } if + dup s" is-in-log" stringcmp 0 = { drop 0 exit } if + dup s" oldest-entry" stringcmp 0 = { drop 1 exit } if + dup s" next-newer-entry" stringcmp 0 = { drop 0 exit } if + dup s" guess-entry-end" stringcmp 0 = { drop 0 exit } if + dup s" containing-entry" stringcmp 0 = { drop 0 exit } if + dup s" is-assembly-word" stringcmp 0 = { drop 0 exit } if + dup s" is-docol-itself" stringcmp 0 = { drop 0 exit } if + dup s" is-docol-codeword" stringcmp 0 = { drop 0 exit } if + dup s" is-docol-interpreted-word" stringcmp 0 = { drop 0 exit } if + dup s" is-codeword-pointer" stringcmp 0 = { drop 0 exit } if + dup s" indent" stringcmp 0 = { drop -1 exit } if + dup s" word-heading" stringcmp 0 = { drop -1 exit } if + dup s" list-dictionary" stringcmp 0 = { drop 0 exit } if + dup s" hexdump-row" stringcmp 0 = { drop -3 exit } if + dup s" hexdump-between" stringcmp 0 = { drop -2 exit } if + dup s" hexdump-from" stringcmp 0 = { drop -2 exit } if + dup s" hexdump" stringcmp 0 = { drop -1 exit } if + dup s" describe-hex" stringcmp 0 = { drop -1 exit } if + dup s" describe-docol" stringcmp 0 = { drop -1 exit } if + dup s" describe" stringcmp 0 = { drop -1 exit } if + dup s" describe-all" stringcmp 0 = { drop 0 exit } if + dup s" describe-compilation" stringcmp 0 = { drop 0 exit } if + dup s" symbolize-pointer" stringcmp 0 = { drop -1 exit } if + dup s" list-callers" stringcmp 0 = { drop 0 exit } if + dup s" forget" stringcmp 0 = { drop -1 exit } if + dup s" ," stringcmp 0 = { drop -1 exit } if + dup s" make-immediate" stringcmp 0 = { drop 0 exit } if + dup s" make-hidden" stringcmp 0 = { drop 0 exit } if + dup s" make-visible" stringcmp 0 = { drop 0 exit } if + dup s" recurse" stringcmp 0 = { drop 0 exit } if + dup s" recurse" stringcmp 0 = { drop 0 exit } if + dup s" find" stringcmp 0 = { drop 0 exit } if + dup s" allocate" stringcmp 0 = { drop 0 exit } if + dup s" create" stringcmp 0 = { drop -1 exit } if + dup s" self-codeword" stringcmp 0 = { drop 0 exit } if + dup s" variable" stringcmp 0 = { drop -2 exit } if + dup s" keyword" stringcmp 0 = { drop -1 exit } if + dup s" literal" stringcmp 0 = { drop -1 exit } if + + ~ From language/dynamic/input.e. + dup s" buffer-physical-start" stringcmp 0 = { drop 0 exit } if + dup s" buffer-physical-length" stringcmp 0 = { drop 0 exit } if + dup s" buffer-logical-start" stringcmp 0 = { drop 0 exit } if + dup s" buffer-logical-length" stringcmp 0 = { drop 0 exit } if + dup s" input-buffer-refill" stringcmp 0 = { drop 0 exit } if + dup s" input-buffer-next-source" stringcmp 0 = { drop 0 exit } if + dup s" clear-buffer" stringcmp 0 = { drop -1 exit } if + dup s" zero-input-buffer-metadata" stringcmp 0 = { drop -1 exit } if + dup s" allocate-input-buffer-metadata" stringcmp 0 = { drop 1 exit } if + dup s" allocate-input-buffer" stringcmp 0 = { drop 0 exit } if + dup s" attach-string-to-input-buffer" stringcmp 0 = { drop -2 exit } if + dup s" consume-from" stringcmp 0 = { drop -1 exit } if + dup s" peek-from" stringcmp 0 = { drop 0 exit } if + dup s" key-from" stringcmp 0 = { drop 0 exit } if + dup s" normalize-buffer" stringcmp 0 = { drop -1 exit } if + dup s" compute-next-buffer-free-block" stringcmp 0 = { drop 1 exit } if + dup s" refill-input-buffer-from-stdin" stringcmp 0 = { drop -1 exit } if + dup s" main-input-buffer" stringcmp 0 = { drop 1 exit } if + dup s" consume" stringcmp 0 = { drop 0 exit } if + dup s" peek" stringcmp 0 = { drop 1 exit } if + dup s" key" stringcmp 0 = { drop 1 exit } if + + ~ From language/dynamic/interpret.e. + dup s" unroll-past-string" stringcmp 0 = { drop 0 exit } if + dup s" swap-past-string" stringcmp 0 = { drop 0 exit } if + ~ The following are deliberate omissions: dropstring, + ~ dropstring-with-result, accumulate-string. + dup s" is-space" stringcmp 0 = { drop 0 exit } if + dup s" is-alphanumeric" stringcmp 0 = { drop 0 exit } if + ~ The following is a deliberate omission: word. + dup s" generalized-digit-value" stringcmp 0 = { drop 0 exit } if + ~ The following are deliberate omissions: decode-generalized-digit, + ~ read-base-unsigned, read-integer-unsigned, read-integer, read-decimal. + dup s" interpreter-flags" stringcmp 0 = { drop 1 exit } if + dup s" [" stringcmp 0 = { drop 0 exit } if + dup s" ]" stringcmp 0 = { drop 0 exit } if + dup s" :" stringcmp 0 = { drop 0 exit } if + dup s" ;" stringcmp 0 = { drop 0 exit } if + dup s" ;asm" stringcmp 0 = { drop 0 exit } if + dup s" '" stringcmp 0 = { drop 1 exit } if + dup s" relink-main-input-buffer-to-stdin" stringcmp 0 = { drop 0 exit } if + ~ The following is a deliberate omission: interpret. + dup s" quit" stringcmp 0 = { drop 0 exit } if + + ~ From language/dynamic/linux.e. + dup s" allocate-timespec" stringcmp 0 = { drop 1 exit } if + dup s" timespec-seconds" stringcmp 0 = { drop 0 exit } if + dup s" timespec-nanoseconds" stringcmp 0 = { drop 0 exit } if + dup s" nanosleep" stringcmp 0 = { drop 0 exit } if + dup s" sys-sigaction" stringcmp 0 = { drop -2 exit } if + dup s" sys-sigaltstack" stringcmp 0 = { drop -1 exit } if + dup s" allocate-sigaction" stringcmp 0 = { drop 1 exit } if + dup s" sigaction-action" stringcmp 0 = { drop 0 exit } if + dup s" sigaction-flags" stringcmp 0 = { drop 0 exit } if + dup s" sigaction-restorer" stringcmp 0 = { drop 0 exit } if + dup s" sigaction-mask" stringcmp 0 = { drop 0 exit } if + dup s" allocate-sigaltstack" stringcmp 0 = { drop 1 exit } if + dup s" sigaltstack-pointer" stringcmp 0 = { drop 0 exit } if + dup s" sigaltstack-flags" stringcmp 0 = { drop 0 exit } if + dup s" sigaltstack-size" stringcmp 0 = { drop 0 exit } if + dup s" prepare-signal-stack" stringcmp 0 = { drop 0 exit } if + ~ The following is a deliberate omission: signal-return-trampoline. + dup s" wrap-signal-handler" stringcmp 0 = { drop 0 exit } if + dup s" bind-signal" stringcmp 0 = { drop -2 exit } if + ~ The following is a deliberate omission: handle-crash. + dup s" install-crash-handler" stringcmp 0 = { drop 0 exit } if + + ~ Created by warm-start in compilation/execution.e. + dup s" log" stringcmp 0 = { drop 1 exit } if + dup s" s0" stringcmp 0 = { drop 1 exit } if + dup s" r0" stringcmp 0 = { drop 1 exit } if + dup s" latest" stringcmp 0 = { drop 1 exit } if + dup s" here" stringcmp 0 = { drop 1 exit } if + + ~ Word not provided statically, but used during the log-load routine anyway. + dup s" L@'" stringcmp 0 = { drop 1 exit } if + dup s" L!'" stringcmp 0 = { drop -1 exit } if + dup s" labels" stringcmp 0 = { drop 1 exit } if + dup s" allocate-transformation-state" stringcmp 0 = { drop 1 exit } if + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. We also return a comically large negative value, + ~ to make sure things fail as quickly as possible afterwards. + ." No known stack delta: " emitstring newline + -256 ; + + +~ (delta --) +: transform-apply-stack-delta + transformation-state transformation-state-user-stack-depth @ + + transformation-state transformation-state-user-stack-depth ! ; + + +~ Label transform implementation +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The following code is all part of implementing the label transform. For +~ conceptual overview, see the top of this file. + + +~ This is the alternate version of "create" for use with the label +~ transform. Its code is the same as the regular "create" except as noted +~ below. It is likely to be extremely useful to read and understand "create" +~ in language/dynamic/dynamic.e before attempting to understand +~ label-create-alternate. +: label-create-alternate + ~ While we could put magic comments here, and be guaranteed to catch every + ~ word-defining word under the label transform, there's a subtle thing where + ~ we need to make sure the "indent" command happens in the same places it + ~ does when the same code runs under the log-load transform, and only those + ~ places. So, we do it in the callers of "create" instead. + dup stringlen 1 + + ~ : provide-data + dup 3unroll + here @ 10 + swap memmove + here @ + + ~ This value of "latest" is going into the generated output, so we need + ~ to map it to the target address space. It's stored in the host address + ~ space to make immediate words work as expected, so the appropriate + ~ conversion is host-address-space-to-target. + ~ : 8 #-- (previous entry pointer) + latest @ host-address-space-to-target pack64 + ~ : 1 #-- (entry flags) + 0 pack8 + ~ : bidirectional-null-terminated entry name + 0 pack8 + ~ : 1 data-adjust-output-point + ~ : fresh-line + + + 8 packalign + here @ latest ! + + ~ Now we're immediately after the word header, which is where the codeword + ~ will be. This is the value the label should taken on, so we set it. + dup host-address-space-to-offset + here @ 10 + + swap-transform-variables + intern-label set-label + swap-transform-variables + + here ! ; + + +~ This is the alternate version of ":" for use with the label transform. Its +~ code is the same as the regular "create" except as noted below. It is likely +~ to be extremely useful to read and understand ":" in +~ language/dynamic/dynamic.e before attempting to understand +~ label-colon-alternate. +: label-colon-alternate + ~ This calls label-create-alternate instead of "create". + word value@ + ~ : blank-line + ~ : blank-line + ~ : provide-string-copy + ~ : # is defined here via the label transform; this is its entry header. + ~ : indent + label-create-alternate dropstring + + ~ This looks up "docol" by label. + ~ : 8 #-- (docol codeword) + swap-transform-variables + L@' docol-codeword-value + L@' origin + swap-transform-variables + + , + ~ : blank-line + + latest @ dup entry-flags@ 0x80 | swap entry-flags! + ] ; + + +~ So, the way docol's user-facing entry is set up in language/static/core.e, +~ it really wants to reference "here" to create its codeword, but "here" is in +~ the host address space. We solve this by having it call the word +~ "self-codeword" and then patching around the address space issue with +~ alternates. +~ +~ If we didn't have this fix, everything would appear to work fine but the +~ statically generated user-facing docol from the label transform would have +~ a wrong codeword, varying based on the host's memory usage. It's never +~ actually called by evoke itself (it would crash horribly), though it may +~ be from programs that use the facilities differently. It's a binary +~ reproducibility issue - our only known one, in fact - so it's worth fixing. +: label-self-codeword-alternate + here @ dup 8 + host-address-space-to-target pack64 here ! + ; make-immediate + + +~ This is the alternate version of ";" for use with the label transform. Its +~ code is the same as the regular "create" except as noted below. It is likely +~ to be extremely useful to read and understand ";" in +~ language/dynamic/dynamic.e before attempting to understand +~ label-semicolon-alternate. +: label-semicolon-alternate + ~ This looks up "exit" by label. + swap-transform-variables + L@' exit + swap-transform-variables + offset-to-target-address-space , ~ : -8 exit #-- (codeword pointer) + ~ : deindent + + latest @ dup entry-flags@ 0x80 invert & swap entry-flags! + + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of ;. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ This is the alternate version of ";asm" for use with the label transform. +~ Its code is the same as the regular "create" except as noted below. It is +~ likely to be extremely useful to read and understand ";asm" in +~ language/dynamic/dynamic.e before attempting to understand +~ label-semicolon-assembly-alternate. +: label-semicolon-assembly-alternate + here @ pack-next 8 packalign + ~ : provide-data + here ! + ~ : deindent + + latest @ dup dup entry-flags@ 0x80 invert & swap entry-flags! + entry-to-execution-token + ~ The codeword needs to be transformed to the target address space. + ~ : provide-data + ~ : data-set-output-point + ~ : delete-last-comment-at-output-point + ~ : 8 #-- (self codeword) + dup 8 + host-address-space-to-target + swap ! + ~ : data-set-output-point + + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of ;asm. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ TODO there should really be an actual word that this alternate is replacing +~ +~ If it existed, that word would be (string pointer --). +: label-keyword-alternate + ~ : blank-line + ~ : blank-line + ~ : provide-string-copy + ~ : # is defined here via the label transform; this is its entry header. + ~ : indent + label-create-alternate + + here @ dup + ~ (self execution token, output point) + dup 8 + host-address-space-to-target pack64 + swap host-address-space-to-target :rax mov-reg64-imm64 + ~ (output point) + :rax push-reg64 + pack-next + 8 packalign + here ! + ~ : deindent + ; make-immediate + + +~ It's convenient to be able to work with strings in label-transformed +~ code. If we don't provide an alternate for it, we get codeword pointers in +~ the host address space, which therefore don't work. +: label-string-alternate + ~ Something subtle here: s" is state-dependent. That is, it does different + ~ things depending on the interpreter flags. We would really rather know + ~ which version we're getting, and also it would be best if it didn't + ~ scribble on the output buffer. Fortunately we can achieve both of these, + ~ by coercing things into a known state while calling it. + ~ + ~ We could choose either version of s", but the interpreted one is more + ~ convenient because it doesn't mess with a spurious litstring invocation, + ~ just scribbled into scratch space after "here". Of course, that raises the + ~ additional concern that we have the wrong "here", but we can just swap + ~ that around, too. + ~ + ~ This is all worth it to avoid reimplementing s". If we had two + ~ implementations, they'd have to be kept in sync, and it's an important + ~ user-facing word with semantics that are likely to improve over time. + interpreter-flags @ + ' s" entry-to-execution-token + swap-transform-variables + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of the alternate. + [ ' [ entry-to-execution-token , ] + execute + swap-transform-variables + swap interpreter-flags ! + + ~ Whew. What a mouthful. + ~ + ~ Having done this, we have the string pointer on the stack at transform + ~ time, which with the label transform is the same as immediate time. If + ~ we're in immediate mode, therefore, we've left the string on the stack and + ~ that's all we wanted. If we're in compile mode, it's our job to output a + ~ litstring invocation. + + interpreter-flags @ 0x01 & { + swap-transform-variables + L@' litstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ swap packstring 8 packalign here ! + } if + ; make-immediate + + +: label-dot-string-alternate + ' label-string-alternate entry-to-execution-token execute + + interpreter-flags @ 0x01 & { + swap-transform-variables + L@' emitstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 emitstring #-- (codeword pointer) + } { emitstring } if-else + ; make-immediate + + +~ Because docol requires it, we provide a special mini-version of the label +~ system. We only do L@' and L!', because that's all we need. These are real +~ labels; there can be arbitrarily many of them, and they can have forward +~ references. +~ +~ The value that's accepted is in the host address space; the label is set +~ to an offset; and the value that's returned is in the target address space. +~ +~ (-- value) +: label-L@'-alternate + word value@ + + swap-transform-variables + intern-label + use-label + swap-transform-variables + + dropstring-with-result + + offset-to-target-address-space + ; make-immediate + + +~ (value --) +: label-L!'-alternate + host-address-space-to-offset + + word value@ + + swap-transform-variables + intern-label + swap-transform-variables + + dropstring-with-result + + swap-transform-variables + set-label + swap-transform-variables + ; make-immediate + + +~ We implement alternates of all the high-level flow-control words for the +~ label transform: if, unless, if-else, forever, and while. We leave { and } +~ as their usual implementations. The values { and } leave on the stack will +~ be in the host address space, which is convenient anyway. Those values don't +~ make their way into the output, since everything is relative, and the +~ relative offsets are correct regardless. What we do need to change, though, +~ is the addresses of branch and 0branch. We need to resolve these via label. +~ +~ (start pointer, length --) +: label-if-alternate + 2dup swap dup 5 8 * + 3roll + ~ (start pointer, length, adjusted start pointer, start pointer, length) + memmove + ~ (start pointer, length) + swap here @ swap here ! swap + ~ (old here, length) + swap-transform-variables + L@' 0branch + L@' != + L@' lit + swap-transform-variables + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 != #-- (codeword pointer) + ~ The branch length needs to be one word longer than the block length, + ~ because the length field itself is part of the scope of the branch. + offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer) + dup 8 + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ~ (old here, length) + drop 5 8 * + here ! + ; make-immediate + +~ (start pointer, length) +: label-unless-alternate + 2dup swap dup 5 8 * + 3roll + ~ (start pointer, length, adjusted start pointer, start pointer, length) + memmove + ~ (start pointer, length) + swap here @ swap here ! swap + ~ (old here, length) + swap-transform-variables + L@' 0branch + L@' = + L@' lit + swap-transform-variables + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 = #-- (codeword pointer) + ~ The branch length needs to be one word longer than the block length, + ~ because the length field itself is part of the scope of the branch. + offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer) + dup 8 + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ~ (old here, length) + drop 5 8 * + here ! + ; make-immediate + +~ (true start, true length, false start, false length) +: label-if-else-alternate + ~ First we slide the false-block forward, then the true-block. We slide + ~ them both directly into their final positions, leaving space at the start + ~ for a test and branch, and space in between for an unconditional branch. + ~ Those spaces will take five words, and two words, respectively. So the + ~ false-block gets moved by seven words, and the true-block gets moved by + ~ five words. + 2dup swap dup 7 8 * + 3roll memmove + 3 pick dup 5 8 * + 4 pick memmove + ~ (true start, true length, false start, false length) + + ~ Now we write out the initial test-and-branch. + 4 roll dup 5 unroll here @ 6 unroll here ! + ~ (old here, true start, true length, false start, false length) + swap-transform-variables + L@' 0branch + L@' != + L@' lit + swap-transform-variables + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 != #-- (codeword pointer) + ~ Branch past the length field, the true-block, and the unconditional + ~ branch in the middle. + offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer) + 3roll dup 4 unroll 3 8 * + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + + ~ Next, write out the unconditional branch in the middle. + swap dup 3unroll 5 8 * + here ! + swap-transform-variables + L@' branch + swap-transform-variables + offset-to-target-address-space , ~ : -8 branch #-- (codeword pointer) + ~ Branch past the length field and the false-block. + dup 8 + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + + ~ Set "here" to point to the true end. + drop drop drop drop 7 8 * + here ! + ; make-immediate + +~ (start, length --) +: label-forever-alternate + swap-transform-variables + L@' branch + swap-transform-variables + offset-to-target-address-space , ~ : -8 branch #-- (codeword pointer) + 8 + -1 * ~ : provide-hex + ~ : 8 # #-- (branch offset) + , drop + ; make-immediate + +~ (test start, test length, body start, body length --) +: label-while-alternate + ~ The conditional branch needs five words. + 2dup swap dup 5 8 * + 3roll memmove + here @ 5 unroll swap dup 3unroll here ! + ~ (old here, test start, test length, body start, body length) + swap-transform-variables + L@' 0branch + L@' != + L@' lit + swap-transform-variables + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + 0 ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 != #-- (codeword pointer) + ~ Branch past the length field, the body, and the unconditional branch. + offset-to-target-address-space , ~ : -8 0branch #-- (codeword pointer) + dup 3 8 * + ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ~ Set "here" to the new end. + 5 8 * 6 roll + here ! + ~ (test start, test length, body start, body length) + ~ Unconditionally branch backwards past the branch word, the body, the + ~ conditional branch, and the test. + swap-transform-variables + L@' branch + swap-transform-variables + offset-to-target-address-space , ~ : -8 branch #-- (codeword pointer) + 6 8 * + swap drop + swap drop -1 * ~ : provide-hex + ~ : 8 # #-- (branch offset) + , + ; make-immediate + + +~ This implements the label transform for a single word. It is directly +~ analogous to "interpret", and reading language/dynamic/dynamic.e may help in +~ understanding it, though it's meant to still make sense on its own. +~ +~ It expects to be called from "label-transform", below, which loops. +~ +~ (-- done) +: label-transform-one + word + + ~ If no word was returned, end the transformation. + dup 0 = { drop 1 exit } if + + ~ The string is on the top of the stack, so to get a pointer to it we get + ~ the stack address. + ~ (string) + value@ + + ~ Check whether it's one of the words we have alternates for, and look up + ~ the alternate if so. + dup 0 swap + ~ (name as stack string, name pointer, placeholder, name pointer) + dup s" create" stringcmp 0 = { swap drop ' label-create-alternate swap } if + dup s" :" stringcmp 0 = { swap drop ' label-colon-alternate swap } if + dup s" self-codeword" stringcmp 0 = { + swap drop ' label-self-codeword-alternate swap } if + dup s" ;" stringcmp 0 = { swap drop ' label-semicolon-alternate swap } if + dup s" ;asm" stringcmp 0 = { + swap drop ' label-semicolon-assembly-alternate swap } if + ~ It is nontrivial to construct a string with a double-quote in it. + dup ' s" entry-to-name stringcmp 0 = { + swap drop ' label-string-alternate swap } if + dup ' ." entry-to-name stringcmp 0 = { + swap drop ' label-dot-string-alternate swap } if + dup s" L@'" stringcmp 0 = { swap drop ' label-L@'-alternate swap } if + dup s" L!'" stringcmp 0 = { swap drop ' label-L!'-alternate swap } if + dup s" keyword" stringcmp 0 = { + swap drop ' label-keyword-alternate swap } if + dup s" if" stringcmp 0 = { swap drop ' label-if-alternate swap } if + dup s" unless" stringcmp 0 = { swap drop ' label-unless-alternate swap } if + dup s" if-else" stringcmp 0 = { + swap drop ' label-if-else-alternate swap } if + dup s" forever" stringcmp 0 = { + swap drop ' label-forever-alternate swap } if + dup s" while" stringcmp 0 = { swap drop ' label-while-alternate swap } if + drop swap + ~ (name as stack string, 0 or alternate entry pointer, name pointer) + + ~ If an alternate was found, the alternate will be used in immediate mode. + ~ If not, we look up the word in the regular, non-transformed dictionary + ~ and use that for immediate mode. + over { dup + transformation-state transformation-state-saved-latest @ swap find-in + 3roll drop swap } unless + ~ (name as stack string, immediate entry pointer, name pointer) + + ~ In regular "interpret", we would check whether we found the word before + ~ checking the mode. However, we have three different places words could + ~ come from, so that's not a simple notion. So, we check the mode first. + interpreter-flags @ 0x01 & { + ~ If we're in compile mode, there's still a chance it's an immediate + ~ word. First check whether we have an immediate entry, then if so, check + ~ that entry's flags. Notice that this means the generated code can't + ~ override an immediate word with a non-immediate word of the same name. + over dup { entry-flags@ 0x01 & not } { not } if-else + + { + ~ Either there was no immediate entry, or the immediate entry wasn't + ~ flagged as an immediate word. So we check whether this could be a + ~ compilation. + ~ + ~ To do this, we need to look the word up in the output buffer. We + ~ can't easily traverse the next-entry pointers in the output buffer's + ~ dictionary, so we check the label. Since we don't know the word's name + ~ statically, this is a rare scenario where we can't use the abbreviated + ~ label syntax, but that's easy enough. + ~ + ~ Even though we've ruled out the possibility that the word is only + ~ ever used immediately, it is still possible that there's some reason + ~ the word doesn't exist. In particular, it could be an integer literal. + ~ If we were to call use-label first, that would count as a requirement + ~ that the label must eventually be set. We don't want to require that + ~ quite yet, so we call find-label. + ~ + ~ This check is the means by which forward references are disallowed: + ~ On the very first pass, a forward-referenced label won't exist yet, so + ~ transform will give a "no such word" error, which in an ideal world + ~ would prevent there from being a subsequent pass, but at the very + ~ least it will ensure the output isn't a valid ELF. + dup + swap-transform-variables + find-label + swap-transform-variables + { + ~ It exists, so we declare our use of it (that's also the only way to + ~ get a value for it). + ~ : provide-string-copy + swap-transform-variables + intern-label use-label + swap-transform-variables + + ~ Labels point to codewords (because that's what + ~ label-create-alternate does), which is already what we want to + ~ output. + ~ + ~ An important caveat: Though it would require something weird to be + ~ happening, such as a forced forward reference, the label may be + ~ zero! We need to allow for that possibility by not examining the + ~ contents of a nonexistent entry. + ~ + ~ Fortunately we don't have to look at it, just append it to the log + ~ and clean up. + ~ : 8 # #-- (codeword pointer) + offset-to-target-address-space , drop dropstring 0 exit + } if + + ~ If we got here, we're in compile mode, no label was found, and even + ~ if there was a candidate for an immediate word it wasn't flagged as + ~ immediate. There are two possibilities: It's genuinely missing, or it's + ~ an integer literal. We decline to run the candidate immediate entry, + ~ even if it exists, because that's not the correct semantics. + ~ + ~ If the word is genuinely missing, we want to make sure we make it + ~ all the way to the not-found error-handling code at the end, because + ~ that will be way easier to debug than doing the wrong thing will. Way, + ~ way easier. Far less staring at numbers. + ~ + ~ Anyway, we no longer need the immediate entry pointer, so we drop + ~ it. + drop drop + } { + ~ If we get here, we're in compile mode, but there was a candidate + ~ entry for an immediate word, and it was indeed flagged as immediate. + ~ So, we run it and exit. + drop dropstring-with-result entry-to-execution-token execute + 0 exit + } if-else + + ~ This is the end of the compile-mode branch. As you can see by tracing + ~ through all the above cases, if we got here, the two possibilities are + ~ that the word is genuinely missing, or it's an integer literal. + ~ + ~ Please notice that these are the same two possibilities remaining at + ~ the end of the immediate-mode branch, below. + } { + ~ If we got here, we're in interpret mode. There are three + ~ possibilities: there's an immediate word which we should run; it's an + ~ integer literal; or the word is genuinely missing. + ~ + ~ If the immediate entry pointer is non-zero, run it and exit. + over { + drop dropstring-with-result entry-to-execution-token execute + 0 exit + } if + + ~ There was no immediate word, so either it's an integer literal or + ~ the word is genuinely missing. Please notice that these are the same two + ~ possibilities remaining at the end of the compile-mode branch, above. + ~ + ~ We no longer need the immediate-mode pointer, so drop it. + drop drop + } if-else + ~ (name as stack string) + + ~ If we got here, one of two things is true: the word is an integer + ~ literal, or it's genuinely missing. We know this because both the mode + ~ cases above end with these as the only two remaining possibilities. So + ~ + ~ Check whether it's an integer literal. As before, we get the stack + ~ address and use it as a string pointer. + value@ read-integer 0 = { + ~ It's a number. + interpreter-flags @ 0x01 & { + ~ We're in compile mode; append first "lit", then the number, to the + ~ log. The version of "lit" we use is found by label, so it'll be the + ~ one that exists when this code is ultimately run. + dropstring-with-result + + ~ We look up "lit" as a label. + swap-transform-variables L@' lit swap-transform-variables + offset-to-target-address-space + ~ : 8 lit #-- (codeword pointer) + , + ~ : provide-hex + ~ : 8 # #-- (integer literal) + , + 0 exit + } if + + ~ We're in interpret mode; push the number to the stack. Or at least, that's + ~ what the code we're interpreting will see. Really it's already on the + ~ stack, just clean everything else up and leave it there. + dropstring-with-result + 0 exit + } if + + ~ If it's neither in the dictionary nor a number, just print an error. + ~ + ~ It's really important, when maintaining this code, to make sure that all + ~ the possible ways the word can fail to exist, end up here. Doing anything + ~ else is going to result in many hours of trying to untangle the + ~ consequences of incorrect behavior, after-the-fact. + s" No such word: " emitstring value@ emitstring newline dropstring 0 ; + + +~ This implements the label transform for all words in a region given as an +~ input string. It is directly analogous to "quit", in interpet.e, but is far +~ more complex. +~ +~ (output buffer start, output point, input string pointer +~ -- output buffer start, output point) +: label-transform + ~ : blank-line + ~ : blank-line + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + ~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ~ : blank-line + ~ : This is the start of a long block of code which has been processed by + ~ : the label transform, meaning it consists of ready-to-run Forth word + ~ : definitions that reference each other by address, suitable for direct + ~ : execution as soon as the cold-start routine has set up the basic + ~ : registers, flags, and memory areas that form Evocation's internal ABI. + ~ : + ~ : Each word definition consists of a dictionary entry header, a + ~ : codeword, and a word body. For words implemented as Forth code, the + ~ : codeword points to the "docol" routine, and the word body is an array of + ~ : pointers to the codewords of other words, occasionally interspersed with + ~ : literal values. For words implemented as machine code, the codeword + ~ : points to the start of the body, and the body is the machine code. + ~ : + ~ : All the word entry headers in this code link to each other, from last + ~ : backwards to first, forming an Evocation dictionary. + ~ : + ~ : The warm-start routine relies on words defined by the label transform, + ~ : as does the log-load routine. + ~ : blank-line + + main-input-buffer dup push-input-buffer + swap attach-string-to-input-buffer + + ~ Save the old values of "here" and "latest", and set the initial values + ~ of the internal ones. These values need to persist across iterations, + ~ since client code will make its own updates to them and then rely on those + ~ updates having taken effect. So we do the swap just once, here outside the + ~ loop, and set it back when the loop ends. + here @ transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest ! + swap transformation-state transformation-state-output-buffer-start ! + here ! + 0 latest ! + ~ Now the stack has nothing of ours on it, so client code can do its thing. + + ~ It's important that the stack has nothing of ours on it that persists + ~ across iterations, so that client code can add and remove stuff there as + ~ it sees fit. + { label-transform-one + ~ (..., done) + + ~ When the loop is done, get the real values of "here" and "latest" + ~ back. The internal "here" is also the output point, and will become our + ~ return value. The internal "latest" is discarded. + { transformation-state transformation-state-output-buffer-start @ + here @ + transformation-state transformation-state-saved-here @ here ! + transformation-state transformation-state-saved-latest @ latest ! + ~ (output buffer start, output point) + + ~ Though we don't actually use transformation-state outside of this + ~ invocation, for tidiness we zero it out. + 0 transformation-state transformation-state-saved-here ! + 0 transformation-state transformation-state-saved-latest ! + 0 transformation-state transformation-state-output-buffer-start ! + + ~ Also put the input source back how it was. + main-input-buffer pop-input-buffer + + exit } if } forever ; + + +~ Log-load transform implementation +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The following code is all part of implementing the log-load transform. +~ For conceptual overview, see the top of this file. + + +~ This outputs code that performs a roll of a given size, for use by the +~ words that rely on the tracked user stack depth. +~ +~ (amount to roll by --) +: log-load-roll + ~ A roll of size 1 is an nop, and a roll of size 0 crashes. + dup 2 > { drop exit } if + + ~ A roll of size 2 is equivalent to a swap, and we compile it as one for + ~ clarity when reading the hexdump. + ~ + ~ Yes, clarity when reading the hexdump. + dup 2 = { + drop + + swap-transform-variables + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + + exit + } if + + swap-transform-variables + L@' roll + L@' lit + swap-transform-variables + + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + swap ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 roll #-- (codeword pointer) + ; + + +~ This outputs code that perfoms an unroll of a given size, for use by the +~ words that rely on the tracked user stack depth. + +~ (amount to unroll by --) +: log-load-unroll + ~ An unroll of size 1 is an nop, and an unroll of size 0 crashes. + dup 2 > { drop exit } if + + ~ Yes, clarity when reading the hexdump! What's so weird about that? :) + dup 2 = { + drop + + swap-transform-variables + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + + exit + } if + + swap-transform-variables + L@' unroll + L@' lit + swap-transform-variables + + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + swap ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , ~ : -8 unroll #-- (codeword pointer) + ; + + +~ This checks the tracked user stack depth and outputs an appropriate roll +~ to put the log address on top, as preparation for calling something that +~ relies on it. +: log-load-roll-log-address + transformation-state transformation-state-user-stack-depth @ + ~ The amount we're rolling includes the log address, which is not a user + ~ value, so we add 1. + 1 + + log-load-roll ; + + +~ This checks the tracked user stack depth and outputs an appropriate unroll +~ to put the log address back at the bottom, as cleanup after calling +~ something that relies on it. +: log-load-unroll-log-address + transformation-state transformation-state-user-stack-depth @ + ~ The amount we're rolling includes the log address, which is not a user + ~ value, so we add 1. + 1 + + log-load-unroll ; + + +~ This checks the tracked user stack depth and outputs an appropriate roll +~ to put the saved label value on top, as preparation for calling something +~ that consumes it. +: log-load-roll-saved-label + transformation-state transformation-state-user-stack-depth @ + ~ The amount we're rolling includes both the log address and the label + ~ value, neither of which are user values, so we add 2. + 2 + + log-load-roll ; + + +~ This checks the tracked user stack depth and outputs an appropriate unroll +~ to put a saved label value on the bottom, as a way of safely storing it away +~ when it's newly generated. +: log-load-unroll-saved-label + transformation-state transformation-state-user-stack-depth @ + ~ The amount we're rolling includes both the log address and the label + ~ value, neither of which are user values, so we add 2. + 2 + + log-load-unroll ; + + +~ (name pointer --) +: log-load-compile-dynamic-word + log-load-roll-log-address + + swap-transform-variables + ~ Looking these up in reverse order saves us some stack juggling. Does it + ~ help readability, or hurt it? Who can say... + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + ~ (name pointer, log-load-comma, log-load-find-execution-token, litstring) + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + 3roll here @ swap packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + log-load-unroll-log-address ; + + +~ When we want the log-load routine to run a word that wasn't statically +~ compiled-in to the target executable, we output code that looks up the word +~ by name on the log, then calls it. +~ +~ We update the user stack depth as we go, to account for our internal +~ needs. The last thing our generated code does is execute the word we were +~ asked to, and we have no way of knowing what its stack delta will be, so +~ that final delta is our caller's responsibility. The caller should only +~ consider the delta of the word it requested itself; we handle everything +~ pertaining to retrieving, and then consuming, its execution token. +~ +~ (name pointer --) +: log-load-execute-dynamic-word + log-load-roll-log-address + + swap-transform-variables + ~ This is reverse order again. + L@' swap + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + ~ (name pointer, swap, log-load-find-execution-token, litstring) + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + 3roll here @ swap packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + + ~ Now the execution token is on the stack, immediately below the log + ~ address, so we apply a delta for it. + 1 transform-apply-stack-delta + + log-load-unroll-log-address + + swap-transform-variables + L@' execute + swap-transform-variables + + offset-to-target-address-space , ~ : -8 execute #-- (codeword pointer) + + ~ Invoking execute consumes the execution token, which is a delta of -1. + ~ Any additional delta is our caller's responsibility, per above. + -1 transform-apply-stack-delta ; + + +~ We generate code that looks up "docol" by name, runs it to get the +~ codeword pointer, then finally appends it to the entry. +~ +~ This one's unusual in that it first executes the word, then compiles the +~ result. To avoid rolling and unrolling repeatedly, we implement it as a +~ special case. For clarity's sake we put the code here, with the other +~ dynamic word stuff. +~ +: log-load-compile-docol + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma + L@' execute + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ s" docol" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 execute #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + log-load-unroll-log-address ; + + +~ There's one more compilation case, where we wish to compile an integer +~ literal. Again, for clarity, we do it here. +~ +~ (integer value --) +: log-load-compile-literal + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma + L@' lit + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ s" lit" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + swap ~ : provide-hex + , ~ : -8 # #-- (integer literal) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + log-load-unroll-log-address ; + + +~ This is the alternate version of "create" for use with the log-load +~ transform. This one is quite unlike the regular "create"; rather than +~ creating an entry on the log directly, its job is to output words which, +~ when they're later executed, will do create's job. +~ +~ In practice that means outputting a codeword pointer to run a +~ statically-compiled word that does the work. The implementation of +~ log-load-create is in language/static/log-load.e. +~ +~ It's worth keeping in mind that this alternate only gets called for +~ manual invocations of "create". It isn't called from the colon alternate. +: log-load-create-alternate + ~ In immediate mode, we have special behavior because this is fundamental + ~ to bootstrapping the log. In compile mode, we compile a dynamic call, + ~ which is the same thing that would happen if we didn't have an alternate + ~ at all. + interpreter-flags @ 0x01 & { + ~ Notice that when we're in compile mode, we aren't actually defining a + ~ word at the time the log-load routine runs, so we don't have magic + ~ comments. + s" create" log-load-compile-dynamic-word + } { + ~ : blank-line + ~ : create + log-load-roll-log-address + + swap-transform-variables + L@' log-load-create + L@' swap + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-create #-- (codeword pointer) + + ~ We've consumed a string pointer from the stack, so that's a delta of -1. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + } if-else ; + + +~ This is the alternate version of ":" for use with the log-load transform. +~ Its code is the same as the regular ":" except as noted below. It is likely +~ to be extremely useful to read and understand ":" in +~ language/dynamic/dynamic.e before attempting to understand +~ "log-load-colon-alternate". +: log-load-colon-alternate + word value@ + ~ : blank-line + ~ : blank-line + ~ : provide-string-copy + ~ : # is defined here via the log-load transform. + ~ : indent + + ~ Calling log-load-create-alternate would result in some redundant rolling + ~ and unrolling, so we do it together like this instead. + log-load-roll-log-address + + swap-transform-variables + L@' log-load-create + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + swap here @ swap packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-create #-- (codeword pointer) + + log-load-unroll-log-address + + dropstring + + ~ We generate code that looks up "docol" by name, runs it to get the + ~ codeword pointer, then finally appends it to the entry. + log-load-compile-docol + + ~ This is where we would mark the entry hidden, but we don't do that. It + ~ won't shadow anything and it won't be called until the entire log-load + ~ routine has finished. + + ~ Switching between immediate and compile mode is one of the very few + ~ things that happens NOW, while the log-load transform is actually running. + ] + ; + + +~ See notes on label-self-codeword-alternate for what problem this is +~ solving. +~ +~ Since self-codeword's real definition is in language/dynamic/dynamic.e, +~ which absolutely cannot be loaded yet at the time we output docol at the +~ very beginning of language/static/core.e, we need to provide an alternate +~ for the log-load transform as well, even though only the label transform has +~ the reproducibility issue. +: log-load-self-codeword-alternate + ~ It's important to remember, this is not an immediate word! It needs to + ~ produce correct compiled output, when invoked in compile mode. Since it's + ~ also a regular word that exists, correct output is a reference to the + ~ non-alternate version. + interpreter-flags @ 0x01 & { + s" self-codeword" log-load-compile-dynamic-word + } { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-self-codeword + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-self-codeword #-- (codeword pointer) + + log-load-unroll-log-address + } if-else + ; make-immediate + + +~ This is the alternate version of ";" for use with the log-load transform. +~ Its code is the same as the regular ";" except as noted below. It is +~ likely to be extremely useful to read and understand ";" in +~ language/dynamic/dynamic.e before attempting to understand +~ "log-load-semicolon-alternate". +: log-load-semicolon-alternate + ~ We generate code that looks up "exit" by name and appends it to the + ~ entry. + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ s" exit" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + log-load-unroll-log-address + + ~ : deindent + + ~ This is where we would unhide the entry, but again, we don't do that. + + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of ;. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ This is the alternate version of ";asm" for use with the log-load +~ transform. Its code is the same as the regular "create" except as noted +~ below. It is likely to be extremely useful to read and understand ";asm" in +~ language/dynamic/dynamic.e before attempting to understand "log-load;asm". +: log-load-semicolon-assembly-alternate + ~ We generate code that statically invokes log-load-semicolon-assembly, + ~ which does all the actual work. There's quite a few steps, so it makes + ~ sense to have a word that bundles them up. + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-semicolon-assembly + swap-transform-variables + + ~ The stack delta of this call is 0. + offset-to-target-address-space , + ~ : -8 log-load-semicolon-assembly #-- (codeword pointer) + + log-load-unroll-log-address + + ~ : deindent + + ~ This is where we would unhide the entry, but again, we don't do that. + + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of ;. + [ ' [ entry-to-execution-token , ] + ; make-immediate + + +~ This just does the same thing [ always does, but having it as an alternate +~ means it happens at transformation time, which is sooner than "immediate" +~ time. The log load transform is weird like that, it has three different +~ times things can happen, rather than the usual two. +: log-load-left-square-brace-alternate + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of the alternate. + [ ' [ entry-to-execution-token , ] + ; make-immediate + +~ We need this one, too. It's not even an immediate word normally! +: log-load-right-square-brace-alternate ] ; make-immediate + + +: log-load-comma-alternate + ~ In immediate mode, we have special behavior because of the "here" magic. + ~ In compile mode, we compile a dynamic call, which is the same thing that + ~ would happen if we didn't have an alternate at all. + interpreter-flags @ 0x01 & { + s" ," log-load-compile-dynamic-word + } { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-comma + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + ~ We consumed the value, so we apply a delta. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } if-else + ; make-immediate + + +: log-load-variable-alternate + ~ In immediate mode, we have special behavior because of the "here" magic. + ~ In compile mode, we compile a dynamic call, which is the same thing that + ~ would happen if we didn't have an alternate at all. + interpreter-flags @ 0x01 & { + s" variable" log-load-compile-dynamic-word + } { + ~ Calling log-load-create-alternate would result in some redundant rolling + ~ and unrolling, so we do it together like this instead. + log-load-roll-log-address + + swap-transform-variables + L@' log-load-variable + L@' 3unroll + swap-transform-variables + + offset-to-target-address-space , ~ : -8 3unroll #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-variable #-- (codeword pointer) + + ~ We consumed the string and address, so we apply a delta. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + } if-else + ; make-immediate + + +: log-load-keyword-alternate + ~ In immediate mode, we have special behavior because of the "here" magic. + ~ In compile mode, we compile a dynamic call, which is the same thing that + ~ would happen if we didn't have an alternate at all. + interpreter-flags @ 0x01 & { + s" keyword" log-load-compile-dynamic-word + } { + ~ Calling log-load-create-alternate would result in some redundant rolling + ~ and unrolling, so we do it together like this instead. + log-load-roll-log-address + + swap-transform-variables + L@' log-load-keyword + L@' swap + swap-transform-variables + + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-keyword #-- (codeword pointer) + + ~ We consumed the string, so we apply a delta. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } if-else + ; make-immediate + + +~ Yeah comments have to go. +: log-load-tilde-alternate + ' ~ entry-to-execution-token execute + ; make-immediate + + +~ Strings are important and must happen now, now, now. +: log-load-string-alternate + ~ Wrapping s" is surprisingly difficult; see label-string-alternate + ~ for detailed notes on how that works. Once we've finished the + ~ transform-time part, our implementations will diverge, but this first bit + ~ is the same. + interpreter-flags @ + ' s" entry-to-execution-token + swap-transform-variables + ~ Since [ is an immediate word, we have to go to extra trouble to compile + ~ it as part of the alternate. + [ ' [ entry-to-execution-token , ] + execute + swap-transform-variables + swap interpreter-flags ! + + ~ Nope, doing it twice didn't make that any less of a mouthful. + ~ + ~ Having done this, we have the string pointer on the stack at transform + ~ time (not, mind you, at log-load time, as yet). Now it is our job to + ~ either compile it, or invoke it "immediately". Recall that the log-load + ~ transform's "immediate" time, which we also call log-load time, is + ~ analogous to the label transform's "compile" time. The log-load + ~ transform's "compile" time is an additional layer of indirection. + ~ + ~ No matter which mode we're in, the first thing we want to do is get the + ~ string onto the value stack at log-load time. So we compile code to do + ~ that, first. We do that using the static "litstring", which we find by + ~ label. + ~ + ~ If this is all too twisty, it might be helpful to go re-read the + ~ definition of log-load-compile-literal, which does a simpler version of + ~ this same task (because integers are easier than strings). + + swap-transform-variables + L@' litstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ swap packstring 8 packalign here ! + + ~ Now the string pointer is on the stack at log-load time, so we apply a + ~ delta for it. + 1 transform-apply-stack-delta + + ~ If we're in immediate mode, we're done! Yay! Putting the string on the + ~ stack at log-load time is what we wanted. If not... + interpreter-flags @ 0x01 & { + ~ We're in compile mode, so we need to look up the ultimate, dynamic, + ~ log-based, super-atomic space rocket copy of "litstring" and use that. + ~ We could call log-load-compile-dynamic-word here, but, as usual, it + ~ would produce some excessive rolling and unrolling, so we do its job + ~ ourselves instead. + log-load-roll-log-address + + swap-transform-variables + ~ As usual, we do these in reverse. + L@' log-load-comma-string + L@' swap + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , + ~ : -8 litstring #-- (codeword pointer) + here @ s" litstring" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma-string #-- (codeword pointer) + + ~ We consumed the string pointer at log-load time, so we apply a delta + ~ for it. + ~ + ~ Notice by the way how the nearby calls to log-load-unroll-log-address + ~ rely on this being split into two deltas like this, even though they + ~ net out to zero; we aren't doing it just for kicks. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } if + ; make-immediate + + +: log-load-dot-string-alternate + ' log-load-string-alternate entry-to-execution-token execute + + interpreter-flags @ 0x01 & { + ~ Hey look, it's the one time we're doing something simple enough that + ~ we can actually benefit from log-load-compile-dynamic-word as something + ~ more than an example to start from. :) + s" emitstring" log-load-compile-dynamic-word + } { + swap-transform-variables + L@' emitstring + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 emitstring #-- (codeword pointer) + } if-else + ; make-immediate + + +~ No matter what mode we're in, we read a name at transform time. Then we +~ look up the name at either log-load time or runtime, depending. +: log-load-tick-alternate + ~ Read the name. + word value@ + + ~ Get the name onto the stack at log-load time. + swap-transform-variables + L@' litstring + swap-transform-variables + + offset-to-target-address-space , ~ : -8 litstring #-- (codeword pointer) + here @ swap packstring 8 packalign here ! + + ~ Apply a delta for the string pointer. + 1 transform-apply-stack-delta + + dropstring + + ~ Now break out the remaining behavior based on mode. + interpreter-flags @ 0x01 & { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + L@' log-load-comma-string + L@' swap + L@' log-load-comma + L@' log-load-find-execution-token + L@' litstring + swap-transform-variables + + ~ The overall stack delta of this sequence is 0. + offset-to-target-address-space , + ~ : -8 litstring #-- (codeword pointer) + here @ s" litstring" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + offset-to-target-address-space , ~ : -8 swap #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma-string #-- (codeword pointer) + + offset-to-target-address-space , + ~ : -8 litstring #-- (codeword pointer) + here @ s" find" packstring 8 packalign here ! + offset-to-target-address-space , + ~ : -8 log-load-find-execution-token #-- (codeword pointer) + offset-to-target-address-space , + ~ : -8 log-load-comma #-- (codeword pointer) + + ~ We consumed the string pointer at log-load time, so we apply a delta + ~ for it. As in log-load-string-alternate, this needs to be split into + ~ two parts like this. + -1 transform-apply-stack-delta + + log-load-unroll-log-address + } { + log-load-roll-log-address + + swap-transform-variables + L@' log-load-find + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-find #-- (codeword pointer) + + ~ We leave an execution token on the log-load-time stack, so no delta + ~ needed. + + log-load-unroll-log-address + } if-else + ; make-immediate + + +~ Because docol requires it, we provide a special mini-version of the label +~ system. We only do L@' and L!', because that's all we need. Unlike the +~ version of this feature for the label transform, for the log-load transform, +~ we heavily restrict the use-case. +~ +~ The implementation strategy is that we ignore the label name, and store +~ the value on the stack when the generated log-load routine runs. So, each +~ instance of L@' must be closely followed by a matching instance of L!'. Each +~ label can only ever be used exactly once, and it must be a backward +~ reference. Furthermore, the stack is used in a very specific way, which the +~ transformed code must be compatible with. The easiest way to explain it is +~ by showing the interface of these words from the transformed code's +~ perspective: +~ +~ L!' is (preserved values, ..., ..., value of label +~ -- value of label, preserved values, ..., ...) +~ L@' is (value of label, preserved values, ..., ...) +~ -- preserved values, ..., ..., value of label) +~ +~ The preserved values are simply more items on the stack, which the +~ alternates take pains not to interfere with. The alternates output a roll or +~ unroll of an appropriate size. Hopefully, in reading this, you have the +~ question: How can the alternates possibly know what size is appropriate? +~ The answer is that the log-load transform carefully tracks how many items +~ the transformed code is expected to have on the stack, based on its +~ hardcoded understanding of each word that's expected to be relevant, looked +~ up by the word's name. The number of items is stored in the user-stack-depth +~ field of transformation-state. +~ +~ There is no adjustment done on the saved value, since it's created in the +~ target address space and then also used in the target address space. It +~ wouldn't actually be necessary to use this at all, since checking "here" +~ would be sufficient, but then the code would have to do something different +~ depending on which transform it's running under, and there'd have to be a +~ mechanism for that. +~ +~ This is sufficient to implement docol, and that's probably the only thing +~ it should be used for. +: log-load-L@'-alternate + word dropstring + log-load-roll-saved-label + ~ We now begin thinking of the label value as user data, so we need to + ~ notate that appropriately. + 1 transform-apply-stack-delta + ; make-immediate + +: log-load-L!'-alternate + word dropstring + ~ We cease to think of the label value as user data, so we need to notate + ~ that appropriately. + -1 transform-apply-stack-delta + log-load-unroll-saved-label + ; make-immediate + + +~ Not to be outdone by the label transform, the log-load transform also +~ offers alternates of all the high-level flow-control words: if, unless, +~ if-else, forever, and while. Unlike the label transform, we also need to +~ implement alternates of { and }, because their values need to be on the +~ stack at log-load "immediate" time, not at transform time. +~ +~ Anyway, most of the implementation is deferred to pre-packaged words in +~ language/static/log-load.e. +: log-load-left-curly-brace-alternate + log-load-roll-log-address + + swap-transform-variables + L@' log-load-left-curly-brace + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-left-curly-brace #-- (codeword pointer) + + ~ It pushes a start pointer onto the stack. + 1 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : { + ~ : indent + ; make-immediate + + +: log-load-right-curly-brace-alternate + ~ : deindent + ~ : } + log-load-roll-log-address + + swap-transform-variables + L@' log-load-right-curly-brace + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-right-curly-brace #-- (codeword pointer) + + ~ It pushes a length value onto the stack. + 1 transform-apply-stack-delta + + log-load-unroll-log-address + ; make-immediate + + +~ (start pointer, length --) +: log-load-if-alternate + ~ : if + log-load-roll-log-address + + swap-transform-variables + L@' log-load-if + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-if #-- (codeword pointer) + + ~ It pops the start and length. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (start pointer, length) +: log-load-unless-alternate + ~ : unless + log-load-roll-log-address + + swap-transform-variables + L@' log-load-unless + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-unless #-- (codeword pointer) + + ~ It pops the start and length. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (true start, true length, false start, false length) +: log-load-if-else-alternate + ~ : if-else + log-load-roll-log-address + + swap-transform-variables + L@' log-load-if-else + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-if-else #-- (codeword pointer) + + ~ It pops two pairs of start and length. + -4 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (start, length --) +: log-load-forever-alternate + ~ : forever + log-load-roll-log-address + + swap-transform-variables + L@' log-load-forever + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-forever #-- (codeword pointer) + + ~ It pops the start and length. + -2 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ (test start, test length, body start, body length --) +: log-load-while-alternate + ~ : while + log-load-roll-log-address + + swap-transform-variables + L@' log-load-while + swap-transform-variables + + offset-to-target-address-space , + ~ : -8 log-load-while #-- (codeword pointer) + + ~ It pops two pairs of start and length. + -4 transform-apply-stack-delta + + log-load-unroll-log-address + ~ : blank-line + ; make-immediate + + +~ This implements the log-load transform for a single word. It is directly +~ analogous to "interpret", and reading language/dynamic/interpret.e may help +~ in understanding it, though it's meant to still make sense on its own. +~ +~ It expects to be called from "log-load-transform", below, which loops. +~ +~ (-- done) +: log-load-transform-one + word + + ~ If no word was returned, end the transformation. + dup 0 = { drop 1 exit } if + + ~ The string is on the top of the stack, so to get a pointer to it we get + ~ the stack address. + ~ (string) + value@ + + ~ Check whether it's one of the words we have alternates for, and look up + ~ the alternate if so. + 0 swap + ~ (name as stack string, placeholder, name pointer) + dup s" create" stringcmp 0 = { + swap drop ' log-load-create-alternate swap } if + dup s" :" stringcmp 0 = { + swap drop ' log-load-colon-alternate swap } if + dup s" self-codeword" stringcmp 0 = { + swap drop ' log-load-self-codeword-alternate swap } if + dup s" ;" stringcmp 0 = { + swap drop ' log-load-semicolon-alternate swap } if + dup s" ;asm" stringcmp 0 = { + swap drop ' log-load-semicolon-assembly-alternate swap } if + dup s" [" stringcmp 0 = { + swap drop ' log-load-left-square-brace-alternate swap } if + dup s" ]" stringcmp 0 = { + swap drop ' log-load-right-square-brace-alternate swap } if + dup s" ," stringcmp 0 = { swap drop ' log-load-comma-alternate swap } if + dup s" variable" stringcmp 0 = { + swap drop ' log-load-variable-alternate swap } if + dup s" keyword" stringcmp 0 = { + swap drop ' log-load-keyword-alternate swap } if + dup s" ~" stringcmp 0 = { + swap drop ' log-load-tilde-alternate swap } if + ~ It is nontrivial to construct a string with a double-quote in it. + dup ' s" entry-to-name stringcmp 0 = { + swap drop ' log-load-string-alternate swap } if + dup ' ." entry-to-name stringcmp 0 = { + swap drop ' log-load-dot-string-alternate swap } if + dup ' ' entry-to-name stringcmp 0 = { + swap drop ' log-load-tick-alternate swap } if + dup s" L@'" stringcmp 0 = { swap drop ' log-load-L@'-alternate swap } if + dup s" L!'" stringcmp 0 = { swap drop ' log-load-L!'-alternate swap } if + dup s" {" stringcmp 0 = { + swap drop ' log-load-left-curly-brace-alternate swap } if + dup s" }" stringcmp 0 = { + swap drop ' log-load-right-curly-brace-alternate swap } if + dup s" if" stringcmp 0 = { swap drop ' log-load-if-alternate swap } if + dup s" unless" stringcmp 0 = { + swap drop ' log-load-unless-alternate swap } if + dup s" if-else" stringcmp 0 = { + swap drop ' log-load-if-else-alternate swap } if + dup s" forever" stringcmp 0 = { + swap drop ' log-load-forever-alternate swap } if + dup s" while" stringcmp 0 = { swap drop ' log-load-while-alternate swap } if + ~ (name as stack string, 0 or alternate entry pointer, name pointer) + + ~ If we have an alternate, we want to run that now, regardless of what + ~ mode we're in. They're all flagged as immediate, but we don't even bother + ~ checking, because it doesn't fully describe their behavior anyway. With + ~ this transform there's three potential times at which we might execute + ~ things, not two. The alternates are more immediate than immediate; they + ~ run NOW, during the transformation. + over { + drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } if + drop drop + ~ (name as stack string) + + ~ Now we might have a compiled word, an immediate word, or an integer + ~ literal. Recall that the word won't actually be looked up until the + ~ routine we're producing is run - that's the whole point - so there's no + ~ check we can perform now that will tell us whether the word we have exists + ~ in the eventual log. Instead, we invert the usual fallback order and + ~ check whether the word could be an integer literal. If it is, we'll + ~ handle that; if not, we'll assume it'll eventually exist. + ~ + ~ This means that code that's run with the log-load transform can't + ~ shadow an integer literal with a word definition. Oh, so limiting. + value@ read-integer 0 = { + ~ It's a number. + ~ + ~ (name as stack string, integer value) + dropstring-with-result + ~ (integer value) + + interpreter-flags @ 0x01 & { + ~ We're in compile mode, so we want to generate code which will compile + ~ the number. + log-load-compile-literal + 0 exit + } if + + ~ We're in interpret mode, so we want to generate code which will push + ~ the number to the stack. + ~ + ~ This is an immediate effect, so once we've done it, we update the user + ~ stack depth. An integer literal is a stack-depth delta of 1. + swap-transform-variables L@' lit swap-transform-variables + offset-to-target-address-space , ~ : -8 lit #-- (codeword pointer) + ~ : provide-hex + , ~ : -8 # #-- (integer literal) + 1 transform-apply-stack-delta + 0 exit + } if + ~ (name as stack string) + + ~ We know it's a regular word, and we're assuming it will exist at + ~ runtime. We of course have no way to check what flags it will have, which + ~ means immediate words don't work with this transform. We still treat it + ~ differently based on whether we're in compile mode. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. We compile code that compiles the word. + ~ + ~ Since that's not an immediate effect, we don't need to update the + ~ user stack depth. Instead, this is a key spot where we rely on that + ~ knowledge, to roll and unroll the log address. + value@ log-load-compile-dynamic-word + dropstring 0 exit + } if + ~ (name as stack string) + + ~ At this point we know we're in immediate mode and have a regular word. + ~ While we still have the name pointer handy, we check what delta this word + ~ will cause for the user stack depth, when run. See + ~ transform-get-stack-delta for more explanation of this. We keep track of + ~ the proposed delta until we actually process the word, down below. + value@ dup transform-get-stack-delta swap + ~ (name as stack string, proposed stack depth delta, name pointer) + + ~ We're in immediate mode. We compile code that runs the word immediately. + ~ We check whether there's a label for the word; if there is, we'll output + ~ that. Otherwise we'll output code that looks it up in the log and runs it. + ~ + ~ Just like in label-transform, we use find-label to check whether a label + ~ exists without declaring a dependency on it, then if it does, we do + ~ use-label to ask for its value. + ~ + ~ There's one additional wrinkle to remember here: We're running inside + ~ the label loop, and warm-start appears before all the normal words in the + ~ executable. So all the labels we'll be checking are forwared references, + ~ and on the very first pass they definitely won't be defined. That's fine + ~ though, they will exist on all subsequent passes, so things will + ~ definitely still converge. + ~ + ~ The first pass will never accidentally think it succeeded, because even + ~ the reference to L' cold-start from the ELF header is a forward reference + ~ and won't exist on the first pass. + dup + swap-transform-variables + find-label + swap-transform-variables + { + ~ Again just like in label-transform, we declare our use of the label + ~ and get a value for it. + ~ : provide-string-copy + swap-transform-variables + intern-label use-label + swap-transform-variables + ~ (name as stack string, proposed stack depth delta, label value) + + ~ Like in label-transform, this is a codeword pointer, so we just output + ~ it directly. Also as before, because we don't have to examine it, we + ~ don't have to do anything special in the case where it's zero due to the + ~ way the label loop works. + ~ + ~ This is an immediate effect, so once we've done that, we update the + ~ user stack depth. + offset-to-target-address-space , + ~ : -8 # #-- (codeword pointer) + transform-apply-stack-delta + dropstring 0 exit + } if + ~ (name as stack string, proposed stack depth delta, name pointer) + + ~ There's no label for the word; that means it wasn't statically + ~ compiled-in to the target executable. So we output code that looks up the + ~ word by name on the log, then calls it. + ~ + ~ This is also an immediate effect, despite being distinct from the above + ~ case, so once we've done that, we update the user stack depth. + ~ + ~ There's no such thing as not finding the word, with this transform. So + ~ once we're done, we just exit. + log-load-execute-dynamic-word + transform-apply-stack-delta + dropstring 0 ; + + +~ This implements the log-load transform for all words in a region given as +~ an input string. It is directly analogous to "quit", in +~ language/dynamic/interpret.e, but is far more complex. +~ +~ (output buffer start, output point, input string pointer +~ -- output buffer start, output point) +: log-load-transform + ~ : blank-line + ~ : This is the start of the log-load routine, which is a long block of + ~ : code that has been processed by the log-load transform. It is part of + ~ : the warm-start routine, which does other things before and after it. + ~ : For clarity's sake, to avoid weird nesting, the section header above + ~ : calls this the warm-start section of the executable, but in a sense it + ~ : might be more accurate to call it the log-load section. + ~ : + ~ : The routine is interpreted Forth code, just as the warm-start routine + ~ : as a whole is; see above. + ~ : + ~ : The job of the log-load routine is to create runnable code in the + ~ : dynamic log, at runtime. The normal way to create a Forth executable + ~ : is to use label-transformed code to implement a minimal set of + ~ : functionality needed for the log-load routine to run, then invoke the + ~ : log-load routine to copy a more complete set of functionality into + ~ : memory. + ~ : + ~ : The log-load routine is super important, but also extremely verbose, + ~ : which necessarily makes it hard to read. If you're skimming this file + ~ : for the first time to get a sense of what it contains, you might want + ~ : to search for the words "label transform" to get to the stuff that makes + ~ : better introductory reading. + ~ : blank-line + + main-input-buffer dup push-input-buffer + swap attach-string-to-input-buffer + + ~ Save the old values of "here" and "latest", and set the initial values + ~ of the internal ones. These values need to persist across iterations, + ~ since client code will make its own updates to them and then rely on those + ~ updates having taken effect. So we do the swap just once, here outside the + ~ loop, and set it back when the loop ends. + ~ + ~ We also take this opportunity to initialize the output-buffer-start and + ~ user-stack-depth fields of transformation-state. + here @ transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest ! + swap transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + here ! + 0 latest ! + ~ Now the stack has nothing of ours on it, so client code can do its thing. + + ~ It's important that the stack has nothing of ours on it that persists + ~ across iterations, so that client code can add and remove stuff there as + ~ it sees fit. + { log-load-transform-one + ~ (..., done) + + ~ When the loop is done, get the real values of "here" and "latest" + ~ back. The internal "here" is also the output point, and will become our + ~ return value. The internal "latest" is discarded. + { transformation-state transformation-state-output-buffer-start @ + here @ + transformation-state transformation-state-saved-here @ here ! + transformation-state transformation-state-saved-latest @ latest ! + ~ (output buffer start, output point) + + ~ Though we don't actually use transformation-state outside of this + ~ invocation, for tidiness we zero it out. + 0 transformation-state transformation-state-saved-here ! + 0 transformation-state transformation-state-saved-latest ! + 0 transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + + ~ Also put the input source back how it was. + main-input-buffer pop-input-buffer + + exit } if } forever ; + + +~ Hex transform implementation +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The following code is all part of implementing the hex transform. For +~ conceptual overview, see the top of this file. +~ +~ The hex transform operates under some very complex memory-management +~ assumptions, even compared to the other transforms, so it's worth going over +~ all that and studying how it comes together, even though much of it is +~ material that has been explained elsewhere. This explanation is here with +~ the implementation details rather than at the top of the file, because it's +~ only necessary to understanding how to modify the transform, not how to use +~ it. +~ +~ This is the bit of the hex transform where all the memory-management +~ assumptions are in play at once, so, a quick refresher. The transform +~ itself is running in the outer context; hex-trace and its siblings are +~ part of Evocation's main log and dictionary. This is also true for the +~ label and log-load transforms. Evocation has two global variables, +~ "here" and "latest", which are the root of all references to the log and +~ dictionary, respectively. Remember, the log is the structure used for +~ memory allocation, and the dictionary, which forms the majority of the +~ log, is the structure used for looking up words by name. +~ +~ Every transform, in its various ways, is changing what it means to +~ "execute" and "compile" code; therefore, when the transforms are invoked, +~ they are passed an "output buffer" which is used as the destination for +~ any compilation that occurs, and any scratch space that is needed. When +~ more than one transform is running at once (such as when the hex transform +~ operates on code that is itself running the label transform), each +~ transform has its own separate output buffer. +~ +~ Furthermore, the transformation facility helps each transform to swap out +~ the values of "here" and "latest", and restore them later, so that the code +~ being transformed will see the output buffer as if it is the "real" log, and +~ will see the separate dictionary stored within the output buffer as if it is +~ the "real" dictionary. +~ +~ All this stuff about the output buffer applies to every transform. The +~ hex transform takes it one step further, and as such there are two +~ additional memory regions that are important to understanding it. The first +~ is the label-loop buffer, which is allocated out of the inner log, and used +~ to hold draft versions of the binary output that the inner compilation +~ process would eventually emit to the standard output stream, if it were +~ being allowed to emit output in the normal way. The second is the output +~ metadata buffer, which is allocated out of the outer log, and used to hold +~ metadata such as comments and formatting pertaining to code structure, which +~ will need to be referenced when actually outputting the final hex dump. +~ +~ So, the label-loop buffer can be thought of as scratch space for the +~ compiled binary output from the code being transformed, and the output +~ metadata buffer can be thought of as the scratch space for the formatted hex +~ dump that will be made out of that output. It's important not to confuse +~ either of them with the output buffer, which is the scratch space used as +~ part of the compilation process. +~ +~ Confusingly, the output buffer and the label-loop buffer both contain +~ logs and dictionaries, at least potentially, if the code being compiled is +~ Forth code. It is also possible to use the hex transform on assembly code, +~ in which case the label-loop buffer won't have a log in it but the output +~ buffer still will. In practice, the hex transform frequently winds up +~ needing to be careful about the log and dictionary in the output buffer, but +~ rarely does anything that directly touches the log and dictionary in the +~ label-loop buffer, so you can usually ignore the latter when reading this +~ code. +~ +~ Allocating the output buffer and output metadata buffer is the +~ responsibility of the caller of hex-transform. Allocating the label-loop +~ buffer is the responsibility of label-loop, which is called by the code +~ being transformed, but the hex transform intervenes in that allocation to +~ save information about it. +~ +~ The output buffer is referenced during the transform via the +~ transformation-state-output-buffer-start field of the global +~ "transformation-state" variable, and the output metadata buffer is +~ referenced via the transformation-state-output-metadata field of that same +~ variable. The label-loop buffer is referenced from the +~ hex-output-metadata-label-loop-buffer-start and -length fields of the +~ output metadata's top-level header, and the code being transformed passes +~ around its own reference to that same buffer. +~ +~ Finally, recall that, when Evocation itself is the thing being +~ transformed, the code under transformation includes its own copy of the +~ transformation facility, along with all the rest of Evocation. When the code +~ under transformation invokes the label and log-load transforms, it will do +~ so using the copies of those transforms which have been transformed by the +~ hex transform. The same goes for most Evocation internals invoked by the +~ compilation process, except for whatever specific exceptions the hex +~ transform creates. Do not confuse the inner copies of anything with the +~ outer copies. Also try not to worry too much about the inner-inner copies, +~ let the inner transforms deal with them. +~ +~ Got all that background fresh in your mind? Okay, time to get concrete! +~ The output metadata is a header structure followed by an array of entry +~ structures, as follows: +~ +~ (header start) +~ 0x00 - 0x07 Label-loop buffer start +~ 0x08 - 0x0f Label-loop buffer length +~ (entry start) +~ ... + 0x00 - ... + 0x07 Data pointer +~ ... + 0x08 - ... + 0x0f Referenced data length +~ ... + 0x10 - ... + 0x17 String pointer +~ (entry fields repeat at successive offsets, until...) +~ ... + 0x00 - ... + 0x07 (end) Zero, used as a delimiter +~ +~ +~ Magic comment syntax +~ ~~~~~~~~~~~~~~~~~~~~ +~ +~ How, the sufficiently determined reader may ask, does all this output +~ metadata get created? Surely, the reader may rightly think, creating +~ metadata entries which fully describe a compilation process must entail +~ gathering and synthesizing information from disparate stages of that +~ process, which seems quite involved. +~ +~ That is correct: It is quite involved. It would be nice if there were a +~ simple trick, but this appears to be essential complexity. Several +~ approaches were considered. In principle it would be possible to have a +~ specific trap defined here in this file for every word that generates +~ nontrivial output, and keep knowledge of what information to gather from +~ those words in the trap definitions. However, that would bind the important +~ semantics quite closely to the already-overwhelming topic of the +~ transformation data structures, and make it all but impossible to port +~ Evocation to a new architecture. The knowledge we wish to capture is really +~ knowledge about an instruction set architecture, not about data structures. +~ +~ Instead, following the principle that different kinds of knowledge on the +~ same topic should live close together, we've defined a magic-comment syntax +~ which allows the assembly-language words in language/static/amd64.e to +~ describe their own metadata, and is versatile enough to do the same for +~ future architectures. +~ +~ When the compiler operates normally, without the hex transform, these +~ magic comments are simply regular comments, and are discarded as the +~ interpreter finds them. When the compiler runs under the hex transform, they +~ are instead recognized as commands to be processed by the hex transform. +~ Magic comments can only appear in the body of a word being compiled, not at +~ the top level. The hex transform intervenes in the compilation process to +~ insert calls to its own internal words, which are executed, not when the +~ comment is read, but later, when the word it was compiled into is called. +~ When the word in question is itself part of the compiler, the magic comments +~ will be able to see and work with all the state that exists as it runs, and +~ gather it as they wish. +~ +~ There are several kinds of magic comment. All of them begin with the +~ characters : and space as the first two characters of the comment body (and +~ don't forget that there's a space after ~, as well). The syntax on the rest +~ of the line determines what type of command it is. +~ +~ Here are some examples: +~ +~ ~ : Intriguing commentary goes here. +~ ~ : 5 This comment describes the next five bytes of output. +~ 777 pack32 ~ : -4 This comment describes the previous four bytes. +~ +~ ~ : indent +~ ~ : deindent +~ ~ : fresh-line +~ ~ : blank-line +~ +~ ~ : 1 adjust-length +~ ~ : -10 adjust-start +~ ~ : 1 data-adjust-length +~ ~ : -1 data-adjust-start +~ +~ ~ : 0x1000 set-output-point +~ ~ : 8 adjust-output-point +~ ~ : data-set-output-point +~ ~ : 1 data-adjust-output-point +~ +~ ~ : 1 suppress +~ ~ : delete-first-comment-at-output-point +~ ~ : delete-last-comment-at-output-point +~ +~ ~ : Do a thing with # and # ? +~ ~ : provide-decimal +~ ~ : provide-hex +~ ~ : provide-hex8 +~ ~ : provide-hex16 +~ ~ : provide-hex32 +~ ~ : provide-hex64 +~ ~ : provide-string +~ ~ : provide-string-copy +~ ~ : provide-keyword +~ ~ : provide-data +~ ~ : drop-subitem +~ ~ : swap-subitems +~ ~ : 3 roll-subitems +~ +~ By the way, the reason it's possible to write these examples is that +~ they're all embedded within an outer comment, the text you're reading, so +~ they don't look like real magic comments to the hex transform. Hopefully +~ that's not too confusing; there isn't really another way. +~ +~ So. You'll have noticed that some magic comments seem to be descriptive +~ text, and others seem to be commands. Every magic comment, in one way or +~ another, creates or manipulates the metadata entries, which are stored in +~ an array inside the output metadata as global mutable state. There are +~ several phases of processing, and if you've gotten this far, you likely need +~ to understand what they are and what order they happen in. +~ +~ The simplest kind of comment is the "line comment", the first example +~ above. Any comment that doesn't match some more-specific syntax is treated +~ as a line comment. It has not escaped Irenes' notice that this means your +~ syntax errors will seem to half-work; sorry about that. When a line comment +~ is executed, it creates a metadata entry at the end of the array of entries, +~ of -entry-type-line-comment, attached to the latest output point. +~ +~ This is the general pattern: Any magic comment that creates a metadata +~ entry will always create it at the end of the entry array, and will always +~ attach it to the latest output point as of the time the comment executes. +~ Notice that, although the entry array will eventually be sorted by the +~ addresses entries are attached to, at the time entries are created they're +~ simply appended. This is rarely an important distinction, but when it is, it +~ is. +~ +~ What is the latest output point? Well, the hex transform has trapped all +~ the words from core that compilation processes use to directly append bytes +~ to the label-loop buffer, including pack8, packstring, and the variants +~ thereof. The traps are able to tell when the destination is in the +~ label-loop buffer, and they ignore any writes that aren't. The traps keep +~ track of the next address AFTER whatever was just written, and store that +~ in the output metadata header so magic comments can make use of it. +~ +~ It's necessary to take this sneaky approach, because the compiler is free +~ to write things in any order it wants; the label loop goes back to the start +~ every so often, and the high-level flow-control words even slide things +~ around after the fact. The compiler is also free to pass around addresses +~ however it wants within itself, and without restricting that, there's no way +~ for the hex transform to know which value represents the place stuff MIGHT +~ be written to. +~ +~ The semantics of the latest output point are simple enough that they're +~ easy to keep in mind while writing magic comments. In practice, the output +~ point is almost never the cause of confusion about the behavior of magic +~ comments, but it's important to know about since it's the input the whole +~ thing starts with. +~ +~ Now, one thing to keep in mind is that every metadata entry has both an +~ address in the label-loop buffer that it attaches to, and a length field. +~ Line comments insert themselves in between lines of output in the hex dump, +~ and don't otherwise affect the surrounding formatting, so they don't need to +~ make use of the length and it's always set to zero. +~ +~ Now the second example above, which starts with the number 5 before its +~ descriptive text. When the first space-separated word of a magic comment's +~ body is a valid integer literal, this is taken as a parameter; different +~ types of magic comment use that parameter in different ways. The parameter +~ can be positive or negative, and can be written in any base Evocation +~ normally supports. +~ +~ When a parameter is given (even if it's zero), and the comment doesn't +~ match some other more-specific syntax, it's treated as a "suffix comment". +~ Much like a line comment, when a suffix comment is executed, it creates a +~ metadata entry at the end, of -entry-type-suffix-comment, attached to the +~ latest output point. The command uses the parameter as the initial value of +~ the entry's length field, but it's worth being aware that other commands may +~ change it later. +~ +~ It's called a suffix comment because, when all the passes described below +~ have run and the formatting happens, it will appear at the end of a line of +~ text, after the byte values it's attached to. Things like assembly-language +~ instructions should almost always be suffix comments, because this makes it +~ easy for a human reader to see which bytes of machine code go with them. +~ +~ There's also an implicit way to create a suffix comment, which is to have +~ non-blank words of any kind on the line prior to the magic comment. In this +~ case, the default is to be a suffix comment rather than a line comment. +~ Suffix comments created this way will have zero length. +~ +~ Before we move on from magic comments that produce descriptive text, also +~ look at the third example above. This is another suffix comment, but it's +~ got a negative number as its parameter. It's got a bit of code on the line +~ before it, to illustrate the typical way these negative parameters are used. +~ Just as a suffix comment with a positive length describes a span of bytes +~ with its start anchored at the address the comment is attached to, so when +~ the length is negative, the span of bytes has its END anchored at the +~ address. +~ +~ You can see examples of how this syntax is useful in compilation/elf.e, +~ where it describes fields of various header structures. When it fits the +~ situation, this notation is concise and easy to visually skim both in the +~ actual source code, and in the generated hex dump. +~ +~ Now let's look at some magic comments that do more interesting things. +~ The two commands "indent" and "deindent" both create an entry of +~ -entry-type-indent. Neither takes a parameter as part of the comment syntax, +~ but the entry structure has an internal value which is set to 2 for "indent" +~ and -2 for "deindent". When output is eventually formatted, these entries +~ will be used to adjust the amount of space at the beginning of each line, +~ which can be very useful to visually group code together. The formatting +~ process has some mutable state of its own, which doesn't exist until this +~ very late stage (long after magic comments execute); among other things, +~ there's a notion of current indentation level, which is preserved until +~ these entries adjust it. +~ +~ The commands "fresh-line" and "blank-line" create entries of +~ -entry-type-fresh-line and -entry-type-blank-line, respectively. Just as the +~ output formatting knows how deeply indented it is, it also knows whether +~ it's at the start of a line. A fresh-line entry will insert a line break, +~ but only if we're somewhere deep in a line; if we're already at the start, +~ it does nothing. A blank-line entry will do the same thing as fresh-line, +~ then it will add another line break, so that the result is to output a fully +~ blank line in the hex dump. This can be useful to break things up visually. +~ +~ Thus far, though we've taken pains to allude to the fact that there are +~ many stages of processing of metadata entries after they're created, we +~ haven't introduced any interesting features that rely on that. That changes +~ with the "adjust-line" command. When this command executes, it doesn't +~ create a new metadata entry. Rather, it scans backwards from the end of the +~ entry array, to find the most recently-created entry which is a line or +~ suffix comment. It skips over entries of other types. Then it adjusts the +~ length of that entry, in-place! The parameter of adjust-line may be positive +~ or negative, and either way it's added to the pre-existing length of the +~ entry it modifies. +~ +~ If that doesn't sound confusing, you may not have fully appreciated that +~ adjust-line commands don't have to come in the same word as the command that +~ created the entry they're modifying. For example, in +~ language/static/amd64.e, rex-w is a common helper word called as part of +~ many assembly instructions. It always outputs a single byte. Commentary in +~ that file describes an accounting convention whereby keeping track of this +~ byte is rex-w's job, so rex-w also has a magic comment with an adjust-length +~ command. Whatever word calls rex-w will have already created a suffix +~ comment giving the name of the instruction it's implementing, by the time +~ this is called, and rex-w's call to adjust-length will find that comment's +~ entry and modify it. +~ +~ The use of this may not seem like much for a word like rex-w, which always +~ outputs the same number of bytes, but now look at the definition of +~ addressing-indirect-reg64. This is a common addressing mode shared by many +~ instructions, and called as a helper from various instruction words. Notice +~ how it has to generate a different encoding when it's given the register +~ :rsp, which has an extra SIB byte that's not needed for any other register. +~ There's no magic comments in addressing-indirect-reg64 itself, but the word +~ "sib" is another helper which does an appropriate adjust-length, if and only +~ if sib is actually called. +~ +~ You can see how it might become quite confusing trying to decide which +~ word should take responsibility for a particular byte, when there are +~ multiple layers of abstraction like this. It's especially confusing because +~ this is an extra form of side-effect which acts on global mutable state, and +~ is out-of-band compared to the normal Forth value stack. When you're +~ implementing an instruction set architecture, you should strongly consider +~ defining an accounting convention which makes that clear and unambiguous. +~ Feel free to consult the convention described at the top of +~ language/static/amd64.e for inspiration. +~ +~ All the adjust-* commands change something immediately, as they execute. +~ What they adjust differs. In the cases of adjust-length and adjust-start, +~ it's a field of a recent entry. Notionally, adjust-start does the same thing +~ as adjust-length but for the start address the entry is attached to, rather +~ than the length of the attachment. Also, while adjust-length only affects +~ comment entries, adjust-start affects any entry that produces output, such +~ as fresh-line. +~ +~ The various -output-point commands are used to directly interact with the +~ notion of the latest output point, which can be useful if a location has +~ been skipped over and there are commands which should be run before +~ outputting anything at the new location. The simplest variant is +~ set-output-point, which sets it to the parameter value. The data-set- +~ variant obtains a value in the manner of the other data-* commands, adds it +~ to the parameter value, and sets the latest output point to the result. The +~ adjust- and data-adjust- variants, like other adjust commands, add a value +~ to the existing one. +~ +~ Notice that the general rule is that data-set-* commands use their +~ parameter as an addend, while data-adjust-* commands use it as a multiplier. +~ +~ The data-adjust-* variants deserve further commentary, though you may find +~ it more productive to read and understand the entire explanation about +~ provide-* commands before worrying about these. These variants adjust the +~ same things as the non-data ones, but instead of adjusting by a fixed +~ amount, they look for the most recent -entry-type-saved-data metadata entry. +~ They delete that entry from the entry array entirely, and use the value +~ saved in it as the amount to adjust by. Such entries are created by the +~ provide-data command, on which more below. Additionally, the data-adjust-* +~ commands use their parameters as scaling factors to the adjustment, and +~ these factors may be negative. You'll usually specify a parameter of 1 or +~ -1. +~ +~ We will revisit the topic of adjust-length later, when we describe the +~ comment template feature, but for now we'll leave it there. +~ +~ Direct your attention to the "suppress" command. Sometimes, you intend to +~ call a helper word which is going to create its own entries, but you know +~ that those entries don't suit your purpose, and you want to ignore them. +~ For example, you may be calling a word which outputs a binary string and +~ creates entries describing the string, but you're doing something more +~ specific and would prefer to create entries that describe your special case, +~ instead. +~ +~ When you need this, you can call "suppress" with an integer parameter. If +~ the parameter is 1, the next time a metadata entry would have been created, +~ it won't; then things go back to normal. If you want to suppress more than +~ one entry in a row, you can pass it a larger number. If you change your +~ mind, you can pass it a negative number. At the time magic comments are +~ executing, there's a running count of how many entries should be suppressed, +~ which is decremented any time it's greater than zero and an entry would be +~ created, and adjusted every time a call to "suppress" is executed. +~ +~ Sometimes, an entry has already been created, and you now need to get rid +~ of it. While there are reasons to be cautious of more-general mechanisms, +~ the commands delete-*-comment-at-output-point will search for a metadata +~ entry which is one of the comment types and which has its start position set +~ to the same address as the current output point. The -first- variant will +~ search forward from the start of the array, while -last- will search +~ backward from the end; both will stop as soon as they encounter one. This is +~ usually desired when overwriting a location that has already been written +~ to. +~ +~ Take a quick look at the remaining examples. These are part of the comment +~ template feature. We'll need to describe the other phases of processing +~ before we can talk about how they work, but notice that one of them has the +~ space-separated word # inside it, while the others are commands whose names +~ start with provide-. Any line or suffix comment can have # in it, which will +~ consume a subitem from somewhere else, replacing the # like it's a template. +~ The various provide- commands are the origins of those subitems. Which # +~ goes with which provide- command? Thereby hangs a tale. +~ +~ So. Let's pretend for the moment that we've finished talking about things +~ that happen when magic comments execute. We haven't, quite, but to finish it +~ out you'll need the full picture in your head. +~ +~ All this time, the hex transform has been executing the compiler, which +~ is running its guts inside a utility called the label loop (see +~ compilation/labels.e). The compiler guts have been calling their own various +~ internal words and accumulating their binary output in the label-loop +~ buffer. While this is happening, the hex transform's various traps have been +~ tracking the latest output point, executing magic comments, and doing other +~ vital but simpler tasks. +~ +~ Eventually the label-loop will reach the end of its iteration, and then it +~ will either conclude that all the labels in the program have been resolved +~ successfully, or it will notice that some of them were given addresses that +~ don't work. If the labels aren't all resolved, the label loop will start +~ over from the beginning, running all the same compiler guts again. The hex +~ transform will notice that this happened, clear out all the metadata +~ entries, and restart its own activities as well. +~ +~ When the label loop finally declares success, and exits, the compiler will +~ want to actually produce its binary output. The hex transform has trapped +~ this, too! Now there's a postprocessing phase which cleans up all the +~ metadata entries, and then finally there's a formatting phase where the +~ entries are "run", as if they're a program, and the final hex dump with all +~ its comments is output. +~ +~ As a side note, the hex transform doesn't stop the compiler short; it lets +~ the compiler decide which bytes will be output and in what order. In +~ practice, Evocation and the various supplemental programs around it only +~ ever write their output in a single giant chunk, but the formatting phase +~ actually runs every single time the compiler calls sys-write, and it only +~ handles the portion of the label-loop buffer which the compiler passed to +~ sys-write. +~ +~ The postprocessing phase is idempotent - doing it twice is the same as +~ doing it once - so it's simply called every time sys-write is, before the +~ formatting phase starts. Postprocessing considers every metadata entry, +~ every time it runs, even when sys-write is called on something less than +~ the whole buffer. +~ +~ If you add postprocessing features, make sure to keep them idempotent. +~ While it's possible to imagine reasons one might want to have back-and-forth +~ interplay between successive formatting and postprocessing phases, Evocation +~ goes to some trouble to make sure there is none. In Irenes' opinion, this +~ is already quite enough complexity and is nearing the limit of what humans +~ will find worthwhile. If you break idempotence, you are hereby warned that +~ you are at risk of falling into the abyss[1]. +~ +~ Postprocessing re-organizes entries, without changing their meaning, but +~ in a way that will make them easier to format. There are two things it +~ does, and they happen simultaneously: The whole array is bubble-sorted; +~ and some suffix comment entries are split apart. +~ +~ The bubble sort resolves ordering first by the address each entry is +~ attached to, low-to-high. As a tiebreaker when two entries have the same +~ address, a comment entry is sorted after a stack-manipulation entry. The +~ tiebreaker rule means that stack-manipulation commands can come after the +~ last byte that's within the comment's span; otherwise they would always have +~ to be before it. If neither criterion applies, the entries will stay in +~ whatever order they were in to begin with; that is, it's a stable sort. +~ +~ The comment splitting applies only to suffix comments, and only when their +~ length is not zero. They become a fresh-line entry at the start of the span +~ the comment originally attached to, and a zero-length suffix comment entry +~ at the end of the span. +~ +~ Please notice that adjust-length commands happen when magic comments are +~ executed, which was long, long ago by now. By the time the postprocessing +~ happens, every entry's length has been as adjusted as it's ever going to be. +~ This is important, because the order of entries is going to matter during +~ the formatting phase. +~ +~ Notice also that the splitting of suffix comment entries changes what +~ address the comment is attached to (unless it's a negative length, which is +~ already at the end of its span). Any entries that were attached to output +~ points somewhere inside the span will now definitely be before the suffix +~ comment's entry in the entry array, whereas up till now they were likely +~ somewhere after it, depending on the exact order everything was created in. +~ +~ The postprocessing phase is conceptually simple - unlike the magic-comment +~ execution phase before it, and unlike the formatting phase after it, there +~ isn't any mutable state inside the phase that would make it matter what +~ order things happen in. Enjoy this, because ordering is about to become +~ super confusing. +~ +~ Now let's consider the formatting phase. We've already mentioned that +~ there is some global state which is tracked throughout the phase, such as +~ the current indentation level and whether the output is at the start of a +~ line. The formatting phase is given an overall block of bytes in the +~ label-loop buffer, which it iterates through in order from beginning to end. +~ Any time the formatting phase reaches an address which has metadata entries +~ attached to it, all the entries at that address are executed, in the order +~ they exist in the entry array. +~ +~ Yes, that's right, executing an entry is different from executing the +~ magic comment that created the entry. That's important. +~ +~ The line-comment and suffix-comment entries do the obvious things: They +~ print out the appropriate comment text. Suffix comments are also all +~ horizontally aligned with each other, to make them easier to visually skim. +~ The two kinds of comment entries also do a less-obvious thing, which is fill +~ in any # template items that are part of the comment text, in order from +~ left to right. +~ +~ Where do those items come from? Well, there's a separate stack, the +~ subitem entry stack, which is kept in the hex output metadata header. The +~ subitem entry stack has an extremely small, fixed maximum depth. The maximum +~ depth is deliberately small, so that any leaks onto it will be detected +~ somewhere close to their root causes, for ease of diagnosis. Unusually for +~ Evocation, if you underflow or overflow it, you'll get a friendly error +~ message rather than a segfault - how nice! Of course, the error message will +~ appear in the middle of your regular output and corrupt it, but you can't +~ have everything... +~ +~ Each time a comment template is being filled and encounters a # +~ placeholder, an item is popped off the subitem entry stack and formatted +~ according to what type of entry it is. It's called an "entry stack" for a +~ reason: it's a stack of pointers to metadata entries, whose backing store +~ is in this very same entry array that we're executing. So, all the various +~ internal fields of an entry are available to provide rich behavior which +~ allows different kinds of values to be formatted in different ways. +~ +~ For those used to languages with automatic memory management, keep in mind +~ that there's no language-provided guarantee that the thing a pointer points +~ to still exists, and hasn't been replaced with some other +~ misleadingly-similar thing. The separation of all this stuff into phases +~ provides that guarantee, because there's nothing in the formatting phase +~ that destroys or moves metadata entries in the array, but if that separation +~ were to break down, astonishingly complex wrong behavior would be entirely +~ likely. If you're reading all this, it's probably to touch that code, so +~ please keep those consequences in mind. +~ +~ How do entry pointers get pushed onto the subitem entry stack, and where +~ do the values inside them come from? Okay, now this is the payoff, the part +~ where you need to understand all these phases at once. Cast your mind all +~ the way back to the magic-comment execution, and take another look at the +~ provide-* examples above. Recall that magic comment commands execute when +~ the word they're contained in is running. For the other comment commands, +~ this is mostly a curiosity; we talked about adjust-length, above, but that's +~ still just recording the fact that the word did or didn't run. +~ +~ The provide-* commands are deeper than that. They peek at the top item on +~ the stack OF THE COMPILER, the code being transformed. The -decimal and +~ -hex* variants create a corresponding -entry-type-push-subitem- metadata +~ entry of the matching type, and copy the numeric value into it. +~ +~ The -string variant expects to find a pointer to a null-terminated string; +~ -string-copy does too, but copies the contents of it to a safe place +~ immediately, on the assumption they'll be overwritten. The -keyword variant +~ expects to find a keyword (a word which, when executed, pushes its own +~ execution token onto the stack); the command extracts the name of the +~ keyword from the dictionary entry header. All three of these save pointer to +~ their respective strings in a push-subitem-string metadata entry. +~ +~ Admit it, you thought writing out "metadata entry" so many times instead +~ of just "entry" was silly because there was no other kind of entry in +~ consideration, right up until you got to "dictionary entry". If so, hey +~ look, neat, right? ;) +~ +~ The -data variant treats the value as opaque, and creates an +~ -entry-type-saved-data metadata entry. Unlike the others, these entries do +~ not affect the subitem entry stack; they're consumed and removed from the +~ entry array before entry execution even starts, by the matching data-* +~ command. +~ +~ Anyway, notice that when the various provide-* commands execute, all +~ they're doing is capturing values and creating metadata entries. Like all +~ metadata entries, these are attached to the latest output point as of the +~ time the magic comment executes. In particular, the subitem entry stack +~ isn't touched until all the way at the end, in the formatting phase. It's +~ only when the formatting reaches the address the entry is attached to that +~ the entry is executed, which has the effect of pushing a pointer to the +~ entry onto the subitem entry stack. +~ +~ It's been said already, but just to bring it all full circle, the life +~ cycle of a push-* entry ends later in the formatting phase, when a comment +~ entry pops it off the subitem entry stack and pretty-prints the value it +~ holds. +~ +~ With all this context, it likely doesn't need much explanation, but the +~ drop-subitem command will create an -entry-type-drop-subitem entry. When +~ this entry is executed, it will discard an item from the subitem entry +~ stack. Similarly, swap-subitems creates an -entry-type-swap-subitems, which +~ swaps the top two items, and roll-subitems creates an +~ -entry-type-roll-subitems, which rolls them, or unrolls them with a negative +~ parameter. + +~ In general, the order in which provide-* commands execute will most likely +~ match the order in which the corresponding bytes are output. This may not +~ always match the order in which the comment template wants to pretty-print +~ them. Therefore, you will want to use these commands to get the subitem +~ stack in the proper order. +~ +~ In using these commands that manipulate the subitem stack, it's important +~ to remember that, when formatting happens, the left-to-right output of +~ subitems in the final output comment is top-to-bottom on the subitem stack, +~ because they're popped in order. This is the opposite of the usual visual +~ representation of stacks, and can easily be confusing. +~ +~ It's probably clear from the extreme emphasis this documentation has taken +~ on describing the order things happen in, but it is quite common to define +~ a suffix comment at the start of an assembly-instruction word; adjust its +~ length as other words are called; accumulate push-* entries; then rely +~ on the address sorting to make sure the push-* entries are executed +~ before the suffix comment entry, even though the suffix-comment command +~ executed before the others, and even though the adjust-length commands may +~ have come before or after the provide-* commands that go with the same +~ suffix comment. +~ +~ Now that you have this full picture in your head, you finally also have +~ the background to understand the data-adjust-* commands. You may find it +~ helpful to go re-read the explanation of them, above, to let it sink in. +~ +~ This is the kind of forwards-and-backwards thinking which humans are +~ surprisingly good at when reading and writing software, but which it's +~ quite difficult to formalize in a way that lets a computer share that +~ understanding. If you've read this far, Irenes would absolutely adore +~ hearing about how you found the explanation and whether you did anything +~ with it; don't be shy! +~ +~ [1] https://katalepsis.net/ + +~ We have a bunch of accessors and traversers for the output metadata, which +~ are all functions from pointers to pointers. Don't confuse these with the +~ accessors for the transformation state, defined far, far above. +: hex-output-metadata-label-loop-buffer-start ; +: hex-output-metadata-label-loop-buffer-length 8 + ; +: hex-output-metadata-latest-output-point 2 8 * + ; +: hex-output-metadata-has-non-space-this-input-line 3 8 * + ; +: hex-output-metadata-suppression-count 4 8 * + ; +: hex-output-metadata-is-fresh-line 5 8 * + ; +: hex-output-metadata-indentation-depth 6 8 * + ; +: hex-output-metadata-current-column 7 8 * + ; +: hex-output-metadata-n-bytes-this-line 8 8 * + ; +: hex-output-metadata-subitem-entry-stack-depth 9 8 * + ; +: hex-output-metadata-subitem-entry-stack-zero 10 8 * + ; +: hex-output-metadata-subitem-entry-stack-capacity 8 ; +: hex-output-metadata-first-entry + 10 hex-output-metadata-subitem-entry-stack-capacity + 8 * + ; +: hex-output-metadata-entry-data-start ; +: hex-output-metadata-entry-data-length 8 + ; +: hex-output-metadata-entry-type 2 8 * + ; +: hex-output-metadata-entry-content 3 8 * + ; +: hex-output-metadata-next-entry 4 8 * + ; +: hex-output-metadata-previous-entry 4 8 * - ; +: hex-output-metadata-entry-type-line-comment 0 ; +: hex-output-metadata-entry-type-suffix-comment 1 ; +: hex-output-metadata-entry-type-fresh-line 2 ; +: hex-output-metadata-entry-type-blank-line 3 ; +: hex-output-metadata-entry-type-indent 4 ; +: hex-output-metadata-entry-type-string-literal 5 ; +: hex-output-metadata-entry-type-raw-string-literal 6 ; +: hex-output-metadata-entry-type-push-subitem-decimal 7 ; +: hex-output-metadata-entry-type-push-subitem-hex 8 ; +: hex-output-metadata-entry-type-push-subitem-hex8 9 ; +: hex-output-metadata-entry-type-push-subitem-hex16 10 ; +: hex-output-metadata-entry-type-push-subitem-hex32 11 ; +: hex-output-metadata-entry-type-push-subitem-hex64 12 ; +: hex-output-metadata-entry-type-push-subitem-string 13 ; +: hex-output-metadata-entry-type-saved-data 14 ; +: hex-output-metadata-entry-type-drop-subitem 15 ; +: hex-output-metadata-entry-type-swap-subitems 16 ; +: hex-output-metadata-entry-type-roll-subitems 17 ; + +~ Initialize the contents of the output metadata to all zeroes. This is +~ called from hex-transform at its top level, at the very start, to make sure +~ everything is structurally valid. We can't store real values at that point, +~ because they don't exist yet. The actual label-loop buffer, per its name, +~ won't be allocated until label-loop is called, so we can't possibly know its +~ address till then. +: zero-hex-output-metadata + transformation-state transformation-state-output-metadata @ + dup hex-output-metadata-label-loop-buffer-start 0 swap ! + dup hex-output-metadata-label-loop-buffer-length 0 swap ! + dup hex-output-metadata-latest-output-point 0 swap ! + dup hex-output-metadata-has-non-space-this-input-line 0 swap ! + dup hex-output-metadata-suppression-count 0 swap ! + dup hex-output-metadata-is-fresh-line 1 swap ! + dup hex-output-metadata-indentation-depth 0 swap ! + dup hex-output-metadata-current-column 0 swap ! + dup hex-output-metadata-n-bytes-this-line 0 swap ! + dup hex-output-metadata-subitem-entry-stack-depth 0 swap ! + dup hex-output-metadata-first-entry 0 swap ! ; + +~ (pointer -- boolean) +: is-in-label-loop-buffer + dup + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-start @ + <= + swap + transformation-state transformation-state-output-metadata @ + dup hex-output-metadata-label-loop-buffer-start @ + swap hex-output-metadata-label-loop-buffer-length @ + + > && ; + +: has-non-space-this-input-line@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-has-non-space-this-input-line @ ; + +: has-non-space-this-input-line! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-has-non-space-this-input-line ! ; + +: is-comment-entry + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-line-comment = swap + hex-output-metadata-entry-type-suffix-comment = || ; + +: is-output-producing-entry + dup is-comment-entry swap + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-fresh-line = 3roll || swap + hex-output-metadata-entry-type-blank-line = || ; + +: is-saved-data-entry + hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-saved-data = ; + +: is-push-subitem-entry + ~ Notably, the subitem swap, drop, and roll entry types are not + ~ push-subitem entries. + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-push-subitem-decimal = swap + dup hex-output-metadata-entry-type-push-subitem-hex = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex8 = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex16 = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex32 = 3roll || swap + dup hex-output-metadata-entry-type-push-subitem-hex64 = 3roll || swap + hex-output-metadata-entry-type-push-subitem-string = || ; + +: is-subitem-stack-manipulation-entry + hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-drop-subitem = swap + dup hex-output-metadata-entry-type-swap-subitems = 3roll || swap + hex-output-metadata-entry-type-roll-subitems = || ; + +: is-fresh-line@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-is-fresh-line @ ; + +: is-fresh-line! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-is-fresh-line ! ; + +: fresh-line is-fresh-line@ not { newline } if ; + +: indentation-depth@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-indentation-depth @ ; + +: indentation-depth! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-indentation-depth ! ; + +: current-column@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-current-column @ ; + +: current-column! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-current-column ! ; + +: advance-current-column current-column@ + current-column! ; + +: n-bytes-this-line@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-n-bytes-this-line @ ; + +: n-bytes-this-line! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-n-bytes-this-line ! ; + +: increment-bytes-this-line n-bytes-this-line@ 1+ n-bytes-this-line! ; + +: describe-subitem-entry-stack + transformation-state transformation-state-output-metadata @ + ." depth " + dup hex-output-metadata-subitem-entry-stack-depth @ .hex64 newline + ." capacity " + hex-output-metadata-subitem-entry-stack-capacity .hex64 newline + hex-output-metadata-subitem-entry-stack-zero + hex-output-metadata-subitem-entry-stack-capacity 8 * hexdump-from ; + +: subitem-entry-stack-depth@ + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-depth @ ; + +: subitem-entry-stack-depth! + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-depth ! ; + +: is-subitem-entry-stack-empty + subitem-entry-stack-depth@ 0 = ; + +: is-subitem-entry-stack-full + subitem-entry-stack-depth@ + hex-output-metadata-subitem-entry-stack-capacity = ; + +: push-subitem-entry-stack + is-subitem-entry-stack-full not { + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-zero + subitem-entry-stack-depth@ 8 * + ! + + subitem-entry-stack-depth@ 1+ subitem-entry-stack-depth! + } { + ~ We still consume the value, so that our caller doesn't crash. + drop + + ." Subitem entry stack overflow." newline + } if-else ; + +: pop-subitem-entry-stack + is-subitem-entry-stack-empty not { + subitem-entry-stack-depth@ 1- subitem-entry-stack-depth! + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-subitem-entry-stack-zero + subitem-entry-stack-depth@ 8 * + @ + } { + ." Subitem entry stack underflow." newline + + ~ We still return a value, so that our caller doesn't crash. + 0 + } if-else ; + +~ (data start, data length, entry type, string pointer, entry pointer --) +: hex-output-metadata-entry! + dup hex-output-metadata-entry-content 3roll swap ! + dup hex-output-metadata-entry-type 3roll swap ! + dup hex-output-metadata-entry-data-length 3roll swap ! + dup hex-output-metadata-entry-data-start 3roll swap ! + drop ; + +~ (entry pointer, data start, data length, entry type, string pointer +~ -- next entry pointer) +: pack-hex-output-metadata-entry + 4 pick hex-output-metadata-entry! + hex-output-metadata-next-entry ; + +~ (data start, data length, entry type, string pointer --) +: add-hex-output-metadata-entry + ~ If the suppression count is greater than zero, decrement it. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-suppression-count @ + dup 0 < { + 1- + transformation-state transformation-state-output-metadata @ + hex-output-metadata-suppression-count ! + 4 ndrop exit + } { drop } if-else + + 3 pick is-in-label-loop-buffer { + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + { dup @ dup { dup 3 pick >= drop } if } { + hex-output-metadata-next-entry + } while + + 5 unroll pack-hex-output-metadata-entry + 0 pack64 drop + } { drop drop drop drop } if-else ; + +~ (entry pointer --) +: delete-metadata-entry + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + { dup @ } { hex-output-metadata-next-entry } while + ~ (entry pointer, array-end marker pointer) + over hex-output-metadata-next-entry - 8 + + ~ (entry pointer, length of block to move) + swap dup hex-output-metadata-next-entry swap 3roll memmove ; + + +~ (-- entry pointer or 0) +: find-latest-metadata-entry + ~ Loop forward from the beginning of the entry array to find the last + ~ actual entry. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + dup @ { + { dup hex-output-metadata-next-entry @ } + { hex-output-metadata-next-entry } while + } if ; + +~ (-- entry pointer or 0) +: find-latest-comment-metadata-entry + find-latest-metadata-entry + ~ (entry pointer or 0) + + ~ If and only if we actually found one, now loop backwards to find the + ~ most recent one that's a comment entry. All length adjustments apply to + ~ comment entries, anything else needs to be skipped for this purpose. + { dup { dup is-comment-entry not } { 0 } if-else } + { transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + over > { + hex-output-metadata-previous-entry } { drop 0 } if-else } while + ~ (entry pointer or 0) + ; + +~ (-- entry pointer or 0) +: find-latest-output-producing-metadata-entry + find-latest-metadata-entry + ~ (entry pointer or 0) + + ~ If and only if we actually found one, now loop backwards to find the + ~ most recent one that's an output-producing entry. + { dup { dup is-output-producing-entry not } { 0 } if-else } + { transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + over > { + hex-output-metadata-previous-entry } { drop 0 } if-else } while + ~ (entry pointer or 0) + ; + +~ (-- entry pointer or 0) +: find-latest-saved-data-metadata-entry + find-latest-metadata-entry + ~ (entry pointer or 0) + + ~ If and only if we actually found one, now loop backwards to find the + ~ most recent one that's a comment entry. All length adjustments apply to + ~ comment entries, anything else needs to be skipped for this purpose. + { dup { dup is-saved-data-entry not } { 0 } if-else } + { transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + over > { + hex-output-metadata-previous-entry } { drop 0 } if-else } while + ~ (entry pointer or 0) + ; + +~ (target start location -- entry pointer or 0) +: find-first-comment-metadata-entry-with-start + ~ Find the first entry, but if it doesn't exist, we want 0 instead. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + ~ (target start location, entry pointer) + + ~ Now loop forwards to find the first that's a comment entry and has the + ~ desired start location. + { dup @ } { + dup is-comment-entry + over hex-output-metadata-entry-data-start @ 3 pick = + && { swap drop exit } if + hex-output-metadata-next-entry + } while drop drop 0 ; + + +~ (target start location -- entry pointer or 0) +: find-latest-comment-metadata-entry-with-start + find-latest-metadata-entry + ~ (target start location, entry pointer or 0) + + dup { + { dup @ } { + dup is-comment-entry + over hex-output-metadata-entry-data-start @ 3 pick = + && { swap drop exit } if + + dup + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + = { drop drop 0 exit } if + + hex-output-metadata-previous-entry + } while + } if swap drop ; + + +~ (length adjustment --) +: adjust-latest-comment-metadata-entry-length + find-latest-comment-metadata-entry + + ~ We've found the entry we want to act on, if it exists, so do it. + dup { + hex-output-metadata-entry-data-length dup @ 3roll + swap ! + } { + drop + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. + ." No pre-existing metadata entry to adjust." newline + crash + } if-else ; + +~ (length adjustment --) +: adjust-latest-output-producing-metadata-entry-start + find-latest-output-producing-metadata-entry + + ~ We've found the entry we want to act on, if it exists, so do it. + dup { + hex-output-metadata-entry-data-start dup @ 3roll + swap ! + } { + drop + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. + ." No pre-existing metadata entry to adjust." newline + crash + } if-else ; + + +~ (target start location --) +: delete-first-comment-metadata-entry-with-start + find-first-comment-metadata-entry-with-start + dup { delete-metadata-entry } { drop } if-else ; + +~ (target start location --) +: delete-latest-comment-metadata-entry-with-start + find-latest-comment-metadata-entry-with-start + dup { delete-metadata-entry } { drop } if-else ; + +: delete-first-comment-metadata-entry-at-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point @ + delete-first-comment-metadata-entry-with-start ; + +: delete-latest-comment-metadata-entry-at-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point @ + delete-latest-comment-metadata-entry-with-start ; + + +~ (value --) +: set-latest-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point ! ; + +~ (adjustment --) +: adjust-latest-output-point + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point + dup 3unroll @ + swap ! ; + +~ (-- data value) +: data-consume + find-latest-saved-data-metadata-entry + ~ (entry pointer or 0) + + dup { + dup hex-output-metadata-entry-content @ swap + ~ (data value, entry pointer) + + delete-metadata-entry + } { + drop + + ~ If we get here, that's a problem. Emit an error message to make sure + ~ it's easy to diagnose. + ." No saved-data metadata entry to take a value from." newline + + ~ We still return a value, so that our caller doesn't crash. + 0 + } if-else ; + +~ (adjustment scale factor --) +: data-adjust-latest-comment-metadata-entry-length + ~ All the entry array manipulation happens in data-consume. Once we're + ~ done doing that, the array is now in a consistent state, so we can hand + ~ off to the non-data implementation to do the rest of the work. + data-consume * adjust-latest-comment-metadata-entry-length ; +~ (adjustment scale factor --) +: data-adjust-latest-output-producing-metadata-entry-start + ~ Same as for adjusting the entry length. + data-consume * adjust-latest-output-producing-metadata-entry-start ; + +~ (value offset --) +: data-set-latest-output-point + data-consume + set-latest-output-point ; +~ (adjustment scale factor --) +: data-adjust-latest-output-point + data-consume * adjust-latest-output-point ; + + +~ (count adjustment --) +: adjust-hex-output-suppression-count + transformation-state transformation-state-output-metadata @ + hex-output-metadata-suppression-count dup @ 3roll + swap ! ; + +~ This is the followup to zero-hex-output-metadata, above. Once we do have +~ the label-loop buffer, we need to create some default entries. This is +~ called in the first label-loop iteration by hex-allocate-replacement, and +~ it's called before subsequent iterations by the hook on reset-labels defined +~ in hex-colon-alternate. +~ +~ This overwrites whatever entries currently exist with the new ones, and +~ adds a zero delimiter at the end. +~ +~ In addition to setting up the entries, we also set latest-output-point to +~ the start of the label-loop buffer here. This needs to happen at the start +~ of each pass, so although it doesn't quite fit the name, we do it here. +~ +~ It requires the header to have already been initialized; in particular it +~ requires the label-loop buffer start pointer to be valid. +: create-hex-output-metadata-top-of-file-entries + transformation-state transformation-state-output-metadata @ + dup hex-output-metadata-label-loop-buffer-start @ + swap hex-output-metadata-first-entry + ~ (label buffer start, metadata output point) + + ~ This likely won't affect anything, because every call to pack* + ~ overwrites it, but we initialize the latest output point to the start of + ~ the label loop buffer here. That way, in the event the very first thing in + ~ the output is something that's supposed to have a magic comment on it, + ~ hex-tilde-replacement will know where to attach the metadata entry. + ~ + ~ If that was word soup, go read about hex-tilde-replacement and + ~ hex-tilde-alternate and come back. :) + over + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point ! + 0 has-non-space-this-input-line! + + over 0 hex-output-metadata-entry-type-line-comment + s" This file is a commented hexadecimal representation of a compiled" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" program, the output of Evocation's hex transform. The comments are" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" intended to allow a human reader to audit it. You can convert it to a" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" runnable executable by piping it through the program named 'hex' and" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" chmodding the output 755. The difference between a source and a binary" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-line-comment + s" is comments! Enjoy. :)" + pack-hex-output-metadata-entry + + over 0 hex-output-metadata-entry-type-blank-line 0 + pack-hex-output-metadata-entry + + 0 swap ! ~ End-of-entries delimiter + drop ; + +: hex-self-codeword-alternate self-codeword ; + +: hex-string-alternate + ~ The technique we use to wrap s" is analogous to how we do it in the + ~ label transform, but with one critical decision different. + ~ + ~ In the label transform, the output buffer is going to be written + ~ directly into the final executable at some point, and we'd really rather + ~ not scribble temporary values into it, even if we expect to overwrite them + ~ later. Additionally, everything the label transform does runs inside the + ~ label loop, so the code it's transforming isn't expected to do any sort of + ~ miscellaneous setup things, just define a bunch of words. In that + ~ situation, making sure to use temporary space from the outer, "real" log + ~ is helpful. + ~ + ~ In the hex transform, most of that is different. The output buffer will + ~ include all sorts of things that don't become part of the final + ~ executable, though they're used in producing it. So, it's fine to use it + ~ for scratch space. Additionally, using the outer log for string literals + ~ gets us into trouble, since some of these temporary strings need to be + ~ made more durable by calling allocate-string on them. If we do that with + ~ a string pointer backed by the outer log, the inner "here" will wind up + ~ pointing to the end of the outer log, and all sorts of things will start + ~ scribbling atop each other. + ~ + ~ We do still benefit from using the interpreted version of s" rather than + ~ the compiled one; as with the label transform, it's convenient to handle + ~ the litstring dance ourselves. + ~ + ~ If we're in compile mode, we have reinvented a problem which the + ~ regular, non-transformed s" already deals with: The temporary space we're + ~ writing to is in the same place as the code we're compiling. We solve it + ~ the same way: Check beforehand and write out the call to litstring if we + ~ need it, so that we won't have to slide things around later. + interpreter-flags @ 0x01 & { + ~ We look up the inner version of litstring to reference here. This is + ~ similar to what the label transform does, except we don't use a label + ~ for it. + s" litstring" find entry-to-execution-token , + } if + + ~ Now, regardless of what mode we're actually in, call the interpreted + ~ version of s" to read the actual string and its null terminator. + interpreter-flags @ + ' s" entry-to-execution-token + [ ' [ entry-to-execution-token , ] + execute + swap interpreter-flags ! + + ~ Now we have a string pointer on the stack at transform time. If we're in + ~ immediate mode, that's sufficient. If we're in compile mode, we also + ~ already output a litstring invocation, and the string is in the right + ~ place, but "here" is pointing before it and needs to point after it, then + ~ we also still need to add alignment padding. Plus, we need to be sure to + ~ not leave the string pointer itself on the stack. + interpreter-flags @ 0x01 & { + dup stringlen 1+ + 8 packalign here ! + } if + ; make-immediate + +: hex-dot-string-alternate + ' hex-string-alternate entry-to-execution-token execute + + interpreter-flags @ 0x01 & { + ~ We look up the inner version of emitstring, too. + s" emitstring" find entry-to-execution-token , + } { emitstring } if-else + ; make-immediate + +: hex-create-alternate create ; + +~ This is a helper called from the patched version of "variable", described +~ in more detail in hex-colon-alternate, below. It expects to be called after +~ outputting the entry header for "variable", during the body of the +~ definition, so that it can output compiled code which will run as part of +~ the transformed "variable". +~ +~ The helper accepts a string pointer giving a variable name. The code it +~ produces checks the name of the variable being defined and, if the two names +~ match, alters the resulting inner variable to point to the same backing +~ store as the outer variable of the same name. +~ +~ In many ways the hex transform is the trippiest one. To wit, there's two +~ layers of compilation happening here... so don't get confused. When the +~ helper is called, we're compiling the inner "variable", but "variable" +~ itself is a word-defining word which also has the task of compilation... +~ which we're modifying. +~ +~ (name pointer --) +: hex-variable-use-outer + ~ The actual payload here is that we check whether we're defining the + ~ word described by the name pointer we were given, and, if so, we make it + ~ reference the outer backing store instead of the inner one. + ~ + ~ We want to do this all as references to inner words, which fortunately + ~ have been defined by now, but we have to do that a bit indirectly... + s" dup" find entry-to-execution-token , + s" litstring" find entry-to-execution-token , + here @ over packstring 8 packalign here ! + s" stringcmp" find entry-to-execution-token , + s" lit" find entry-to-execution-token , 0 , + s" =" find entry-to-execution-token , + + ~ Also, we don't have high-level flow control yet, and even if we did, + ~ it would be awkward to use it here. So we count the branch by hand. Ah + ~ well. As always, remember that with forward branches, the offset to + ~ branch by is the first word to be skipped, and is included in the count. + s" 0branch" find entry-to-execution-token , 6 8 * , + + ~ If control reaches here in the generated code, the string matched. + s" swap" find entry-to-execution-token , + s" drop" find entry-to-execution-token , + + ~ To get the value of the outer variable, we just call it. Of course, + ~ looking up an outer entry is a pain, but at least it's a pain in a way + ~ that should be familiar by now. + s" lit" find entry-to-execution-token , + swap-transform-variables + find + swap-transform-variables + entry-to-execution-token execute , + + s" swap" find entry-to-execution-token , ; + +~ This is a helper used by postprocess-metadata-entries, below. It +~ duplicates the entry it's given, creating a second identical copy +~ immediately after it in the entry array, sliding everything else forward to +~ make room. +~ +~ (entry pointer --) +: dup-metadata-entry + ~ Find all the remaining entries, and the final terminator, and slide + ~ them forward by the length of one entry. + dup dup + ~ (entry pointer, entry pointer, entry pointer) + + { dup @ } { hex-output-metadata-next-entry } while 8 + + ~ (entry pointer, entry pointer, entry array end pointer) + swap - + ~ (entry pointer, entry array tail length) + swap dup hex-output-metadata-next-entry 3roll + ~ (entry pointer, adjusted entry pointer, entry array tail length) + memmove ; + +~ This is a helper used by postprocess-metadata-entries, below. It swaps +~ the contents of the entry it's given with the contents of the entry +~ immediately after it in the entry array. +~ +~ (entry pointer --) +: swap-metadata-entries + ~ Copy the current entry to a scratch area. + dup dup dup hex-output-metadata-next-entry swap - + ~ (entry pointer, entry pointer, entry length) + swap-transform-variables here @ swap-transform-variables swap + ~ (entry pointer, entry pointer, scratch pointer, entry length) + memcopy + ~ (entry pointer) + + ~ Copy the next entry over the current entry. + dup dup hex-output-metadata-next-entry dup + ~ (entry pointer, entry pointer, next entry pointer, next entry pointer) + 3roll - + ~ (entry pointer, next entry pointer, entry length) + 2 pick swap + ~ (entry pointer, next entry pointer, entry pointer, entry length) + memcopy + ~ (entry pointer) + + ~ Copy the scratch area over the next entry. + dup hex-output-metadata-next-entry dup + ~ (entry pointer, next entry pointer, next entry pointer) + 3roll - + ~ (next entry pointer, entry length) + swap-transform-variables here @ swap-transform-variables 3unroll + ~ (scratch pointer, next entry pointer, entry length) + memcopy ; + +~ Metadata entries are post-processed before they're output, in order to +~ make the structure of the output code simpler. The post-processing won't +~ happen until output actually occurs, which is important for operations that +~ modify entries in-place. +~ +~ Any time output is performed, all existing entries are post-processed. +~ Therefore, the post-processing is required to be idempotent, and is. +: postprocess-metadata-entries + 1 { } { + 0 + ~ (did anything this iteration) + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + { dup @ } { + ~ (did anything, entry pointer) + + ~ Is the entry a suffix comment with a non-zero data length? + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-suffix-comment = + over hex-output-metadata-entry-data-length @ 0 != && { + ~ Split it into two entries so as not to rely on data length for + ~ formatting. + dup dup-metadata-entry + ~ (did anything, entry pointer) + ~ Now we have the original entry at the original location, and a copy + ~ of it at the next location. + + ~ We have a feature which lets a suffix comment be created with a + ~ negative length, which means it covers bytes before the current output + ~ point rather than after it. This logic here is the implementation of + ~ that feature. + dup hex-output-metadata-entry-data-start @ dup + 2 pick hex-output-metadata-entry-data-length @ + + 2dup min 3unroll max + ~ (..., entry pointer, low end of data, high end of data) + + ~ Now we modify the original in-place to turn it into a fresh-line + ~ entry at the low end of the data... + 2 pick hex-output-metadata-entry-type + hex-output-metadata-entry-type-fresh-line swap ! + ~ (..., entry pointer, low end of data, high end of data) + + 2 pick hex-output-metadata-entry-data-start 3roll swap ! + ~ (..., entry pointer, high end of data) + over hex-output-metadata-entry-data-length 0 swap ! + ~ (..., entry pointer, high end of data) + + ~ ... then we modify the next entry in-place to set its location to + ~ the end of the data instead of the beginning, and its length to zero. + over hex-output-metadata-next-entry + ~ (..., entry pointer, high end of data, next entry pointer) + + dup hex-output-metadata-entry-data-start 3roll swap ! + ~ (..., entry pointer, next entry pointer) + hex-output-metadata-entry-data-length 0 swap ! + ~ (..., entry pointer) + + ~ This rule won't fire again on the fresh-line entry because it's of a + ~ a different type, and it won't fire on the modified suffix-comment + ~ entry because its data length is zero. + ~ + ~ It's possible that one or the other of the bubble-sort rules will + ~ fire on either of them. + + ~ (did anything, entry pointer) + swap drop 1 swap + } if + ~ (did anything, entry pointer) + + ~ Do this entry and the next entry both exist, and they're out of + ~ order based on their data starts? + dup hex-output-metadata-next-entry dup @ + { hex-output-metadata-entry-data-start @ + over hex-output-metadata-entry-data-start @ > } + { drop 0 } if-else + { + ~ Swap the order of the two entries. Since this whole thing is in a + ~ loop, this functions as a bubble sort. + dup swap-metadata-entries + swap drop 1 swap + + ~ This rule won't fire again on the same pair of entries because now + ~ they're in the correct order. It may fire again next iteration, + ~ but only until everything is sorted. + ~ + ~ This rule does nothing to alter whether the suffix-comment rule + ~ will fire on either of the entries it swapped, so there's no + ~ possibility of an infinite loop through that one. + } if + ~ (did anything, entry pointer) + + ~ Do this entry and the next entry both exist, and they have the same + ~ data start, and this one is a comment entry, and the next one is a + ~ stack-manipulation entry with zero length? + dup is-comment-entry over hex-output-metadata-next-entry @ && + { ~ (did anything, entry pointer) + dup hex-output-metadata-next-entry + over hex-output-metadata-entry-data-start @ + over hex-output-metadata-entry-data-start @ = + swap dup hex-output-metadata-entry-data-length @ 0 = 3roll && swap + is-subitem-stack-manipulation-entry && } + { 0 } if-else + { + ~ Swap the order of the two entries. Since this whole thing is in a + ~ loop, this functions as a bubble sort. + dup swap-metadata-entries + swap drop 1 swap + + ~ This rule can't fire in the same iteration as the previous swap, + ~ because that one doesn't fire when the starts are equal. It also + ~ won't fire again on the same pair of entries, again because now + ~ they're in the correct order. If it fires again in the next + ~ iteration that'll only be in the usual way it does for a bubble + ~ sort. + ~ + ~ As with the other swap rule, this rule also does nothing to alter + ~ whether the suffix-comment rule will fire on either entry it + ~ touches, so it won't loop through that one. + } if + ~ (did anything, entry pointer) + + hex-output-metadata-next-entry + } while drop + } while ; + +: hex-comment-first-tab-stop 36 ; +: hex-comment-second-tab-stop 58 ; + +~ This is a helper called from hex-emit-template-string. The word pointer +~ is in the outer log's scratch space, and must not be overwritten. +~ +~ (queued space count, word pointer -- should ignore space) +: hex-emit-template-string-word + dup s" #" stringcmp 0 = { + ~ (queued space count, word pointer) + drop + + pop-subitem-entry-stack + ~ (queued space count, subitem entry) + + ~ If we underflowed the stack, we got zero back, so make sure not to + ~ crash. A crash here would be a pain to debug because it would be + ~ unclear how much of the overall system is working, and it's a + ~ complex system. + dup { + ~ (queued space count, subitem entry) + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-decimal = { + swap dup indent advance-current-column 0 swap + + dup hex-output-metadata-entry-content @ + dup 10 swap logfloor 1+ advance-current-column + . + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ + dup 16 swap logfloor 1+ 2 + advance-current-column + .hex + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex8 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex8 + 4 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex16 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex16 + 6 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex32 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex32 + 10 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-hex64 = { + swap dup indent advance-current-column 0 swap + + ." 0x" + dup hex-output-metadata-entry-content @ .hex64 + 18 advance-current-column + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-push-subitem-string = { + swap dup indent advance-current-column 0 swap + + dup hex-output-metadata-entry-content @ + dup stringlen advance-current-column + emitstring + } if + } if + + drop drop 0 exit + } if + + dup s" #--" stringcmp 0 = { + ~ (queued space count, word pointer) + + hex-comment-second-tab-stop current-column@ + 2dup > { + drop drop swap drop 0 swap + newline + hex-comment-first-tab-stop indent ." ~" + hex-comment-second-tab-stop hex-comment-first-tab-stop 1+ - indent + hex-comment-second-tab-stop current-column! + } { + - dup indent advance-current-column + swap drop 0 swap + } if-else + + drop drop 1 exit + } if + + ~ (queued space count, word pointer) + swap dup indent advance-current-column + dup stringlen advance-current-column + emitstring 0 ; + + +~ (string pointer --) +: hex-emit-template-string + 0 swap + ~ (queued space count, input point) + + { unpack8 dup } { + ~ (queued space count, input point, latest character) + dup is-space { + ~ Instead of outputting space characters as we reach them, we keep a + ~ count of how many are pending. This allows us to do word-wrapping + ~ without having to worry about trailing spaces. + 3roll 1+ 3unroll drop + } { + ~ (queued space count, input point, first word character) + ~ We use the outer log's scratch space to accumulate each word in. + swap-transform-variables here @ swap-transform-variables + swap + pack8 + swap + ~ (queued space count, scratch output point, input point) + + ~ Scan forward and find a space-separated word. + { unpack8 dup dup is-space not && } { + ~ (queued space count, scratch output point, adjusted input point, + ~ next character) + 3roll swap pack8 swap + ~ (queued space count, adjusted scratch output point, + ~ adjusted input point) + } while + ~ (queued space count, scratch output point, input point, + ~ first non-word character or 0) + 3roll 0 pack8 drop + ~ (queued space count, input point, first non-word character or 0) + + swap-transform-variables here @ swap-transform-variables + ~ (queued space count, input point, first non-word character or 0, + ~ word pointer) + + 4 roll swap 1 max hex-emit-template-string-word 0 4 unroll + ~ (queued space count, input point, first non-word character, + ~ should ignore space) + + over { + ~ If the character is non-zero, it's a space, so it can't be part of + ~ a word, so we can queue it for later output... unless we were asked + ~ to skip it, of course. + not { + ~ (queued space count, input point, first non-word character) + 3roll 1+ 3unroll + } if + drop + } { + ~ If this is the end of the string, we can discard the 0, but then + ~ we need to nudge the input point back so the loop will terminate. + drop drop 1- + } if-else + ~ (queued space count, input point) + } if-else + } while drop drop drop ; + + +~ (string pointer --) +: hex-emit-comment + hex-comment-second-tab-stop current-column@ > { + newline + hex-comment-first-tab-stop dup indent current-column! + 1 is-fresh-line! + 0 n-bytes-this-line! + } if + + ." ~" + 1 advance-current-column + + dup @ { + space + 1 advance-current-column + } if + + hex-emit-template-string ; + + +~ This "replacement" is a little different from an alternate: When the code +~ under transformation attempts to compile its own version of sys-write, it +~ gets a stub that calls this word instead. It's swapped out by +~ hex-colon-alternate, whereas the regular alternates are swapped out by +~ hex-transform-one. +~ +~ In the programs we're actually running the transform on, there's only ever +~ a single call to sys-write which is the whole binary in one go, but we don't +~ want to require that, so we keep all the formatting state in the output +~ metadata header. +~ +~ (file descriptor, base address, length to write -- length written) +: hex-sys-write-replacement + ~ In intended operation, the code under transformation is a compilation + ~ process, and it won't output anything that isn't executable binary. + ~ However, while developing, it's common to have crashes, and it's nice to + ~ get the crash dump as ASCII rather than hex. + over is-in-label-loop-buffer not { + sys-write exit + } if + 3roll drop dup 3roll + ~ The result should be the length written. We just proactively declare + ~ that we'll write the full length we were asked to, threading that through + ~ as the result we'll eventually return. + ~ (result, length to write, base address) + + postprocess-metadata-entries + + ~ Importantly, postprocessing leaves the entries sorted, which means we + ~ can go back and forth in a linear scan through the entry array while we + ~ also do a linear scan of the output data. It's fiddly, but we can't afford + ~ to be O(n^2) here, it adds up to quite a lot of runtime. + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + ~ (result, length to write, base address, initial metadata scan pointer) + { 2 pick 0 <= } { + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + ~ Keep inspecting entries as long as the output address is greater than + ~ or equal to the entry address. If we're looking at the entries that come + ~ before the output, this will scan through all of them first, then + ~ eventually catch up. Since the scan pointer is kept across iterations, + ~ it's important we not go beyond that point. + { dup @ dup + ~ (result, length remaining, current output address, + ~ metadata scan pointer, entry's first field, entry's first field) + { + ~ This is an nop, but for clarity's sake it's best to not depend on + ~ details of the structure layout that perhaps not everyone has + ~ memorized... + ~ + ~ To get into this block, we tested for the array end indicator, but + ~ now that we know we have an entry here, we're looking at its + ~ contents. + hex-output-metadata-entry-data-start + + dup 3 pick + ~ (result, length remaining, current output address, + ~ metadata scan pointer, entry's data start, entry's data start, + ~ current output address) + >= swap drop + } if + } { + dup @ + 2 pick = { + ~ We found a matching metadata entry. + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-line-comment = { + fresh-line + indentation-depth@ dup indent advance-current-column + + dup hex-output-metadata-entry-content @ hex-emit-comment + newline + + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-suffix-comment = { + hex-comment-first-tab-stop current-column@ - 1 max + dup indent advance-current-column + + dup hex-output-metadata-entry-content @ hex-emit-comment + newline + + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-fresh-line = { + fresh-line + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-blank-line = { + fresh-line + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-indent = { + dup hex-output-metadata-entry-content @ + indentation-depth@ + indentation-depth! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-string-literal = { + fresh-line + indentation-depth@ dup indent advance-current-column + + ." ~ " + 0x22 value@ emitstring drop + dup hex-output-metadata-entry-content @ emitstring + 0x22 value@ emitstring drop + ." (string literal with null)" + + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-raw-string-literal = { + fresh-line + indentation-depth@ dup indent advance-current-column + + ." ~ " + 0x22 value@ emitstring drop + dup hex-output-metadata-entry-content @ emitstring + 0x22 value@ emitstring drop + ." (raw string literal)" + + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + dup is-push-subitem-entry { + dup push-subitem-entry-stack + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-saved-data = { + ~ It's not valid to execute these, so print a diagnostic. They're + ~ supposed to always be consumed by data-* commands. + ." A saved-data metadata entry leaked." newline + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-drop-subitem = { + pop-subitem-entry-stack drop + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-swap-subitems = { + ~ If we underflow the stack, we'll get zeroes back here. In order + ~ to avoid causing more confusing problems later, we make sure to + ~ discard the zeroes instead of pushing them. Just like in + ~ hex-emit-template-string, the reasoning is that it's easier to + ~ diagnose what's wrong with this subsystem when it runs to + ~ completion. + pop-subitem-entry-stack + pop-subitem-entry-stack + swap + dup { push-subitem-entry-stack } { drop } if-else + dup { push-subitem-entry-stack } { drop } if-else + } if + + dup hex-output-metadata-entry-type @ + hex-output-metadata-entry-type-roll-subitems = { + ~ The parameter giving the amount to roll by is in the content + ~ field. + dup hex-output-metadata-entry-content @ + ~ (... amount to roll by) + + ~ We resist the temptation to do the memcopy math. We don't need + ~ to, since the regular Forth roll and unroll do it for us. + dup 0 < { + ~ In this scenario, we're rolling. The amount to roll by is also + ~ the number of items. + + 0 { 2dup < } { pop-subitem-entry-stack 3unroll 1+ } while + drop + ~ (... items, amount to roll by / number of items) + + ~ Please notice that the items we have popped from the subitem + ~ entry stack are now, on the value stack, in the reverse of the + ~ order they were on the entry stack. They will reverse again when + ~ we push them back. + ~ + ~ The amount to roll by is positive, so the desired operation is + ~ a regular roll. Since the entries are reversed right now, we + ~ unroll them, which will be what we want when we put them back. + ~ + ~ Try it out interactively with a toy example and convince + ~ yourself. It's hard to really model in your head, but it's true. + ~ The intuition is that, if you're looking at the value stack, + ~ the bottommost item there will be the topmost one after + ~ re-reversing, so we think of our operations as proceeding + ~ up-stack from there, instead of the usual operations that start + ~ at the topmost item and proceed downwards. + ~ + ~ Anyway, this little trick does a regular unroll, which acts as + ~ a roll, and keeps the value around. + dup 3unroll 1+ unroll + } if + ~ (... items if positive, amount to roll by) + + ~ We did the positive case first, which means the amount to roll + ~ by is still its original value, regardless of whether that case + ~ ran or not. So, we can check if it's negative to see if we need + ~ to do the negative case. + dup 0 > { + ~ In this scenario, we're unrolling. We negate the amount to + ~ roll by to get the amount to unroll by, which is also the number + ~ of items. + negate + + 0 { 2dup < } { pop-subitem-entry-stack 3unroll 1+ } while + drop + ~ (... items, number of items) + + ~ The parameter was negative, so we were asked to do an unroll. + ~ This trick does a roll, and keeps the value. Notice that "roll" + ~ always needs a positive amount. + dup 1+ roll swap + } if + ~ (... items, number of items) + + ~ Now, regardless of which case ran, we have the items and we have + ~ a non-negative count of them. Notice that if we were asked to roll + ~ by zero, neither case ran, but that still describes what we have + ~ accurately. + + ~ Now we push them back. + 0 { 2dup < } { + 3roll + + ~ Again, if we underflowed we got zeros, and we discard them. + dup { push-subitem-entry-stack } { drop } if-else + + 1+ + } while + drop drop + } if + } if + hex-output-metadata-next-entry + } while + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + 2 pick { + n-bytes-this-line@ 16 = { + newline + 1 is-fresh-line! + 0 n-bytes-this-line! + 0 current-column! + } if + + is-fresh-line@ { + indentation-depth@ dup indent advance-current-column + } { + space + 1 advance-current-column + } if-else + + over 8@ .hex8 + + 2 advance-current-column + increment-bytes-this-line + 0 is-fresh-line! + } if + ~ (result, length remaining, current output address, + ~ metadata scan pointer) + + 3unroll 1+ swap 1- swap 3roll + } while drop ; + +~ This has complex logic, so we do it as a trace rather than with magic +~ comments. +~ +~ (new label value, label entry pointer --) +: hex-set-label-trace + ~ If the value is zero, don't bother making an entry. There's a bunch of + ~ unused labels set to zero and even if they were used, showing them at the + ~ start of the file would not provide useful information. + over 0 = { drop drop exit } if + + ~ Similarly, if the label has its non-offset bit set, we don't need an + ~ entry for that, either + ~ + ~ It's worth noting that this bit is set by the code being compiled, + ~ potentially after it has already called label-set, and therefore after + ~ this trace. This introduces an ordering dependency, though it's unlikely + ~ to come up in practice because the bit is kept across label-loop passes + ~ and as long as there are any forward references there will always be at + ~ least two passes. + dup is-label-non-offset { drop drop exit } if + + ~ Recall that label values are offsets within the output file. This is not + ~ otherwise a requirement, compiled code can use their values for anything + ~ it wants, but the label transform treats them as offsets and so does the + ~ ELF code. + ~ + ~ We want to create metadata entries associated with that offset; recall + ~ also that entries' data starts are host addresses which must be within + ~ the label-loop buffer. So... + over + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-start @ + + 0 + ~ (new label value, label entry pointer, entry data start, + ~ entry data length) + + 2dup hex-output-metadata-entry-type-push-subitem-hex64 7 roll + add-hex-output-metadata-entry + ~ (label entry pointer, entry data start, entry data length) + + 2dup hex-output-metadata-entry-type-push-subitem-string + 6 roll entry-to-name + + swap-transform-variables here @ swap-transform-variables dup 3unroll + ~ (copy, original, copy) + over stringlen 1+ memcopy + swap-transform-variables allocate-string swap-transform-variables + add-hex-output-metadata-entry + + hex-output-metadata-entry-type-line-comment + s" label # at offset # is here." + add-hex-output-metadata-entry ; + +~ (data start, data length --) +: hex-pack-trace + ~ We keep a running tally of the next address in the output, for the + ~ benefit of hex-tilde-replacement, which needs to know where to attach its + ~ metadata entries. + + + dup is-in-label-loop-buffer { + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point ! + } { drop } if-else ; + +~ (output point, string pointer --) +: hex-packstring-trace + dup stringlen 1+ + ~ (output point, string pointer, string length) + 2 pick over hex-pack-trace + swap + ~ (output point, string length, string pointer) + drop over + hex-output-metadata-entry-type-string-literal swap + add-hex-output-metadata-entry ; + +~ The purpose of this word is to make sure that the memory-sliding +~ techniques used by the high-level flow control words are appropriately +~ reflected in the output metadata. This is accomplished by finding all +~ entries whose data start pointer or string content pointer is within the +~ slid region, and adjusting the relevant pointer appropriately. +~ +~ Notice that this strategy means there's no metadata entry describing the +~ old location of the slid memory, though sliding is non-destructive. The +~ assumption is that that location is going to be overwritten with new code, +~ which will have its own metadata entries created as the new code is written. +~ Otherwise, since we don't do anything to erase metadata entries pertaining +~ to overwritten locations, old and new metadata entries would overlap and +~ cause confusion. The assumption is correct for all existing uses of +~ memory-sliding as of the time this was written, but it's possible it will +~ need to be revisited someday. +~ +~ This word is called for both memcopy and memmove. It's called by +~ hex-memory-slide-replacement, which is itself installed by a variety of +~ means for different situations; see its documentation for more detail. +~ +~ (source, destination, length --) +: hex-memory-slide-trace + 2 pick is-in-label-loop-buffer + 2 pick is-in-label-loop-buffer && + { + ~ At the time this runs, the metadata entry array isn't sorted, so we + ~ check the whole thing. + transformation-state transformation-state-output-metadata @ + hex-output-metadata-first-entry + ~ (source, destination, length, initial metadata scan pointer) + { dup @ } { + ~ (source, destination, length, metadata scan pointer) + + dup hex-output-metadata-entry-data-start @ 4 pick <= + ~ (source, destination, length, metadata scan pointer, lower bound okay) + over hex-output-metadata-entry-data-start @ 5 pick 4 pick + > + && { + ~ (source, destination, length, metadata scan pointer) + dup hex-output-metadata-entry-data-start @ 4 pick - 3 pick + + over hex-output-metadata-entry-data-start ! + } if + + dup hex-output-metadata-entry-type @ + dup hex-output-metadata-entry-type-string-literal = + swap hex-output-metadata-entry-type-raw-string-literal = || { + dup hex-output-metadata-entry-content @ + ~ (source, destination, length, scan pointer, content pointer) + dup 5 pick <= + ~ (source, destination, length, scan pointer, content pointer, + ~ lower bound okay) + over 6 pick 5 pick + > && { + ~ (source, destination, length, scan pointer, content pointer) + 4 pick - 3 pick + + over hex-output-metadata-entry-content ! + } { drop } if-else + } if + + hex-output-metadata-next-entry + } while 4 ndrop + } { drop drop drop } if-else ; + + +~ By overriding colon, we can special-case the definitions of particular +~ words. It's very metacircular. +~ +~ This lets us prepend trap code to the original definition. For those not +~ familiar, a "trap" in systems programming is code that runs instead of some +~ other, pre-existing code, by violating the usual abstractions in some way. +~ We implement our traps by creating the word header, including the docol +~ pointer, then compiling the trap code before we return from the colon +~ alternate, so that it's already been output before the original word's body +~ starts to compile. +~ +~ Prepending our trap code to the original code like this can also be used +~ to get the effect of replacing the original code entirely by calling "exit" +~ at the end of our trap. The original code will still be compiled, after the +~ trap code, but doing this will make sure it doesn't run. Most of the time, +~ though, we do want to run the original code, so we allow the trap to fall +~ through to it. We carefully note fall-through with comments, to make the +~ traps easier to maintain. +~ +~ The kinds of side-effects we care about can all be written this way, +~ though occasionally we wind up having to compute an intermediate value that +~ the code we're trapping will then compute independently, and it's important +~ to keep those implementations in sync. +~ +~ The most significant challenge is that, because our trap will be defined +~ at the same point in loading as the original word would be, it can only use +~ words that are available at that point. Occasionally this results in some +~ awkwardness. +~ +~ Code for these traps winds up looking a lot like code written for log-load +~ alternates, in that we have to do the dictionary lookups and other +~ compilation ourselves. +~ +~ At times, we also need to trap words that are implemented in assembler. +~ The most notable of these is "sys-write", which is fundamental to what the +~ hex transform does. The details of how we make our traps work with assembler +~ words are explained below, as they arise. +: hex-colon-alternate + word value@ + + ~ The word "variable" is itself a word-defining word, and we will + ~ special-case its definition to special-case the definitions of particular + ~ variables. It's very very metacircular. + dup s" variable" stringcmp 0 = { + ~ Don't lose track of the layering happening here. The word "variable" + ~ is a regular docol word; it's defining a word that's implemented in + ~ assembly, but it can use whatever Forthy logic it wants to do so. In + ~ this case we're going to have it run a little extra logic, then continue + ~ with the rest of its usual definition. + + ~ Before we get to the extra logic, we do want an entry header for + ~ "variable" itself, so we do that... This takes care of all of colon's + ~ responsibilities except switching to compile mode; we'll do that part + ~ after we've output our payload. + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ There's two variables that we want to point to the outer backing + ~ stores, rather than the inner ones. The code for that is a bit + ~ repetitive, so we have a helper for it; see above. + ~ + ~ It is worth stopping to contemplate the meaning of sharing these two + ~ variables in particular between the inner and outer contexts. + ~ Essentially this says that they're both reading the same input stream, + ~ and the two copies of the interpreter both share the same state. Thus, + ~ trading off responsibility for lexing between inner and outer contexts + ~ works just like trading off responsibility between two interpreters + ~ when there's no transformation involved, or between a regular + ~ interpreter and a transform. + ~ + ~ If we didn't do this, we'd still have to invent some way to control + ~ what input the inner context sees, and the concept of "the next + ~ character" would become more complex during the transform and require + ~ care and attention. Sharing this stuff keeps it simple. + s" interpreter-flags" hex-variable-use-outer + s" main-input-buffer" hex-variable-use-outer + ~ After this, we can return control to the regularly-scheduled + ~ "variable", which will do the "create" and all that. That stuff isn't + ~ colon's responsibility, so it isn't our responsibility, it'll happen + ~ regardless. + + ~ Notably, we do NOT share transformation-state. There are at least a + ~ hundred places where it would need to be carefully swapped, and we + ~ already have quite enough of that kind of brittleness in the log-load + ~ transform. Plus, there's no obvious way to do a real push/pop notion for + ~ it, so we wouldn't get arbitrary nesting of transforms anyway. By + ~ letting the code inside the hex transform have its own, separate copy of + ~ transformation-state, we avoid that problem entirely, and it's still not + ~ hard to access the "other" one when circumstances require. + + ~ Now we close out colon's responsibilities by switching to compile + ~ mode. We return from colon after this. The hex transform will continue + ~ by processing the source words that form the regular body of "variable", + ~ eventually hitting the matching semicolon. Our friendly tampering is + ~ now complete! + ' ] entry-to-execution-token execute + exit + } if + + ~ Now we want to override s". As usual, that's the single most annoying + ~ string to quote, so we cheat. + dup ' s" entry-to-name stringcmp 0 = { + ~ Create the word header. It's a normal docol word, so that much is + ~ simple. + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ This time around we would really rather just always use the alternate, + ~ which already untangles the layered nonsense. So we have the payload + ~ call the alternate directly, then exit. We could come up with a way to + ~ then skip forward in the code under transformation, but that would be + ~ complex, and it's unnecessary: We let it keep running, outputting the + ~ usual body of s", which we know will never be reached. + ' hex-string-alternate entry-to-execution-token , + s" exit" find entry-to-execution-token , + + ~ As before, finish up colon's responsibilities, then return control to + ~ the code under transformation. + ' ] entry-to-execution-token execute + exit + } if + + ~ Same deal for .". Hey, we're getting good at this! + dup ' ." entry-to-name stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ' hex-dot-string-alternate entry-to-execution-token , + s" exit" find entry-to-execution-token , + + ' ] entry-to-execution-token execute + exit + } if + + ~ We want to suppress the behavior of relink-main-input-buffer-to-stdin + ~ entirely. Happily, that's easy. We need to do this because otherwise the + ~ transformed code will mess with our outer interpreter! + dup s" relink-main-input-buffer-to-stdin" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ Return before doing anything. + s" exit" find entry-to-execution-token , + + ' ] entry-to-execution-token execute + exit + } if + + ~ We are entirely replacing sys-write with our own version. It's an + ~ assembly word, and we're replacing it with a Forth word, so there's some + ~ matching code in the ;asm alternate that makes sure to not mess that up. + dup s" sys-write" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ' hex-sys-write-replacement entry-to-execution-token , + s" exit" find entry-to-execution-token , + + ' ] entry-to-execution-token execute + exit + } if + + ~ Now we have a bunch of patches that keep track of output metadata. These + ~ are all Forth words, nothing too complicated about the actual patching. + dup s" reset-labels" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ This is only ever called in one place, the end of a failed iteration + ~ of label-loop. We need to reinitialize all the metadata entries whenever + ~ that happens, and reset-labels is a good semantic match for that + ~ behavior, so it's a good place for the hook. + ' create-hex-output-metadata-top-of-file-entries + entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + dup s" set-label" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ (new label value, label entry pointer --) + s" 2dup" find entry-to-execution-token , + ' hex-set-label-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + + dup s" packstring" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ (output point, string pointer) + s" 2dup" find entry-to-execution-token , + ~ This one's a lot of work, so we defer to a single-purpose word. + ' hex-packstring-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ This is highly similar to packstring. + dup s" pack-raw-string" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ (output point, string pointer) + s" 2dup" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" stringlen" find entry-to-execution-token , + ~ (output point, string pointer, string length NOT including terminator) + + ~ Before we add the metadata entry, we also want to call hex-pack-trace + ~ to make sure latest-output-point gets adjusted for the string. + ~ Otherwise, we'd see magic comments in the wrong place. + s" 3roll" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" lit" find entry-to-execution-token , + 4 , + s" unroll" find entry-to-execution-token , + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, string pointer, string length NOT including terminator, + ~ output point, string length NOT including terminator) + ' hex-pack-trace entry-to-execution-token , + + ~ (output point, string pointer, string length including terminator) + s" swap" find entry-to-execution-token , + ' hex-output-metadata-entry-type-raw-string-literal + entry-to-execution-token , + s" swap" find entry-to-execution-token , + ' add-hex-output-metadata-entry entry-to-execution-token , + ~ (output point, string pointer) + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + + dup s" pack8" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 1 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ Extremely similar to the pack8 patch. + dup s" pack16" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 2 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ Extremely similar to the pack8 patch. + dup s" pack32" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 4 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ Extremely similar to the pack8 patch. + dup s" pack64" stringcmp 0 = { + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + + ~ We can't use over because this patch happens at the time pack8 is + ~ being defined, and it would be a forward reference. We do the equivalent + ~ by hand. + ~ (output point, value) + s" swap" find entry-to-execution-token , + s" dup" find entry-to-execution-token , + s" 3unroll" find entry-to-execution-token , + ~ (output point, value, output point) + s" lit" find entry-to-execution-token , + 8 , + ' hex-pack-trace entry-to-execution-token , + ~ Fall through to the inner implementation. + + ' ] entry-to-execution-token execute + exit + } if + + ~ If no special case matches, we fall back to just being a regular colon. + ~ We already read the word name above, so we have to do the rest of the + ~ steps ourselves as well. + create dropstring + s" docol" find entry-to-execution-token execute , + make-hidden + ' ] entry-to-execution-token execute + ; + + +~ This word gets installed as a trap at the beginning of every Forth word, +~ so that it can examine the control stack and produce kinds of metadata that +~ require information that only exists at runtime. See +~ hex-semicolon-alterante, below, for details of how it's installed. +~ +~ It is worth noting that hex-trap can coexist with the more-targeted traps +~ installed by hex-colon-alternate, above. It runs before them, because +~ hex-colon-alternate prepends its stuff first and then +~ hex-semicolon-alternate slides that all forward to prepend the call to +~ hex-trace. +~ +~ TODO this probably doesn't serve a purpose in the end, and should go away, +~ but the actual stack-walking code is useful and should be kept until it's +~ been refactored into something worth keeping. +: hex-trace + exit + ~ value@ here @ swap 0 hex-output-metadata-entry-type-line-comment + ~ add-hex-output-metadata-entry + newline + ~ This stack-walking code is modeled off the code in list-callers, in + ~ language/dynamic/dynamic.e. + ~ + + ~ This is the bit of the hex transform where all the memory-management + ~ assumptions are in play at once, so, in understanding it, it's probably + ~ a good idea to skim back over the background described under "hex + ~ transform implementation", above, and make sure it's fresh in your mind. + ~ + ~ It's important to notice that, as we walk it, the values of "here" and + ~ "latest" reflect the log and dictionary of the code being transformed, ie. + ~ they are the ones in the output buffer, not the log and dictionary of the + ~ outer program. Therefore, we can use containing-entry to find the entry + ~ headers for words inside the transform, and if we want to look at words + ~ outside the transform we can wrap containing-entry in + ~ swap-transform-variables. We can't use is-in-log, though, because the + ~ label-loop buffer is inside the output buffer, which is inside the outer + ~ log, so it doesn't make the distinctions we need it to. + ~ + ~ Every word inside the transform will have hex-transform-one exactly once + ~ in its call chain, so we walk the control stack only up to that point. + control@ + { ~ First, check to make sure we haven't run off the bottom of the control + ~ stack. Remember, the control stack is an array of pointers, so this is a + ~ simple bounds check. + dup r0 @ > + + ~ If it is, we also want to look at what it points to. + dup { + ~ Dereference the pointer we've been iterating (... we're actually + ~ looking at a pointer to a pointer ...), and check that it's not inside + ~ hex-transform-one's body. + drop dup @ + + ~ The inner dictionary is inside the outer log, so we'll get an entry + ~ header regardless of which dictionary we consider, but it may not be + ~ the one we care about. If we want to get the correct entry pointer, we + ~ have to make sure we're looking at the outer dictionary. + swap-transform-variables + + ~ Check what entry the control pointer is in. + containing-entry + + ~ Get the entry for hex-transform-one to compare against. This would + ~ be a forward reference, so we need to look it up at runtime. + s" hex-transform-one" find + + ~ Now switch back. + swap-transform-variables + + ~ If they're equal, we want to stop the loop. + != + } if } + { dup @ + + ~ TODO this isn't in quine.asm, so if we keep this code at all, that needs + ~ to be dealt with + ~ symbolize-pointer space + + ~ Iterate to the next pointer in the control stack. It's an array of + ~ pointers, so this is just arithmetic. + 8 + } while + drop ; + + +~ We want to trace every call to a Forth word, for use in generating +~ metadata. To do this, we want to add a prefix trap to the calls, but we +~ can't put the logic in hex-colon-alternate because we don't know which +~ words are Forth words and which are assembly words until we see the +~ semicolon. +~ +~ So, we do it here in hex-semicolon-alternate. The word body has already +~ been compiled at this point, so we slide the whole body forward to make +~ room. This is explicitly allowed by our compilation model; you may be +~ aware that it's also how high-level flow control is implemented. +~ +~ You might find it useful to compare this code to the implementations of +~ high-level flow-control utilities in language/static/log-load.e; it operates +~ under a very similar set of constraints, except that fortunately we don't +~ have the nightmare multi-dictionary situation that the log-load transform +~ does. +: hex-semicolon-alternate + latest @ entry-to-execution-token 8 + + dup dup dup + ~ (start, start, start, start) + + ~ The actual body of the trap is just a single word long (see below). If + ~ that ever changes, make sure to keep the amount we slide by in sync with + ~ it. + 8 + swap ~ TODO change number of words + ~ (start, start, adjusted start, start) + + here @ swap - + ~ (start, start, adjusted start, length) + + memmove + ~ (start) + + ~ We're going to use comma to append compiled code, so let's swap out the + ~ value of "here" to point to the space we just opened up. + here @ swap here ! + ~ (old "here") + + ~ This applies to every single word terminated with semicolon, which is + ~ all the Forth words that are created directly rather than with "variable" + ~ or some similar high-level facility. Because we also can't have forward + ~ references, that means we can't assume we'll have any available words in + ~ the transformed code to call, at all. So, the only thing we can usefully + ~ have the trap do is call a word that's defined as part of the transform. + ~ + ~ Fortunately, we do get to assume there will be a normal entry header in + ~ place for the word we're trapping. So we don't need to scrounge up any + ~ runtime data for the trap's benefit; the trap will be able to get what it + ~ needs by inspecting the control stack and the log. + ' hex-trace entry-to-execution-token , + + ~ We're done compiling the trap's contents, so swap "here" back. Again, + ~ keep this in sync with the length of the trap. + 8 + here ! + + ~ Now we do the regular semicolon stuff. + [ ' ; entry-to-execution-token , ] + ; make-immediate + + +: hex-semicolon-assembly-alternate + latest @ entry-to-name + dup s" sys-write" stringcmp 0 = { + ~ As detailed in hex-colon-alternate, above, sys-write is implemented in + ~ assembly but we replace it with Forth. This logic here collaborates with + ~ the logic there to make that work. + ~ + ~ The transformed code will still have compiled some assembly, though it + ~ won't be reached and would crash, so we need to fix alignment before we + ~ call semicolon. + drop + here @ 8 packalign here ! + [ ' ; entry-to-execution-token , ] + exit + } if + drop + + ~ If no special case matches, we fall back to the regular behavior. + [ ' ;asm entry-to-execution-token , ] + ; make-immediate + + +~ Because docol requires it, we provide a special mini-version of the label +~ system. We only do L@' and L!', because that's all we need. Unlike with the +~ label transform, these are NOT real labels; they're restricted similarly to +~ how they are for the log-load transform. +~ +~ Per the precedence rules in hex-transform-one, this version will apply to +~ all invocations, regardless of compile mode vs. immediate execution. +~ However, its own logic defers to the inner label system when that exists. +: hex-L@'-alternate + ~ If there's an inner copy of L@' defined, defer to it. + s" L@'" find dup { + entry-to-execution-token execute + exit + } { drop } if-else + + word dropstring + transformation-state transformation-state-label-scratch @ + ; make-immediate + +: hex-L!'-alternate + ~ If there's an inner copy of L!' defined, defer to it. + s" L!'" find dup { + entry-to-execution-token execute + exit + } { drop } if-else + + word dropstring + transformation-state transformation-state-label-scratch ! + ; make-immediate + + +~ The code we're compiling may try to exit when it's done. We want to return +~ to our caller instead; we turn that into an nop. This isn't quite correct, +~ but it will work as long as the inner code doesn't try to do anything else +~ after. +: hex-bye-alternate ; + + +~ Okay, now here's an interesting one. We need to provide additional +~ behavior for "allocate", but only when it is called directly from the body +~ of label-loop. That condition of being in the body is only testable +~ immediately, though "allocate" is not an immediate word and the effect of it +~ needs to happen later. This is crucial functionality that we can't work +~ without. So, we use a replacement and an alternate that work in tandem. +~ +~ First, we define the replacement... +~ +~ (size -- pointer) +: hex-allocate-replacement + dup allocate swap + ~ (result pointer, size) + + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-length ! + ~ (result pointer) + + dup + transformation-state transformation-state-output-metadata @ + hex-output-metadata-label-loop-buffer-start ! + ~ (result pointer) + + create-hex-output-metadata-top-of-file-entries ; + +~ ... then, we define the alternate. +~ +~ The alternate is flagged as immediate, which means hex-transform-one will +~ treat it as always having the highest priority. It checks what mode we're +~ in; if we're immediate, it runs the inner "allocate" if it exists or the +~ outer one if not. If we're compiling, it checks if we're in the body of +~ label-loop and compiles an execution token for the replacement if so, or the +~ inner "allocate" if not. +~ +~ If that was confusing: The point is, by having the immediate effect be +~ compilation, we get to have it both ways. +: hex-allocate-alternate + interpreter-flags @ 0x01 & { + ~ Compile mode. + latest @ entry-to-name dup s" label-loop" stringcmp 0 = { + ~ In label-loop. + drop + ' hex-allocate-replacement entry-to-execution-token , + } { + ~ Not in label-loop. + drop + s" allocate" find entry-to-execution-token , + } if-else + } { + ~ Immediate mode. + s" allocate" find + dup { entry-to-execution-token execute } { drop allocate } if-else + } if-else ; make-immediate + + +~ In order to handle code that slides compiled code around, most notably the +~ high-level flow-control words, we trap memcopy and memmove. These are +~ assembly words, so trapping them with hex-colon-alternate is inconvenient; +~ instead we patch their callers. This is like the "allocate" trap, but +~ simpler. There's no special logic needed here, we just unconditionally +~ install the trap. +~ +~ This word is responsible for processing the hook. For code running +~ directly under the hex transform, it's installed by hex-memcopy-alternate +~ and hex-memmove-alternate, immediately below. For code running in a nested +~ label transform, see hex-label-word-replacement, further down. Note +~ carefully that when it's in a nested transform, the hook only runs in +~ immediate mode; running it in compile mode would affect the program being +~ compiled. +~ +~ It is worth noting that, as of the time this code was written, there is +~ never actually any memory sliding of compiled code that occurs outside of a +~ nested transform. This aligns with intuition, since sliding is really only +~ done in the high-level flow-control words. However, should it happen in the +~ future, we still want it to work, so it's implemented. +~ +~ The actual metadata handling is done by hex-memory-slide-trace, which is +~ above, near the other words that trace memory operations. We let the +~ replacement handle preserving the parameters so that the trace doesn't need +~ to, since that would be a difference between it and the other words similar +~ to it. +~ +~ (source, destination, length -- source, destination, length) +: hex-memory-slide-replacement + 2 pick 2 pick 2 pick hex-memory-slide-trace ; + +~ These two alternates are responsible for installing +~ hex-memory-slide-replacement, immediately above, in invocations of memcopy +~ and memmove that occur directly under the hex transform. For invocations +~ that occur in nested transforms, see hex-label-word-replacement, further +~ down. +: hex-memcopy-alternate + interpreter-flags @ 0x01 & { + ' hex-memory-slide-replacement entry-to-execution-token , + s" memcopy" find entry-to-execution-token , + } { + hex-memory-slide-replacement + s" memcopy" find entry-to-execution-token execute + } if-else ; make-immediate +: hex-memmove-alternate + interpreter-flags @ 0x01 & { + ' hex-memory-slide-replacement entry-to-execution-token , + s" memmove" find entry-to-execution-token , + } { + hex-memory-slide-replacement + s" memmove" find entry-to-execution-token execute + } if-else ; make-immediate + + +~ Similar to how we handle "allocate" as a replacement which is installed by +~ an alternate, we do the same for tilde, but for a different reason. The +~ semantics of ordinary, non-transformed tilde skip over comment text while +~ compiling, and discard it. We need to do processing of that text later, when +~ the comment's position would be reached in running the word it's part of, so +~ the alternate compiles it appropriately. +~ +~ Importantly, the replacement is only used for comments that have a special +~ comment syntax unique to the hex transform, as described in more detail in +~ the alternate, below. If it were used for all comments, it would interfere +~ with the distance of branches, which could get quite complex to work around. +~ It is the responsibility of words that use the hex-transform comment syntax +~ to avoid placing such comments within the scope of a branch. This applies +~ only to explicit, precomputed branches using the words "branch" and +~ "branch0". Fortunately, implicit branches that are part of high-level +~ flow-control words such as "if" and "while" will work fine, since the +~ substitution occurs before the flow control words start sliding code around, +~ and it updates "here" appropriately. +~ +~ Because hex-tilde-replacement is called in various situations during +~ various phases of compilation and interpreting, it can't take responsibility +~ for knowing how the string pointer it's given is allocated. It assumes the +~ string pointer will be valid indefinitely; it's the caller's responsibility +~ to make sure of that. +~ +~ (has non-space this line, string pointer --) +: hex-tilde-replacement + transformation-state transformation-state-output-metadata @ + hex-output-metadata-latest-output-point @ + swap + ~ (has non-space this line, data start, string pointer) + + ~ If the output wouldn't go in the label-loop buffer, don't do any of + ~ this. + ~ + ~ That may seem spurious, but remember, the same assembly instructions + ~ are used for compiling the final binary and defining words within the + ~ compiler. In particular, "variable" will hit this, and there are surely + ~ others. + over is-in-label-loop-buffer not { 3 ndrop exit } if + + ~ Copy the first space-separated word of the comment body into scratch + ~ space to see if it's a special instruction. To minimize interference with + ~ the program under transformation, we use the outer log's scratch space + ~ rather than the inner one's. + swap-transform-variables + dup + here @ + ~ (... source pointer, destination pointer) + { over 8@ dup 0x20 != && } { + swap unpack8 swap 3unroll pack8 + } while + 0 pack8 drop drop + + here @ + swap-transform-variables + + ~ (has non-space this line, data start, string pointer, + ~ first word string pointer) + dup read-integer 0 = { + ~ (has non-space, data start, string pointer, first word string pointer, + ~ data length) + 3unroll stringlen 1+ + + ~ (has non-space, data start, data length, adjusted string pointer) + 4 roll drop + 1 swap + ~ (data start, data length, is suffix, adjusted string pointer) + } { + drop 0 swap + ~ (has non-space, data start, data length, string pointer) + 4 roll swap + ~ (data start, data length, is suffix, string pointer) + } if-else + ~ (data start, data length, is suffix, adjusted string pointer) + + ~ Now look for instruction keywords. These keywords are expected to be the + ~ entire line, except that a length field can come before them. + dup s" adjust-length" stringcmp 0 = { + ~ Modify the most recent comment entry by adjusting its length. + drop drop swap drop adjust-latest-comment-metadata-entry-length + exit + } if + dup s" adjust-start" stringcmp 0 = { + ~ Modify the most recent output-producing entry by adjusting its start. + drop drop swap drop adjust-latest-output-producing-metadata-entry-start + exit + } if + dup s" set-output-point" stringcmp 0 = { + ~ Override the latest output point. + drop drop swap drop set-latest-output-point + exit + } if + dup s" adjust-output-point" stringcmp 0 = { + ~ Modify the latest output point. + drop drop swap drop adjust-latest-output-point + exit + } if + + dup s" data-adjust-length" stringcmp 0 = { + ~ Modify the most recent comment entry by adjusting its length, also + ~ using data from the most recent data entry. + drop drop swap drop data-adjust-latest-comment-metadata-entry-length + exit + } if + dup s" data-adjust-start" stringcmp 0 = { + ~ Modify the most recent output-producing entry by adjusting its start, + ~ also using data from the most recent data entry. + drop drop swap drop + data-adjust-latest-output-producing-metadata-entry-start + exit + } if + dup s" data-set-output-point" stringcmp 0 = { + ~ Override the latest output point, also using data from the most recent + ~ data entry. + drop drop swap drop data-set-latest-output-point + exit + } if + dup s" data-adjust-output-point" stringcmp 0 = { + ~ Modify the latest output point, also using data from the most recent + ~ data entry. + drop drop swap drop data-adjust-latest-output-point + exit + } if + + dup s" suppress" stringcmp 0 = { + ~ Suppress the next N entries, or adjust the remaining count of entries + ~ to suppress. + drop drop swap drop adjust-hex-output-suppression-count + exit + } if + + dup s" delete-first-comment-at-output-point" stringcmp 0 = { + 4 ndrop delete-first-comment-metadata-entry-at-output-point + exit + } if + + dup s" delete-last-comment-at-output-point" stringcmp 0 = { + 4 ndrop delete-latest-comment-metadata-entry-at-output-point + exit + } if + + dup s" fresh-line" stringcmp 0 = { + ~ Create a new fresh-line entry. + drop drop hex-output-metadata-entry-type-fresh-line 0 + add-hex-output-metadata-entry + exit + } if + + dup s" blank-line" stringcmp 0 = { + ~ Create a new blank-line entry. + drop drop hex-output-metadata-entry-type-blank-line 0 + add-hex-output-metadata-entry + exit + } if + + dup s" indent" stringcmp 0 = { + ~ Create a new indent entry with a positive indentation delta. + drop drop hex-output-metadata-entry-type-indent 2 + add-hex-output-metadata-entry + exit + } if + + dup s" deindent" stringcmp 0 = { + ~ Create a new indent entry with a negative indentation delta. + drop drop hex-output-metadata-entry-type-indent -2 + add-hex-output-metadata-entry + exit + } if + + ~ Now we have some commands for the various -provide-subitem- variants. + ~ Notice with all of these that we intentionally read one stack level deeper + ~ than anything of ours, which will be a value provided by the code the + ~ magic comment is embedded in. + dup s" provide-decimal" stringcmp 0 = { + ~ Create a new "push subitem decimal" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-decimal swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex" stringcmp 0 = { + ~ Create a new "push subitem hex" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex8" stringcmp 0 = { + ~ Create a new "push subitem hex8" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex8 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex16" stringcmp 0 = { + ~ Create a new "push subitem hex16" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex16 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex32" stringcmp 0 = { + ~ Create a new "push subitem hex32" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex32 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-hex64" stringcmp 0 = { + ~ Create a new "push subitem hex64" entry. + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-hex64 swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-string" stringcmp 0 = { + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-string swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-string-copy" stringcmp 0 = { + drop drop + 2 pick hex-output-metadata-entry-type-push-subitem-string swap + swap-transform-variables here @ swap-transform-variables dup 3unroll + ~ (copy, original, copy) + over stringlen 1+ memcopy + swap-transform-variables allocate-string swap-transform-variables + add-hex-output-metadata-entry + exit + } if + dup s" provide-keyword" stringcmp 0 = { + ~ Create a new "push subitem string" entry given a keyword pointer. + drop drop + 2 pick execution-token-to-entry entry-to-name + hex-output-metadata-entry-type-push-subitem-string swap + add-hex-output-metadata-entry + exit + } if + dup s" provide-data" stringcmp 0 = { + ~ Create a new "push subitem data" entry. + drop drop + 2 pick hex-output-metadata-entry-type-saved-data swap + add-hex-output-metadata-entry + exit + } if + + ~ Next are the subitem stack manipulation commands. These deal with the + ~ subitem entry stack, just as the provide-* commands do, but at this phase + ~ of processing the effect is just to create an entry in the entry array, + ~ not to do any actual stack manipulation, so their implementations are + ~ quite simple. + dup s" drop-subitem" stringcmp 0 = { + ~ Create a new "drop subitem" entry. + drop drop hex-output-metadata-entry-type-drop-subitem 0 + add-hex-output-metadata-entry + exit + } if + dup s" swap-subitems" stringcmp 0 = { + ~ Create a new "swap subitem" entry. + drop drop hex-output-metadata-entry-type-swap-subitems 0 + add-hex-output-metadata-entry + exit + } if + dup s" roll-subitems" stringcmp 0 = { + ~ Create a new "roll subitem" entry. The parameter goes in the content + ~ field, and the length is always zero. + drop drop 0 swap hex-output-metadata-entry-type-roll-subitems swap + add-hex-output-metadata-entry + exit + } if + + ~ If it's flagged as a suffix by the logic above, create a new + ~ suffix-comment entry. + swap { + hex-output-metadata-entry-type-suffix-comment swap + add-hex-output-metadata-entry + exit + } if + + ~ Create a new line-comment entry. + hex-output-metadata-entry-type-line-comment swap + add-hex-output-metadata-entry ; + + +~ We need to define a few helpers for use in +~ hex-read-magic-comment-introducer, below. The string pointers these return +~ are allocated in the manner described there. +~ +~ (first key -- body-string-pointer) +: hex-read-nonempty-comment-body + ~ This is the rare case in the transforms where we want to get into the + ~ nitty-gritty of lexing. Normally we rely on the upstream implementations, + ~ even when we have to go out of our way to do so, because we don't want to + ~ have to update the transforms every time there's a new syntax feature. + ~ Here, however, we've got a syntax that only has meaning to the transform, + ~ so there's no choice. + swap-transform-variables here @ swap-transform-variables + + ~ This little loop is a modified version of the original tilde loop. + swap { dup dup 0x0a != && } { pack8 key } while drop + + 0 pack8 + 8 packalign + + drop + swap-transform-variables here @ swap-transform-variables ; + +: hex-read-empty-comment-body + swap-transform-variables here @ swap-transform-variables + + 0 pack8 + 8 packalign + + drop + swap-transform-variables here @ swap-transform-variables ; + + +~ This is called from a tilde alternate (such as hex-tilde-alternate, but +~ there are several). Its purpose is to do the lexical analysis of the +~ sequence that introduces a magic comment; it assumes that the leading tilde +~ character has just been consumed from the main input, leaving the separating +~ space as the next character ready to be read. +~ +~ Recall that the delimiter for a regular comment is "~ " (the trailing +~ space is part of it for this purpose). The delimiter for a magic comment is +~ "~ : ". A regular comment may also have a linefeed instead of a space, +~ indicating that it's empty; magic comments likewise can be empty, by ending +~ the line immediately after the colon. +~ +~ This word does the necessary reading, then leaves the input pointing at +~ the body of the comment and returns a value indicating what type of comment +~ this is. A result code of 0 indicates it's a regular comment and the input +~ now points immediately after its ending delimiter; that is, to the start of +~ the next line of text. A value of 1 indicates it's a magic comment with +~ non-zero length and the input points immediately after the delimiter. A +~ value of 2 indicates it's a magic comment with zero length, and the input +~ again points to the start of the next line. +~ +~ Our caller will want to do things with the comment body, so we also return +~ a pointer to a string in temporary storage, for use in further processing. +~ This temporary storage is taken from the "real" log, outside the transform's +~ scope. It's not allocated, merely using the space right after "here", +~ because the caller may or may not wish to allocate it for the long term, and +~ may prefer that its long-term location be elsewhere. +~ +~ Some of the various magic-comment syntaxes care about spacing within the +~ comment body, so it's important to notice that only the first space after +~ the colon is consumed. Any subsequent spaces are part of the body. +~ +~ (-- body string pointer, result code) +: hex-read-magic-comment-introducer + ~ The original code goes byte-by-byte, checks that the value is nonzero + ~ and not equal to 0x0a (linefeed), and exits when either property fails. + ~ We want to do something different based on the very first characters of + ~ the comment body. So, we unroll the first few iterations of the loop so we + ~ can do that test before we fall back to the normal behavior. + ~ + ~ Specifically, we want to recognize a colon (0x3a) with a space (0x20) + ~ immediately after it. Since the interpeter peeked at the space delimiter, + ~ but didn't consume it, we also need to check for a space before the colon, + ~ for a total sequence of three bytes we need to match. We can't just skip + ~ over the space with "consume", because it might also be a linefeed, which + ~ would satisfy the exit criterion. We need to properly match it. + ~ + ~ We also recognize a colon followed immediately by a linefeed, as + ~ denoting an empty comment. + key dup dup 0x0a != && { + ~ If we got here, the first byte was not 0 or 0x0a. Now we check if it's + ~ colon. + 0x20 = { + ~ The first byte was 0x20. Now check the second. + key dup dup 0x0a != && { + dup 0x3a = { + ~ The second byte was 0x3a. Now check the third. + drop key dup { + ~ The third byte is not 0. + dup 0x20 = { + ~ We have a magic comment with a nonempty body. We must save + ~ the rest of it so we can return it. + drop key hex-read-nonempty-comment-body 1 + } { + ~ The third byte is not 0 or 0x20. + dup 0x0a = { + ~ We have a magic comment with an empty body, ending at a + ~ linefeed. As with nonempty ones, we prepare a temporary + ~ string to return. + drop hex-read-empty-comment-body 2 + } { + ~ The third byte was not 0, 0x0a, or 0x20. We got a space, + ~ a colon, and something else. So our special test failed, but + ~ the exit condition isn't met. So we're done unrolling. + hex-read-nonempty-comment-body 0 + } if-else + } if-else + } { + ~ We got a colon and a zero. This is a magic comment with an + ~ empty body, ending at the end of the file. + drop hex-read-empty-comment-body 2 + } if-else + } { + ~ Again, the special test failed but the exit condition isn't met. + hex-read-nonempty-comment-body 0 + } if-else + } { + ~ Again, the exit condition is met. + drop hex-read-empty-comment-body 0 + } if-else + } { + ~ Once more, the special test failed but the exit condition isn't met. + hex-read-nonempty-comment-body 0 + } if-else + } { + ~ For the last time, the exit condition is met. + drop hex-read-empty-comment-body 0 + } if-else ; + + + +~ The tilde alternate is a very important word for the hex transform; it has +~ the task of hooking comment processing to detect a special comment syntax +~ which can be used by words that generate binary output, to define comments +~ which will appear as part of the hex-dump version of that output, but which +~ will be ignored in normal execution. +~ +~ This mechanism allows us, for example, to avoid putting detailed knowledge +~ of the amd64 Evocation-assembly instructions in the hex transform; instead +~ all the details are kept in one place, the authoritative implementations of +~ those instructions. This will substantially improve the maintainability of +~ the code, especially when adding new architectures. +~ +~ This word hex-tilde-alternate only applies to code that is running +~ directly within the hex transform. When an inner transform runs within the +~ hex transform, the inner transform is responsible for lexical processing, so +~ this word never gets invoked. There is an additional variant word +~ hex-*-tilde-alternate for each inner transform that the hex transform +~ supports, responsible for conducting the analogous task within the rules of +~ that inner transform. +: hex-tilde-alternate + ~ The original tilde is already an immediate word, so we can take over + ~ those responsibilities directly without needing to do any extra work to + ~ check the mode we're in or anything like that. + hex-read-magic-comment-introducer + ~ (body string pointer, result code) + + { + ~ It's a magic comment, which may or may not be empty. We want to either + ~ compile or execute a call to hex-tilde-replacement. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. + ~ + ~ Fortunately, we can pack the string directly into the output buffer, + ~ so we don't need to mess around with accumulate-string. + s" lit" find entry-to-execution-token , + has-non-space-this-input-line@ , + + s" litstring" find entry-to-execution-token , + here @ + swap packstring + 8 packalign + here ! + + ' hex-tilde-replacement entry-to-execution-token , + } { + ~ We're in interpret mode. + has-non-space-this-input-line@ swap + hex-tilde-replacement + } if-else + } { + ~ If it's a regular comment, we just ignore it. + drop + } if-else + + ~ Regardless of what path we took, we just consumed a newline, so make + ~ note of the fact. + 0 has-non-space-this-input-line! + ; make-immediate + + +~ This word runs whenever the label transform, running inside the hex +~ transform, encounters a tilde. It completely replaces the normal invocation +~ of tilde, just as hex-tilde-alternate does. It has the same responsibilities +~ around magic comments as hex-tilde-alternate, but for code which is +~ lexically processed by label-transform-one rather than by hex-transform-one. +~ +~ The actions it takes upon finding various sorts of comments differ from +~ hex-tilde-alternate, because the behavior of the label transform is +~ different from the behavior of the hex transform. +~ +~ This is installed by hex-label-word-replacement, bypassing the label +~ transform's normal precedence rules, so there's no need for it to be +~ immediate. +~ +~ Installing this word is the most significant change the hex transform +~ makes to the behavior of the label transform. +: hex-label-tilde-alternate + hex-read-magic-comment-introducer + ~ (body string pointer, result code) + + { + ~ It's a magic comment, which may or may not be empty. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. We ignore magic comments in compile mode, + ~ because they shouldn't become part of the program being compiled. + drop + } { + ~ We're in interpret mode. We run the magic comment immediately. + has-non-space-this-input-line@ swap + swap-transform-variables allocate-string swap-transform-variables + hex-tilde-replacement + } if-else + } { + ~ If it's a regular comment, we just ignore it. + drop + } if-else + + ~ Regardless of what path we took, we just consumed a newline, so make + ~ note of the fact. + 0 has-non-space-this-input-line! ; + + +~ This word runs whenever the log-load transform, running inside the hex +~ transform, encounters a tilde. It completely replaces the normal invocation +~ of tilde, just as hex-tilde-alternate does. It has the same responsibilities +~ around magic comments as hex-tilde-alternate, but for code which is +~ lexically processed by log-load-transform-one rather than by +~ hex-transform-one. +~ +~ The actions it takes upon finding various sorts of comments differ from +~ hex-tilde-alternate, because the behavior of the log-load transform is +~ different from the behavior of the hex transform. +~ +~ This is installed by hex-log-load-word-replacement, bypassing the log-load +~ transform's normal precedence rules, so there's no need for it to be +~ immediate. +~ +~ Installing this word is the most significant change the hex transform +~ makes to the behavior of the log-load transform. +: hex-log-load-tilde-alternate + hex-read-magic-comment-introducer + ~ (body string pointer, result code) + + { + ~ It's a magic comment, which may or may not be empty. + interpreter-flags @ 0x01 & { + ~ We're in compile mode. We ignore magic comments in compile mode, + ~ because they shouldn't become part of the program being compiled. + drop + } { + ~ We're in interpret mode. We run the magic comment immediately. + has-non-space-this-input-line@ swap + swap-transform-variables allocate-string swap-transform-variables + hex-tilde-replacement + } if-else + } { + ~ If it's a regular comment, we just ignore it. + drop + } if-else + + ~ Regardless of what path we took, we just consumed a newline, so make + ~ note of the fact. + 0 has-non-space-this-input-line! ; + + +~ This input helper is a very unusual thing: It's used by hex-transform-one, +~ hex-label-word-replacement, and hex-log-load-word-replacement to skip the +~ space between words. That's necessary because we need to keep track of +~ whether we've had any non-blank stuff on each line yet, so that the tilde +~ replacement can figure out certain cases where a magic comment needs to be a +~ suffix comment rather than a line comment. +: hex-skip-space + { peek dup is-space } + { consume + ~ This will set the flag once for each newline, if we have multiple + ~ consecutive ones or something like that, but that's harmless. + 0x0a = { 0 has-non-space-this-input-line! } if + } while drop ; + + + +~ This word is installed into label-transform-one by the hex-word-alternate, +~ when the label transform runs inside the hex transform. It has the job of +~ performing substantive changes to the label transform's behavior, as +~ required by the hex transform. +~ +~ The most important changes to the base language that this word makes are +~ to call hex-label-tilde-alternate any time a tilde is encountered as a word, +~ and to call hex-skip-space before reading a word. +~ +~ This word is also responsible for invoking hex-memory-slide-replacement +~ when memcopy or memmove are encountered in immediate mode. Note that this +~ really pushes right up against the limit of what it's possible for a +~ transform to do without altering the compilation's output; invoking the +~ replacement in compile mode would do so. +: hex-label-word-replacement + hex-skip-space + word + + value@ + dup s" ~" stringcmp 0 = { + ~ We won't be going back to label-transform-one; clear away its state. + drop dropstring + + hex-label-tilde-alternate + + ~ Return directly to label-transform, faking the "not done" return value + ~ from label-transform-one. + 0 + 2 nexit + } if + dup s" memcopy" stringcmp 0 = { + interpreter-flags @ 0x01 & not { + drop hex-memory-slide-replacement exit + ~ Fall through, returning control to label-transform-one. + } if + } if + dup s" memmove" stringcmp 0 = { + interpreter-flags @ 0x01 & not { + drop hex-memory-slide-replacement exit + ~ Fall through, returning control to label-transform-one. + } if + } if + drop ; + + +~ This word is installed into log-load-transform-one by the +~ hex-word-alternate, when the log-load transform runs inside the hex +~ transform. It has the job of performing substantive changes to the log-load +~ transform's behavior, as required by the hex transform. +~ +~ The most important changes to the base language that this word makes are +~ to call hex-log-load-tilde-alternate any time a tilde is encountered as a +~ word, and to call hex-skip-space before reading a word. +: hex-log-load-word-replacement + hex-skip-space + word + + value@ + dup s" ~" stringcmp 0 = { + ~ We won't be going back to log-load-transform-one; clear away its state. + drop dropstring + + hex-log-load-tilde-alternate + + ~ Return directly to log-load-transform, faking the "not done" return + ~ value from log-load-transform-one. + 0 + 2 nexit + } if + drop ; + + +~ Just as hex-allocate-alternate has the job of installing +~ hex-allocate-replacement in only one single spot, so hex-word-alternate has +~ the job of installing hex-label-word-replacement. It gets installed when +~ "word" is called from lexically within label-transform-one, and at no other +~ time. +~ +~ Notice how the job of each transform's inner bits can be thought of as +~ calling "word" and doing something with the result, with all the lexical +~ processing delegated to "word". This makes "word" a good place to install a +~ modification to the transform's behavior. +~ +~ Its structure is highly similar to that of hex-allocate-alternate. +: hex-word-alternate + interpreter-flags @ 0x01 & { + ~ Compile mode. + latest @ entry-to-name + + dup s" label-transform-one" stringcmp 0 = { + drop + ' hex-label-word-replacement entry-to-execution-token , + exit + } if + + dup s" log-load-transform-one" stringcmp 0 = { + drop + ' hex-log-load-word-replacement entry-to-execution-token , + exit + } if + + ~ Not in a word we install stuff into. + drop + s" word" find entry-to-execution-token , + } { + ~ Immediate mode. + s" word" find + dup { entry-to-execution-token execute } { drop allocate } if-else + } if-else ; make-immediate + + +~ This runs instead of "interpret" in code under the hex transform. The +~ proximate effect of that is to make "include" work. Note, however, that this +~ replacement only applies directly under the hex transform. It isn't a +~ sensible approach under the log-load transform at all, and under the label +~ transform it would have such strange behavior that it isn't a good idea +~ either. +: hex-interpret-replacement + ~ This is a forward reference, so we need to look it up. + s" hex-transform-one" + swap-transform-variables find swap-transform-variables + entry-to-execution-token execute + + ~ We ignore the EOF indication, on the assumption something else will + ~ detect it and return to the outer loop, the one that's ours. For example, + ~ look at "include", in language/dynamic/files.e. + drop ; + + +~ This installs hex-interpret-replacement, compiling it in compile mode and +~ executing it in immediate mode. +: hex-interpret-alternate + interpreter-flags @ 0x01 & { + ' hex-interpret-replacement entry-to-execution-token , + } { + hex-interpret-replacement + } if-else ; make-immediate + + +~ This implements the hex transform for a single word. It is directly +~ analogous to "interpret", and reading language/dynamic/interpret.e may help +~ in understanding it, though it's meant to still make sense on its own. +~ +~ The hex transform runs code immediately. Whereas most transforms alter +~ what the transformed code compiles into, the hex transform alters what it +~ outputs. It's assumed that the output is a binary file of some sort; the +~ binary is output as hexadecimal, interspersed with comments describing the +~ code that produced it, including descriptions of what was executed, along +~ with any comments from the original code. +~ +~ The hex transform's alternates take priority over words defined under +~ the transform when running immediately, but for compilation, words defined +~ under the transform take precedence. In the event that neither an alternate +~ nor an entry in the inner dictionary is found, the outer dictionary is +~ checked; otherwise it's irrelevant. +~ +~ The point of this precedence rule is that string literals, which require +~ special treatment, will be using the inner implementation by the time it +~ gets to actually generating an executable image. It's important that there +~ not be any alternates altering the generated code, only the program actually +~ being compiled. Other literal syntaxes, such as tick, don't have alternates +~ at all (the hex transform manages to be more parsimonious with alternates +~ than other transforms), and will always be using inner versions. +~ +~ The precedence rule does fail to have the desired effect for label +~ references. For these, the alternates take the unusual step of manually +~ calling the inner versions when they exist. +~ TODO think through whether the precedence rule is actually doing anything... +~ +~ It expects to be called from "hex-transform", below, which loops. +~ +~ (-- done) +: hex-transform-one + hex-skip-space + word + + ~ If no word was returned, end the transformation. + dup 0 = { drop 1 exit } if + + ~ The string is on the top of the stack, so to get a pointer to it we get + ~ the stack address. + ~ (string) + value@ + + ~ If it's anything but tilde, set the input state flag accordingly. + dup s" ~" stringcmp 0 != { 1 has-non-space-this-input-line! } if + + ~ Check whether it's one of the words we have alternates for, and look up + ~ the alternate if so. + 0 swap + ~ (name as stack string, placeholder, name pointer) + dup s" self-codeword" stringcmp 0 = { + swap drop ' hex-self-codeword-alternate swap } if + ~ It is nontrivial to construct a string with a double-quote in it. + dup ' s" entry-to-name stringcmp 0 = { + swap drop ' hex-string-alternate swap } if + dup ' ." entry-to-name stringcmp 0 = { + swap drop ' hex-dot-string-alternate swap } if + dup s" create" stringcmp 0 = { swap drop ' hex-create-alternate swap } if + dup s" :" stringcmp 0 = { swap drop ' hex-colon-alternate swap } if + dup s" ;" stringcmp 0 = { swap drop ' hex-semicolon-alternate swap } if + dup s" ;asm" stringcmp 0 = { + swap drop ' hex-semicolon-assembly-alternate swap } if + dup s" L@'" stringcmp 0 = { swap drop ' hex-L@'-alternate swap } if + dup s" L!'" stringcmp 0 = { swap drop ' hex-L!'-alternate swap } if + dup s" bye" stringcmp 0 = { swap drop ' hex-bye-alternate swap } if + dup s" allocate" stringcmp 0 = { + swap drop ' hex-allocate-alternate swap } if + dup s" memcopy" stringcmp 0 = { swap drop ' hex-memcopy-alternate swap } if + dup s" memmove" stringcmp 0 = { swap drop ' hex-memmove-alternate swap } if + dup s" word" stringcmp 0 = { swap drop ' hex-word-alternate swap } if + dup s" ~" stringcmp 0 = { swap drop ' hex-tilde-alternate swap } if + dup s" interpret" stringcmp 0 = { + swap drop ' hex-interpret-alternate swap } if + ~ (name as stack string, 0 or alternate entry pointer, name pointer) + + find + ~ (stack string, 0 or alternate entry pointer, 0 or inner entry pointer) + + interpreter-flags @ 0x01 & { + ~ We're in compile mode. An alternate immediate entry has the highest + ~ precedence; an inner entry of any kind has second-highest. + over { + ~ An alternate entry exists; check its flags. + over entry-flags@ 0x01 & { + ~ It's an immediate entry, so it has precedence, regardless of + ~ what's up with the inner entry. Execute it. + drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ The alternate is not immediate, so check if there's an inner entry. + dup { + ~ There is also an inner entry. Check its flags. + dup entry-flags@ 0x01 & { + ~ The inner entry is immediate, so it has precedence. Execute it. + swap drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ The inner entry is not immediate, so the alternate has + ~ precedence. Compile it. + ~ + ~ Watch this space closely for correctness issues, it's a rare + ~ codepath. + drop dropstring-with-result + entry-to-execution-token , + 0 exit + } if-else + } { + ~ There's no inner entry. Compile the alternate. + ~ + ~ This path, too, is rare and should get close scrutiny for + ~ correctness. + drop dropstring-with-result + entry-to-execution-token , + 0 exit + } if-else + } if-else + } { + ~ There is no alternate entry; check for an inner entry. + dup { + ~ An inner entry exists; check its flags. + dup entry-flags@ 0x01 & { + ~ It's an immediate entry. Execute it. + swap drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ It's not an immediate entry. Compile it. + swap drop dropstring-with-result + entry-to-execution-token , + 0 exit + } if-else + } if + ~ If we got here, there's no inner or alternate entry; fall through. + } if-else + } { + ~ We're in immediate mode. An alternate entry of any kind has precedence. + over { + ~ There's an alternate entry. Execute it. + drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } { + ~ There's no alternate entry. Check for an inner entry. + dup { + ~ An inner entry exists. Execute it. + swap drop dropstring-with-result + entry-to-execution-token execute + 0 exit + } if + ~ If we got here, there's no inner or alternate; fall through. + } if-else + } if-else + drop drop + ~ (stack string) + + ~ As a final fallback, we also check the outer dictionary, for immediate + ~ use only. This will allow things like assembly words to work. + value@ + swap-transform-variables + find + swap-transform-variables + dup { + ~ There's an outer entry; check the mode. + interpreter-flags @ 0x01 & { + ~ We're in compile mode; check the outer entry's flags. + dup entry-flags@ 0x01 & { + ~ It's an immediate word; execute it. + dropstring-with-result + entry-to-execution-token + execute + 0 exit + } { + ~ It's not an immediate word. Pretend it doesn't exist, and fall + ~ through. + drop + } if-else + } { + ~ We're in immediate mode. Execute the outer entry. + dropstring-with-result + entry-to-execution-token + execute + 0 exit + } if-else + } { + ~ There's no outer entry. Fall through. + drop + } if-else + ~ (stack string) + + ~ Check whether it's a number literal. + value@ read-integer 0 = { + ~ It's a number. + ~ + ~ (name as stack string, integer value) + dropstring-with-result + ~ (integer value) + + interpreter-flags @ 0x01 & { + ~ TODO this probably needs a lit alternate (!) + ' lit entry-to-execution-token , , + 0 exit + } if + + 0 exit + } if + ~ (stack string) + + ." No such word: " value@ emitstring newline dropstring 0 ; + + +~ This implements the hex transform for all words in a region given as +~ an input string. It is directly analogous to "quit", in +~ language/dynamic/interpret.e, but is more complex. +~ +~ (output metadata buffer start, output buffer start, output point, +~ input string pointer -- output buffer start, output point) +: hex-transform + main-input-buffer dup push-input-buffer + swap attach-string-to-input-buffer + ~ (output metadata buffer start, output buffer start, output point) + + ~ Save the old values of "here" and "latest", and set the initial values + ~ of the internal ones. These values need to persist across iterations, + ~ since client code will make its own updates to them and then rely on those + ~ updates having taken effect. So we do the swap just once, here outside the + ~ loop, and set it back when the loop ends. + ~ + ~ We also take this opportunity to initialize the other fields of + ~ transformation-state. While it might be nice to do these in some sort of + ~ logical order, it gets unreadable quickly, so we initialize them in the + ~ most convenient order given how we received our parameters. + here @ transformation-state transformation-state-saved-here ! + latest @ transformation-state transformation-state-saved-latest ! + here ! + 0 latest ! + transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + transformation-state transformation-state-output-metadata ! + ~ Now the stack has nothing of ours on it, so client code can do its thing. + + ~ We don't have the real values yet, so we can't create the initial + ~ entries in the output metadata, but we can and should zero it out to make + ~ sure everything else operating on it finds it well-formed. + zero-hex-output-metadata + + ~ The code under the hex transform never gets a real copy of warm-start, + ~ so it doesn't have the globals "here" and so on. It wants to have the + ~ globals, but it can't, not without our help. Why aren't we helping? + ~ + ~ Oh, right, we're helping right here. We just write them into the inner + ~ log and dictionary directly, by using our outer copy of "variable". These + ~ definitions don't have to do anything special; we point them to the same + ~ addresses as the outer ones. Note though that the actual values the + ~ transformed code sees sees are the wrapped, inner ones, since we swapped + ~ the values out elsewhere. + ~ + ~ If we provided these as alternates instead, that would work for code + ~ that doesn't have a nested transform, but the inner transforms want to be + ~ able to look them up by name. + swap-transform-variables log swap-transform-variables s" log" variable + swap-transform-variables s0 swap-transform-variables s" s0" variable + swap-transform-variables r0 swap-transform-variables s" r0" variable + swap-transform-variables latest swap-transform-variables s" latest" variable + swap-transform-variables here swap-transform-variables s" here" variable + + ~ It's important that the stack has nothing of ours on it that persists + ~ across iterations, so that client code can add and remove stuff there as + ~ it sees fit. + { hex-transform-one + ~ (done) + + ~ When the loop is done, get the real values of "here" and "latest" + ~ back. The internal "here" is also the output point, and will become our + ~ return value. The internal "latest" is discarded. + { transformation-state transformation-state-output-buffer-start @ + here @ + transformation-state transformation-state-saved-here @ here ! + transformation-state transformation-state-saved-latest @ latest ! + ~ (output point) + + ~ Though we don't actually use transformation-state outside of this + ~ invocation, for tidiness we zero it out. + 0 transformation-state transformation-state-saved-here ! + 0 transformation-state transformation-state-saved-latest ! + 0 transformation-state transformation-state-output-buffer-start ! + 0 transformation-state transformation-state-user-stack-depth ! + + ~ Also put the input source back how it was. + main-input-buffer pop-input-buffer + + exit } if } forever ; + diff --git a/core.e b/core.e deleted file mode 100644 index 19f851f..0000000 --- a/core.e +++ /dev/null @@ -1,1370 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Core Forth features ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ This file provides extremely fundamental functionality which is a -~ necessary component of any Forth dialect, including Evocation. It is -~ included statically as part of any generated executable, and a second copy -~ of it is later copied into the log when that executable runs. Therefore, it -~ is written to obey the constraints of both the label transform, and the -~ log-load transform; see transform.e for more details on that. - - -~ Execution support -~ ~~~~~~~~~~~~~~~~~ -~ -~ There's two words, docol and exit, which are essential parts of the -~ indirect-threaded execution model. It would be tempting to put them in -~ execution.e, so they'd be closer to the explanation of what they do, but -~ we need two copies of them (just like we do of every other word in this -~ file), one statically compiled and one in the log. So, they're here, because -~ that's significantly simpler, even though it creates a little bit of extra -~ work for the label transform. - - -~ Docol is the "interpreter" that is responsible for the semantics of words -~ written as Forth high-level code. The name is said to be short for -~ "do colon", because word definitions begin with a colon. -~ -~ Concretely, when interpreting, it saves rsi (the "instruction pointer") to -~ the control stack, takes the address of the codeword from rax and increments -~ it in-place to form the new instruction pointer, and copies that to rsi. -~ -~ Having then done this, we're now in the state that normal execution -~ expects, so docol ends by it using "next" to begin the callee's execution, -~ kicking off a nested call. -~ -~ At runtime, invoke docol directly and it will return the value that should -~ be used as a codeword. When compiling to a binary executable, the -~ transformation facility needs to reference it directly, and for that -~ purpose, the label "docol-codeword-value" points to the correct place. -~ -~ Registers in: -~ -~ * rsi is the caller's instruction pointer -~ * rbp is the control stack pointer -~ * rax is the address of the callee's codeword -~ -~ Registers out: -~ -~ * rsi is the callee's instruction pointer -~ * rbp is the control stack pointer - -~ We need this one snippet of assembly code that's just on the log raw, -~ without a word header, because of its role in making words work. We define -~ a label pointing to it. -~ -~ This is the only use of labels in core.e. There's no easy way to -~ remove it. We can't use immediate computation based on "here" because -~ the label transform uses the host address space, not the target address -~ space. The transformation facility's support for labels in transformed -~ code was added just for this. -~ -~ It may seem as if we could have used some extra space in the middle of -~ the proper docol word, which is defined just below. That would work fine -~ with the label transform, which can do forward references, but the log-load -~ transform's label support is special-cased to ONLY do this, and it will only -~ work with a backward reference. -~ -~ We begin by outputting the actual docol routine, the one that codewords -~ should point to. Note that this is before we've done any word header. -~ -~ : This is the actual docol routine, the interpreter which is pointed to by -~ : the codeword of every interpreted word. It does not itself have an entry -~ : in the dictionary; the word "docol" will return a pointer to this routine. -~ : The word's entry follows immediately after the routine. -~ : indent -here @ -dup L!' docol-codeword-value -:rsi pack-pushcontrol -8 :rax add-reg64-imm8 -:rax :rsi mov-reg64-reg64 -pack-next -8 packalign -here ! -~ : deindent - -~ We can't use colon to create docol, not even the part that's a word, -~ because colon tries to dynamically invoke docol to fill in the codeword. -~ : blank-line -~ : This is the dictionary entry for docol. -~ : indent -s" docol" create -self-codeword -here @ -L@' docol-codeword-value :rax mov-reg64-imm64 -:rax push-reg64 -pack-next -8 packalign -here ! -~ : deindent -~ Now that we have docol, colon will work and we can define words the normal -~ way. - -~ This is the mechanism to "return" from a word interpreted by docol. -~ We pop the control stack, and then, since this is threaded execution, we -~ do the next thing the caller wants to do, by inlining "next". -: exit - [ here @ - :rsi pack-popcontrol - here ! ] ;asm - -~ Now that we have exit, semicolon will also work and we can define -~ non-assembly words. However, it will be hard to make them do much until we -~ have lit as well. There's no special hurry; most of the words in core.e are -~ assembly words. We'll get to it further down. - - -~ Stack manipulation routines -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ We start with the three traditional stack operations, swap drop and -~ roll. Sorry to fans of the name "ROT"; we were an HP calculator kid. It'll -~ always be roll to us. Anyway, we do a couple other operations too. Since -~ our goal right now is just to bootstrap the heap, we keep this short and -~ sweet. -~ -~ This code has been written to satisfy the assumptions needed by the label -~ transform, described in-depth in transform.e. This means that it is, in -~ effect, written in a restricted dialect of Evocation rather than in the full -~ language. -~ -~ There is definitely plenty of optimization that could be done. - -: swap - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rax push-reg64 - :rbx push-reg64 - here ! ] ;asm - -: drop - [ here @ - :rax pop-reg64 - here ! ] ;asm - -: 2drop - [ here @ - :rax pop-reg64 - :rax pop-reg64 - here ! ] ;asm - -~ Rotates "up" (pops its parameter, n; nth item then becomes current item). -~ -~ We implement this the high-performance way, with rep movsq, aka the -~ instruction that exists to optimize C's memcpy(). The details of setting -~ that up are complex; see below. -: roll - [ here @ - - ~ Pop our parameter. The rep instruction takes rcx as its count, so we - ~ reduce copying by using it to hold our count, as well. - :rcx pop-reg64 - - ~ We have n - 1 items to slide, so decrement rcx. For the purpose of - ~ counting how many repetitions will happen, it's one-based. This is because - ~ the rep instruction performs a single movsq, then decrements rcx, then - ~ stops if rcx is zero. - :rcx dec-reg64 - - ~ Retrieve the nth item, for later. For this purpose we're thinking in - ~ zero-based terms, so we do this after already having decremented rcx. - :rsp :rcx 8 :rbx mov-reg64-indexed-reg64 - - ~ The source address for movsq is rsi and the destination is rdi; we can - ~ use rdi as we wish, but rsi is our Forth "instruction pointer", so we must - ~ save and restore it. Doing so alters rsp, so we have to adjust the address - ~ calculations by eight bytes as compared to the expressions above, but - ~ happily we can use the disp8 field to do that. We'd be using disp8 anyway - ~ because it's helpful. - :rsi push-reg64 - - ~ Now we set up parameters for the memory-sliding operation. We have - ~ n - 1 items to copy, moving the range rsp through rsp + (n-2)*8 onto the - ~ range rsp + 8 through rsp + (n-1)*8. That's with the value of rsp as it - ~ exists at this moment (it's going to change soon). - ~ - ~ We're sliding them upwards in memory, so we start at the high end so - ~ that we're always moving into a location that doesn't have anything - ~ precious. We use lea as a convenient way to do the stack math. - ~ - ~ When rcx is 1, we want rsp + 8. - :rsp :rcx 8 :rsi lea-reg64-indexed-reg64 - ~ When rcx is 1, we want rsp + 16. - :rsp :rcx 8 8 :rdi lea-reg64-disp8-indexed-reg64 - ~ - ~ Using rcx = 1 is the most convenient example to use for figuring out the - ~ arithmetic. It's a linear relationship, so as long as we get the 8-byte - ~ stride correct, we just need to pick a single point and verify that our - ~ math is right for that point, and it'll be right for any value of rcx. - - ~ Another of our Forth conventions is that the DF flag should be kept at - ~ zero, which directs string instruction to increment rsi. Here, however, - ~ because our source and destination ranges overlap, we need to start at the - ~ high end, which means we need it to decrement. So we set DF to one, and - ~ we'll clear it after. - std - rep-movs64 - - ~ Set everything back. - cld - :rsi pop-reg64 - - ~ There is now an extra item at the low end of the stack (the top) that - ~ needs to go away, and coincidentally we have a value in rbx that needs to - ~ be in that spot. Rather than doing a drop and push, we overwrite it, to - ~ save a little work. - :rbx :rsp mov-indirect-reg64-reg64 - - ~ All done, wow! What a mouthful. - here ! ] ;asm - -~ Rotates "down" (pops its parameter, n; current item then becomes nth -~ item). -~ -~ Jonesforth calls this "-roll" and we could do that, but honestly the name -~ unroll sounds nicer and it's only a single character longer. You might say -~ it rolls off the tongue better. -~ -~ We implement this the high-performance way, with rep movsq, aka the -~ instruction that exists to optimize C's memcpy(). The details of setting -~ that up are complex; see below. -: unroll - [ here @ - - ~ Pop our parameter. The rep instruction takes rcx as its count, so we - ~ reduce copying by using it to hold our count, as well. - :rcx pop-reg64 - - ~ We have n - 1 items to slide, so decrement rcx. Also, save a copy of it in - ~ rdx after doing that, for later. - :rcx dec-reg64 - :rcx :rdx mov-reg64-reg64 - - ~ Retrieve the 0th item, for later. - :rsp :rbx mov-reg64-indirect-reg64 - - ~ Now we set up parameters for the memory-sliding operation. We have - ~ n - 1 items to copy, moving the range rsp + 8 through rsp + (n-1)*8 onto - ~ the range rsp through rsp + (n-2)*8. That's with the value of rsp as it - ~ exists at this moment (it's going to change soon). - ~ - ~ We're sliding them downwards in memory, so we start at the low end so - ~ that we're always moving into a location that doesn't have anything - ~ precious. We use lea as a convenient way to do the stack math. - ~ - ~ As with roll, we need to save rsi and adjust those rsp calculations - ~ accordingly. - :rsi push-reg64 - - ~ Regardless of rcx, we want rsp + 16. - :rsp 16 :rsi lea-reg64-disp8-reg64 - ~ Regardless of rcx, we want rsp + 8. - :rsp 8 :rdi lea-reg64-disp8-reg64 - - ~ With roll, we were starting at the high end. Here, we start at the low - ~ end, which means we need rsi to increment after each repetition. That's - ~ what it does when the DF flag is clear, and another of our Forth - ~ conventions is to keep it clear normally. So, we don't have to touch DF! - ~ Yay! - rep-movs64 - - ~ Restore our original rsi. - :rsi pop-reg64 - - ~ There is now an extra item in the middle of the stack, at the high end of - ~ the sliding we did, that needs to be overwritten with our value in rbx. - ~ Since we destructively updated our count in rcx, we saved a copy of the - ~ count in rdx, and we use that to find the right address. - ~ - ~ When the original count was n, we want rsp + (n-1)*8, so we saved rdx - ~ after decrementing rcx, above. - :rbx :rsp :rdx 8 mov-indexed-reg64-reg64 - - ~ All done, wow! What a mouthful. - here ! ] ;asm - -~ Rotates "up" (third item becomes current item) -: 3roll - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rcx pop-reg64 - :rbx push-reg64 - :rax push-reg64 - :rcx push-reg64 - here ! ] ;asm - -~ Rotates "down" (current item becomes third item) -: 3unroll - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rcx pop-reg64 - :rax push-reg64 - :rcx push-reg64 - :rbx push-reg64 - here ! ] ;asm - -: dup - [ here @ - :rax pop-reg64 - :rax push-reg64 - :rax push-reg64 - here ! ] ;asm - -: 2dup - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx push-reg64 - :rax push-reg64 - :rbx push-reg64 - :rax push-reg64 - here ! ] ;asm - - -~ Arithmetic routines -~ ~~~~~~~~~~~~~~~~~~~ -~ -~ No surprises here. Again, since our goal is to bootstrap the heap, we -~ keep it short. Also again, this is nowhere near optimal. - -: + - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rbx :rax add-reg64-reg64 - :rax push-reg64 - here ! ] ;asm - -: - - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rbx :rax sub-reg64-reg64 - :rax push-reg64 - here ! ] ;asm - -: * - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx mul-reg64 - :rax push-reg64 - here ! ] ;asm - -~ Jonesforth calls this "/mod" but % is widely recognized and has no special -~ Forth significance. -: /% - [ here @ - :rdx :rdx xor-reg64-reg64 ~ rdx is the high bits of the input; zero it - :rbx pop-reg64 - :rax pop-reg64 - :rbx divmod-reg64 - :rdx push-reg64 ~ remainder - :rax push-reg64 ~ quotient - here ! ] ;asm - -~ We define a pair of words that increment and decrement a single item. -~ These were inspired by Common Lisp, where they're constantly useful. -: 1+ - [ here @ - :rax pop-reg64 - :rax inc-reg64 - :rax push-reg64 - here ! ] ;asm - -: 1- - [ here @ - :rax pop-reg64 - :rax dec-reg64 - :rax push-reg64 - here ! ] ;asm - - -~ Comparison routines -~ ~~~~~~~~~~~~~~~~~~~ -~ -~ So. This is subtle. These comparison routines all have the same structure. -~ Notice that = and != are commutative, whereas the others are not, so -~ consider > as the archetypical one when reasoning about correctness. To -~ test if A > B, we do cmp A, B, which sets the flags the same way as -~ subtracting B from A does. The mnemonic names of the condition codes are -~ based on the assumption you do it in this order. -~ -~ We want to treat the top of the stack as the first operand, so we -~ carefully pop in the appropriate order. -~ -~ There are both signed and unsigned variants of the condition codes. We -~ provide both; the unmarked comparisons such as > and <= are signed, while -~ the marked ones such as >unsigned and <=unsigned are of course unsigned. - -~ Jonesforth calls this "="; most languages would call it "==". -: = - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-equal :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Jonesforth calls this "<>", but even most modern SQL dialects recognize -~ C's legacy and allow "!=" these days. As someone who learned C in childhood, -~ this is not actually a hard call for us. -: != - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-not-equal :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack greater than the second item in the stack, when -~ both are treated as signed? -: > - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-greater :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack less than the second item in the stack, when both -~ are treated as signed? -: < - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-less :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack greater than or equal to the second item in the -~ stack, when both are treated as signed? -: >= - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-greater-equal :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack less than or equal to the second item in the -~ stack, when both are treated as signed? -: <= - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-less-equal :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack greater than the second item in the stack, when -~ both are treated as unsigned? -: >unsigned - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-above :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack less than the second item in the stack, when -~ both are treated as unsigned? -: =unsigned - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-above-equal :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - -~ Is the top of the stack less than or equal to the second item in the -~ stack, when both are treated as unsigned? -: <=unsigned - [ here @ - :rax pop-reg64 - :rbx pop-reg64 - :rbx :rax cmp-reg64-reg64 - :cc-below-equal :al set-reg8-cc - 0x01 :rax and-reg64-imm8 - :rax push-reg64 - here ! ] ;asm - - -~ Bitwise routines -~ ~~~~~~~~~~~~~~~~ -~ - -: & - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rbx :rax and-reg64-reg64 - :rax push-reg64 - here ! ] ;asm - -: | - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rbx :rax or-reg64-reg64 - :rax push-reg64 - here ! ] ;asm - -: xor - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rbx :rax xor-reg64-reg64 - :rax push-reg64 - here ! ] ;asm - -~ The HP overloads the name "not", so we follow the Forth convention. -: invert - [ here @ - :rax pop-reg64 - :rax not-reg64 - :rax push-reg64 - here ! ] ;asm - - -~ Literal routines -~ ~~~~~~~~~~~~~~~~ -~ -~ These words are rarely used directly from user code, but are emitted by -~ the interpreter, in compile mode. They allow literal values of various kinds -~ to exist inline as part of compiled code, which would otherwise be only an -~ array of codeword pointers. They do this, in their various ways, by pushing -~ any appropriate value on the stack and making sure execution skips over the -~ bytes used to represent it. - -: lit - [ here @ - lods64 - :rax push-reg64 - here ! ] ;asm - -: litstring - [ here @ - ~ The string immediately follows the codeword in memory, so rsi is - ~ already pointing to it. That address will be our returned result, so we - ~ push it to the stack. - :rsi push-reg64 - - ~ Now we need to skip over the string, so that rsi will be valid for the - ~ next Forth word. To do that, we're going to do a string operation with - ~ scas8, which takes rdi as the address to look at. This means scas8 is - ~ treating its operand as analogous to the destination operand of movs*. - :rsi :rdi mov-reg64-reg64 - ~ We want to compare for equality with zero; scas8 looks in al for the - ~ other half of the comparison, so we clear rax. - :rax :rax xor-reg64-reg64 - ~ Counterintuitively, we do need to pass a count. We pass -1, which will - ~ always work. - :rcx :rcx xor-reg64-reg64 - :rcx not-reg64 - ~ The DF flag is zero per our Forth execution-model convention, which - ~ means scas8 increments rdi after each iteration. This is what we want, - ~ so there's no need to mess with it. - ~ - ~ We also need to worry about ZF, but fortunately that "not" will make - ~ sure it's clear. - ~ - ~ So, we're ready; do it! - repnz-scas8 - ~ The scas8 completes, incrementing rdi, before the repnz checks its - ~ condition. So, rdi is now pointing immediately after the terminating - ~ null byte. Of course, we want this in rsi for Forth's purposes. - :rdi :rsi mov-reg64-reg64 - - ~ Finally, we need to align rsi to the next word boundary. - 7 :rsi add-reg64-imm8 - 7 invert :rsi and-reg64-imm8 - - here ! ] ;asm - - -~ Memory access routines -~ ~~~~~~~~~~~~~~~~~~~~~~ -~ -~ We go with Forth names for this stuff. The HP's names for memory and -~ storage operations heavily leverage the fact they have an object system -~ with type tags and so on; we want to stay close to the bytes. - -~ (value, address --) -: ! - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rax :rbx mov-indirect-reg64-reg64 - here ! ] ;asm - -~ (address -- value) -: @ - [ here @ - :rax pop-reg64 - :rax :rax mov-reg64-indirect-reg64 - :rax push-reg64 - here ! ] ;asm - -~ This follows the general convention that words that set things take the -~ destination as the final parameter. -~ -~ (value, address --) -: +! - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rax :rbx add-indirect-reg64-reg64 - here ! ] ;asm - -~ (value, address --) -: -! - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :rax :rbx sub-indirect-reg64-reg64 - here ! ] ;asm - -~ Jonesforth calls this "c!" but we categorically reject the use of letters -~ that are meant to indicate byte sizes. It's unfriendly to newcomers. There's -~ some risk that this name will be confused for meaning "store a value of 8", -~ but that would not be a useful task, so hopefully it'll be okay. -: 8! - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :al :rbx mov-indirect-reg64-reg8 - here ! ] ;asm - -: 8@ - [ here @ - :rbx pop-reg64 - :rax :rax xor-reg64-reg64 - :rbx :al mov-reg8-indirect-reg64 - :rax push-reg64 - here ! ] ;asm - -: 16! - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :ax :rbx mov-indirect-reg64-reg16 - here ! ] ;asm - -: 16@ - [ here @ - :rbx pop-reg64 - :rax :rax xor-reg64-reg64 - :rbx :ax mov-reg16-indirect-reg64 - :rax push-reg64 - here ! ] ;asm - -: 32! - [ here @ - :rbx pop-reg64 - :rax pop-reg64 - :eax :rbx mov-indirect-reg64-reg32 - here ! ] ;asm - -: 32@ - [ here @ - :rbx pop-reg64 - :rax :rax xor-reg64-reg64 - :rbx :eax mov-reg32-indirect-reg64 - :rax push-reg64 - here ! ] ;asm - -~ Before we get too deep into it, we also define a few reflection routines -~ that retrieve, or set, the address of either of the two stacks. -~ -~ The result, or the new value, is on the top of the data stack. That's the -~ same as how it works for any other word, but given the metacircular nature -~ of these ones it's easy to get confused about that... -~ -~ Jonesforth calls this RSP!, which looks as if it's meant to be an Intel -~ register name but is actually short for return stack pointer. There is no -~ register by that name, it's a Forth-provided abstraction. That's super -~ confusing, plus as discussed above we call it the control stack not the -~ return stack, so we call the words... -~ -~ (stack pointer --) -: control! - [ here @ - :rbp pop-reg64 - here ! ] ;asm - -~ (-- stack pointer) -: control@ - [ here @ - :rbp push-reg64 - here ! ] ;asm - -~ Jonesforth calls this DSP!, for data stack pointer. Again, there's no -~ Intel register by that name, and we call it the value stack, so... -~ -~ (stack pointer --) -: value! - [ here @ - ~ Per Intel's description of POP this reads from the old location, and - ~ there is no increment applied to the resulting value. See, the - ~ description says it increments the register then overwrites it, in that - ~ order. - :rsp pop-reg64 - here ! ] ;asm - -~ (-- stack pointer) -: value@ - [ here @ - ~ Per Intel's description of PUSH this pushes the old value. - :rsp push-reg64 - here ! ] ;asm - -~ Copy one non-overlapping block of memory over another. For the overlapping -~ logic, see roll and unroll. This always copies at byte granularity, for ease -~ of implementation. -~ -~ Jonesforth calls this CMOVE and has a CCOPY which is a single byte. POSIX, -~ however, has memcpy() for non-overlapping blocks and memmove() for -~ overlapping blocks. We follow the latter convention, because it feels like -~ the more important distinction. -~ -~ Also, the "c" was meant to indicate that it works at one-byte granularity, -~ but that isn't, uh... actually an important property here, and as a blanket -~ call we're not using letters to denote data sizes. So we call it "memcopy". -~ Apologies to the C programming tradition but vowels are good, actually. -~ -~ Jonesforth also offers C@C! as another name for its CCOPY, but neither -~ "@!" nor "mem@mem!" seems particularly nice. -~ -~ (source, destination, length --) -: memcopy - [ here @ - ~ We need to save and restore rsi; the other registers we can trample. - :rsi :rdx mov-reg64-reg64 - :rcx pop-reg64 - :rdi pop-reg64 - :rsi pop-reg64 - ~ We start from the low end, since that's easier arithmetic. So, we get - ~ to leave the DF flag alone. - rep-movs8 - :rdx :rsi mov-reg64-reg64 - here ! ] ;asm - -~ This does the same thing as memcopy, but correctly handles situations -~ where the destination overlaps with the source. It achieves this by being -~ careful about which end the transfer starts from. This "move" vs. "copy" -~ distinction mirrors C terminology. -~ -~ (source, destination, length --) -: memmove - [ here @ - ~ We need to save and restore rsi; the other registers we can trample. - :rsi :rdx mov-reg64-reg64 - :rcx pop-reg64 - :rdi pop-reg64 - :rsi pop-reg64 - - ~ We need to check source < destination to decide which end to start from. - :rsi :rax mov-reg64-reg64 - :rdi :rax cmp-reg64-reg64 - ~ Relative offsets are from the start of the instruction after the jmp. - 4 :cc-below jmp-cc-rel-imm8 - - ~ If source is greater, we are sliding downwards so we start from the low - ~ end. So, we get to leave the DF flag alone. - rep-movs8 ~ 2 bytes - 16 jmp-rel-imm8 ~ 2 bytes - - ~ If destination is greater, we are sliding upwards so we start from the - ~ high end. So, we have to save and restore DF. Also, we have to adjust the - ~ pointers. - :rcx :rsi add-reg64-reg64 ~ 3 bytes - :rsi dec-reg64 ~ 3 bytes - :rcx :rdi add-reg64-reg64 ~ 3 bytes - :rdi dec-reg64 ~ 3 bytes - std ~ 1 byte - rep-movs8 ~ 2 bytes - cld ~ 1 byte - - :rdx :rsi mov-reg64-reg64 - here ! ] ;asm - - -~ (string pointer -- string length not including null byte) -: stringlen - [ here @ - :rdi pop-reg64 - :rdi :rbx mov-reg64-reg64 - :rax :rax xor-reg64-reg64 - :rcx :rcx xor-reg64-reg64 - :rcx not-reg64 - repnz-scas8 - :rbx :rdi sub-reg64-reg64 - 1 :rdi sub-reg64-imm8 - :rdi push-reg64 - here ! ] ;asm - -~ This word is for working with strings that are null-terminated at both -~ ends. It counts backwards from the end to find the string length. It accepts -~ an input pointer to the final non-null byte at the end of the string, and -~ returns the length not including either null byte. -~ -~ (string end pointer -- string length not including null) -: reverse-stringlen - [ here @ - :rdi pop-reg64 - - :rdi :rbx mov-reg64-reg64 - :rax :rax xor-reg64-reg64 - :rcx :rcx xor-reg64-reg64 - :rcx not-reg64 - - std - repnz-scas8 - cld - - :rdi :rbx sub-reg64-reg64 - 1 :rbx sub-reg64-imm8 - - :rbx push-reg64 - here ! ] ;asm - - -~ If you have a variable-length string followed by alignment padding, and -~ you want to traverse it in reverse, you also need to skip the alignment -~ padding... -~ -~ The alignment padding can have a total length of no more than 8 bytes. The -~ returned value counts from the end, backwards, to the nearest non-null byte, -~ or at most a distance of eight. -~ -~ (address of final null byte in padding -- count of null bytes in padding) -: reverse-padding-len - [ here @ - :rdi pop-reg64 - - :rdi :rbx mov-reg64-reg64 - :rax :rax xor-reg64-reg64 - 9 :rcx mov-reg64-imm32 - - std - repz-scas8 - cld - - :rdi :rbx sub-reg64-reg64 - 1 :rbx sub-reg64-imm8 - - :rbx push-reg64 - here ! ] ;asm - - -~ We make this work using exactly two jump instructions, which is likely the -~ minimum possible. To avoid relying on labels, we hand-compute the byte -~ offsets, so every instruction within their ranges is annotated with its -~ length in bytes. Good fun. -~ -~ The returned comparsion value is 0 for equal, 1 to indicate the left -~ string (lower on the stack) is greater, and -1 to indicate the right string -~ (top of the stack) is greater. -~ -~ (left string pointer, right string pointer -- comparison value) -: stringcmp - [ here @ - ~ Save the rsi register. - ~ - ~ Happily, we don't need a lot of registers for this code, so we can - ~ dedicate rdx to this and not have to deal with stack juggling.. - :rsi :rdx mov-reg64-reg64 - - ~ Get the parameters off the stack. - ~ - ~ For reasons that will be explained below, the left and right strings - ~ from our caller's perspective are swapped from the perspective of the - ~ comparisons we'll be doing. The rdi register points to the right-hand - ~ operand of the "cmps" instruction, while rsi points to the left-hand - ~ operand; [Intel] volume 2A, chapter 3, section 4-3.3, "CMPS"; note that - ~ the PDF mis-numbers the sections in the second half of chapter 3. - :rsi pop-reg64 - :rdi pop-reg64 - - ~ For the comparison-unequal loop-exit code, we'll need rbx set to zero. - ~ The easy way to do that is by xor'ing it with itself, but doing it at - ~ the end of the loop would overwrite the comparison flags, which we need. - ~ So we do it in advance, and carefully don't touch it anywhere else. - ~ - ~ See the list of which instructions affect the flags in [Intel] - ~ volume 1, appendix A, section A-1, table A-2. - :rbx :rbx xor-reg64-reg64 - - ~ We also clear rax; we'll be using al later, and it will be convenient - ~ to know the upper bits are always zero. - :rax :rax xor-reg64-reg64 - - ~ Now we've initialized everything we need; everything after this point is - ~ part of the loop. - - ~ At the start of each iteration, save a copy of the byte we're at now. - ~ We need to do this before cmps because the pointers will increment; - ~ we'll eventually use it to test whether we've reached the end delimiter. - ~ - ~ We do a 64-bit load into rcx, which is otherwise unused, then copy the - ~ low byte from cl to al. This avoids having to think about addressing - ~ modes that combine 64-bit addresses with smaller data sizes; those are - ~ very subtle. - :rsi :rcx mov-reg64-indirect-reg64 ~ 3 bytes - :cl :al mov-reg8-reg8 ~ 2 bytes - - ~ Now do the cmps, which is the heart of the loop. - ~ - ~ Note that, in addition to relying on this comparison to test content - ~ bytes against each other, in the event that one string is a prefix of - ~ the other, this will also test content bytes against null delimiters. - ~ The longer string will compare as "greater", because zero is less than - ~ all other possible byte values. This is what we want. - ~ - ~ Since strings of different lengths are necessarily unequal, letting - ~ this test do the work of detecting that also means we don't have to deal - ~ with scenarios where we're past the end of one string but not the other. - cmps8 ~ 1 byte - - ~ The flags are now set based on the simulated subtraction of the next - ~ bytes from the two strings. If they were unequal, the loop will end. If - ~ they were equal, we have another test to do before we're finished with - ~ this iteration. So we put the loop-end code next, and conditionally jump - ~ forward past it. - ~ - ~ Recall that relative offsets are from the start of the instruction after - ~ the jmp. - 15 :cc-equal jmp-cc-rel-imm8 ~ 2 bytes - - ~ If we got here, the strings are unequal, so we need to turn the flags - ~ into a comparison value. We cleared rbx earlier; now we set its low bit - ~ to the "above" flag, then use sbb to subtract the "carry" flag (which it - ~ thinks of as the "borrow" flag). - ~ - ~ Recall that "carry" is based on whether the comparison would cause a - ~ change to the next bit "outside" the bits being compared; [Intel] - ~ volume 1, chapter 3, section 3-4.3.1. Since the comparison is a - ~ subtraction, "carry" is true when the right-hand byte is strictly - ~ greater than the left-hand byte. - ~ - ~ Also recall that "zero", also called "equal", is based on whether the - ~ comparison's result produces output that's all zero bits. Since the - ~ comparison is a subtraction, "zero" is true when the two bytes are - ~ identical. - ~ - ~ The "above" condition is not a flag, but a composite of flags. It's - ~ true when both "carry" and "zero" are false; [Intel] volume 1, chapter - ~ 7, section 7-3.1.1, table 7-2. For us, this is equivalent to saying the - ~ left-hand byte is strictly greater than the right-hand. - ~ - ~ So, after the "set" instruction, rbx is 1 if left > right, and 0 if - ~ left = right or left < right. The "sbb" instruction with an immediate - ~ value of zero subtracts the value of the carry flag from rbx; the flag - ~ is true in the case where left < right, and false otherwise. So, after - ~ the "sbb", rbx is 1 if left > right, 0 if left = right, and -1 if - ~ left < right. - ~ - ~ This sounds like the opposite of what we want, but recall that we - ~ exchanged the operands, so these are the values our caller is expecting. - ~ While it might be tempting to look for a way to not need that - ~ transposition, and indeed there exists an approach using "not above", - ~ it's fiddly in a way that's even harder to explain. - ~ - ~ Note that it's important that the "jmp" and "set" instructions don't - ~ change the flags (see table A-2 again), so the "cmps" is the most recent - ~ thing that did. The "sbb" instruction does change them, but we don't - ~ need them again after that point so it doesn't matter. - ~ - ~ Finally, we need to restore rsi before we return to Forth. - ~ - ~ The two-instruction set-sbb sequence is one of those classic assembly - ~ programming tricks that often goes unexplained, because most of its - ~ appeal is its brevity and a proper explanation is quite lengthy. Please - ~ enjoy this gift of knowledge, and thanks to our friends who showed it to - ~ us. - :cc-above :bl set-reg8-cc ~ 3 bytes - 0 :rbx sbb-reg64-imm8 ~ 4 bytes - :rbx push-reg64 ~ 1 byte - :rdx :rsi mov-reg64-reg64 ~ 3 bytes - pack-next ~ 4 bytes - - ~ If we got here, the current bytes are equal to each other. We still - ~ need to test if they're null terminators; if so, we exit, and if not, we - ~ loop. - ~ - ~ At the beginning of this iteration, we saved a copy of the byte being - ~ inspected in rax. The "test" instruction simulates a xor and sets the - ~ flags accordingly. We check the "not equal" condition, also known as - ~ "not zero", and jump backwards to the start of the loop when that's the - ~ case. - ~ - ~ Recall that relative offsets are from the start of the instruction - ~ after the jmp. - :rax :rax test-reg64-reg64 ~ 3 bytes - -28 :cc-not-equal jmp-cc-rel-imm8 ~ 2 bytes - - ~ If we got here, we got all the way to the end of both strings and - ~ found a null byte, so we return 0 to indicate they're equal. - ~ - ~ We can use push-imm32-extended64 even though our stack holds 64-bit - ~ values, because it gets sign-extended. - ~ - ~ We need to restore rsi before we return to Forth. - 0 push-imm32-extended64 - :rdx :rsi mov-reg64-reg64 - here ! ] ;asm - - -~ Branching -~ ~~~~~~~~~ - -~ Okay, so there's a weird thing about how branch and 0branch are defined. -~ 0branch jumps into branch, so they need to be next to each other in the log. -~ To compute the offset to jump by, we pass an address on the stack. Notice -~ that assembly words are always defined in immediate mode; it's just they -~ usually only do trivial logic. - -~ This takes a number of bytes, not machine words. That allows it to be used -~ for putting weird things embedded in the code. -~ -~ The offset is relative to the start of the word the number of bytes is in, -~ so, make sure to have it skip itself. -: branch - [ here @ - dup swap ~ Save a copy of this address for later. - :rsi :rsi add-reg64-indirect-reg64 - here ! ] ;asm -~ (jump destination) - -: 0branch - [ here @ - ~ (jump destination, output point) - - :rax pop-reg64 - :rax :rax test-reg64-reg64 - - ~ Please notice the 8-bit branch to the nearby word. This is the offset - ~ from the end of the jmp instruction, to the start of the target - ~ instruction. To avoid needing the label system for this, we compute it - ~ based on the address before the jmp; the jmp itself is two bytes. - ~ - ~ Remember, with jump arithmetic, subtract the start from the - ~ destination. - ~ - ~ What we're testing with :cc-equal is that the input value is zero. - ~ The name is slightly counterintuitive; it's a result of the condition - ~ names favoring cmp over test. While cmp simulates subtraction, test - ~ simulates bitwise AND. - dup 2 + 3roll swap - :cc-equal jmp-cc-rel-imm8 - ~ (output point) - - ~ In the event we didn't jump, we still need to skip over the literal - ~ value. Using lods here is just a convenient way to skip rsi forward. - lods64 - - here ! ] ;asm -~ the stack is empty once more - - -~ This is like next, but instead of using rsi as the "instruction pointer", -~ it takes a codeword address from the value stack. -~ -~ In the event that the codeword is docol, docol will handle any -~ manipulation of the control stack that needs to happen. Yes, it really is -~ that simple. -~ -~ (execution token --) -: execute - [ here @ - :rax pop-reg64 - :rax jmp-abs-indirect-reg64 - here ! ] ;asm - - -~ Dictionary entries -~ ~~~~~~~~~~~~~~~~~~ -~ -~ Now, we have a bunch of words that are used for traversing the Forth -~ core data structures that describe words. First, we have a couple that -~ relate to individual words and their pieces... -~ -~ The log-load transform produces code that requires -~ entry-to-execution-token, which means it's needed statically. So this stuff -~ to deal with word entry headers might as well go in core, since it has no -~ dependencies to speak of. -~ -~ These are the first words in core that are implemented in Forth rather -~ than assembler. That's not as big a deal as it may seem; the Forth execution -~ model has been ready-to-go ever since we implemented docol and exit, and -~ at this point we have enough basics to do useful things with it. - -~ Jonesforth calls this "TFCA" and ">CFA"; its author speculates that the -~ original meaning is "code field address". -~ -~ (entry pointer -- execution token) -: entry-to-execution-token - ~ Skip next-entry pointer, flag byte, and start terminator. - 10 + - ~ Skip string contents. - dup stringlen + - ~ Skip one for the null terminator, seven more for alignment. - 8 + - ~ Zero the low bits and now it's aligned. - 7 invert & ; - -~ Jonesforth calls this "CFA>". Jonesforth's implementation searches the -~ entire dictionary, since its word header format isn't designed to be -~ traversed in reverse, but ours is, so it should be fast. -~ -~ (execution token -- entry pointer) -: execution-token-to-entry - 1 - - dup reverse-padding-len - - dup reverse-stringlen - - 9 - ; - -~ (entry pointer -- flags byte) -: entry-flags@ - 8 + @ 0xFF & ; - -~ (new flags byte, entry pointer --) -: entry-flags! - 8 + - dup @ 3roll - 0xFF & - swap 0xFFFFFFFFFFFFFF00 & | - swap ! - ; - -~ (entry pointer -- name string pointer) -: entry-to-name 10 + ; - - -~ Binary packing -~ ~~~~~~~~~~~~~~ -~ -~ These routines are for building up data structures in-memory. Sometimes -~ they're used for structures that are meant to stay in memory; other times -~ it's a buffer that will become output. -~ -~ The general pattern is that each routine takes an output address and -~ some specific datum, and returns the output address adjusted to point -~ after the new datum. That makes them easy to chain together. We call this -~ address the "output point", to capture the idea that it's a running total -~ which gets updated by each new datum as it's packed. - -~ (output point, value -- output point) -: pack64 swap dup 3unroll ! 8 + ; -: pack32 swap dup 3unroll 32! 4 + ; -: pack16 swap dup 3unroll 16! 2 + ; -: pack8 swap dup 3unroll 8! 1 + ; - -~ This works on C-style strings, which are characters followed by a null -~ terminator. The packed data includes the null terminator. -~ -~ (output point, string pointer -- output point) -: packstring - dup stringlen 1 + dup - ~ (output point, source, length, length) - 4 roll dup 4 unroll - - ~ (source, destination, length, length, output point) - + 4 unroll - ~ (output point, source, destination, length) - memcopy ; - -~ This also works on C-style strings, relying on the null terminator, but -~ the packed data does not include it. -~ -~ (output point, string pointer -- output point) -: pack-raw-string - dup stringlen dup - ~ (output point, source, length, length) - 4 roll dup 4 unroll - - ~ (source, destination, length, length, output point) - + 4 unroll - ~ (output point, source, destination, length) - memcopy ; - -~ (output point, alignment byte width -- output point) -: packalign - ~ It's possible the padding will be of length zero; keep that in mind - ~ while maintaining these magic comments, as it comes up in several ways. - ~ : fresh-line - ~ : 0 #-- (alignment padding) - { 2dup /% drop { drop exit } unless - swap 0 pack8 swap - ~ : 1 adjust-length - } forever ; - - -~ Binary unpacking -~ ~~~~~~~~~~~~~~~~ -~ -~ These routines are for examining data structures in-memory. -~ -~ Similarly to the output routines, each routine takes an input address, -~ which it updates to point after the data item being read. We call this the -~ "input point". Since this is input, the routines return data items rather -~ than accepting them. - -~ (input point -- input point, value) -: unpack64 dup @ swap 8 + swap ; -: unpack32 dup 32@ swap 4 + swap ; -: unpack16 dup 16@ swap 2 + swap ; -: unpack8 dup 8@ swap 1 + swap ; - -~ (proposed size, alignment byte width -- adjusted size) -: align-size - dup 3unroll dup 3unroll - ~ (alignment, alignment, proposed size, alignment) - 1 - + swap /% swap drop * ; - -~ You might think this would be identical to packalign, but packalign has -~ side effects. -~ -~ (input point, alignment byte width -- input point) -: unpackalign align-size ; - - -~ The first hint of a debugging tool -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~ This peforms the "hlt" instruction (Intel's mnemomic, short for "halt"), -~ which will cause the program to exit with a segmentation fault. If you're -~ running under a debugger, this is a convenient way to get execution to stop -~ at a certain point. -~ -~ It's called "crash" rather than "hlt" to distinguish it from the word -~ which outputs the instruction as machine code. -~ -~ This is the main diagnostic tool available under the label transform. Yep. -~ That's all we get. Don't make those eyes. -: crash - [ here @ - hlt - here ! ] ;asm - - -~ Additional conveniences -~ ~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ Please feel free to find an organizing principle for these and put them -~ where they go. It would be kind of nice to re-write these either in -~ assembly, or with high-level flow control, but it doesn't seem urgent... - -: max - 2dup >= { swap } if - drop ; - -: min - 2dup <= { swap } if - drop ; - -: over swap dup 3unroll ; - -~ 0 pick is equivalent to dup. 1 pick is equivlent to over. -: pick 2 + dup roll dup 3roll unroll ; - -~ Standard Forth doesn't have equivalents of our ndrop and ndup. The HP -~ calls them DROPN and DUPN but that doesn't go well with ie. 2dup or 3roll, -~ so we do it like this. -: ndrop { dup } { swap drop 1- } while drop ; - -: ndup - dup 1+ swap - { dup } { swap dup pick 3unroll swap 1- } while - 2drop ; - -: 3drop drop drop drop ; -: 3dup 2 pick 2 pick 2 pick ; - -: && 0 != swap 0 != * ; -: || | 0 != ; -: not 0 = ; -: negate -1 * ; - -: align-floor dup 3unroll /% swap drop * ; - - -~ Find-in is the main word that provides the capability to look up words by -~ name, though it's usually used via "find" rather than being called directly. -~ -~ Find-in traverses the linked list formed by a particular dictionary's -~ next-entry pointers, looking for an entry that matches a given name. The -~ dictionary pointer is the pointer (not handle) to the root of the list, -~ which runs from newest to oldest. For example, dereferencing the value of -~ "latest" gives the pointer to the main dictionary, which can be passed to -~ find-in. -~ -~ Having find-in separated out is convenient when working with alternate -~ dictionaries, but the main reason for having it is not convenience but -~ necessity: During Evocation's startup, there is a period before global -~ variables are easily accessible, so there would be no way to implement -~ "find". The warm-start routine (see execution.e and transform.e) has the -~ job of fixing that, and it makes extensive use of find-in to do so. -~ -~ The definition of "find" is in dynamic.e, with the other stuff that needs -~ to access the log. -~ -~ (dictionary pointer, string pointer -- entry pointer or 0) -: find-in - ~ It will be more convenient to have the entry pointer on top. - swap - - { - ~ If the entry pointer is null, exit. - ~ (name pointer to find, current entry pointer) - dup 0 = { swap drop exit } if - - ~ Check this entry's "hidden" flag. - ~ (name pointer to find, current entry pointer) - dup entry-flags@ 0x80 & 0x80 != { - ~ Test whether this entry is a match. - ~ (name pointer to find, current entry pointer) - 2dup 10 + stringcmp 0 = { - ~ If we're here, it's a match. Clean up our working state and exit. - ~ (name pointer to find, current entry pointer) - swap drop exit - } if - } if - - ~ If we're here, it's not a match; traverse the pointer and repeat. - ~ (name pointer to find, current entry pointer) - @ - } forever ; - diff --git a/dynamic.e b/dynamic.e deleted file mode 100644 index cf27eb5..0000000 --- a/dynamic.e +++ /dev/null @@ -1,559 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Dynamic definitions ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ This file provides additional facilities which are fundamental parts of -~ Evocation as a language, but which it's not possible to define until global -~ variables are available. Therefore it is incompatible with the label -~ transform, but compatible with the log-load transform and written to obey -~ its constraints; see transform.e for more details on that. -~ -~ The code here relies on the words "log", "s0", "r0", "latest", and "here". -~ These five global variables are the root of all our other data structures. -~ They are defined specially by warm-start in execution.e, since there is no -~ way to create regular definitions for them. Thus, they come to us already -~ set up. -~ -~ It may not be obvious, but when a regular docol-based Evocation word is -~ compiled, it hardcodes pointers to all the words it references, which will -~ be part of it forever after. Thus, these words can reference "here" and so -~ on, and they'll just know where to find it, no runtime mechanism for looking -~ it up is needed. That's important, because there are no good ways to build -~ such a mechanism! It would have to dedicate a register or something of that -~ nature, and registers are far too precious for such a use. -~ -~ In this file, we define a bunch of more sophisticated ways to work with -~ the log, then we use it to define a high-level flow control facility which -~ saves us from having to compute branch offsets by hand. Pleasantly, we get -~ to use this facility before it's actually defined, since the log-load -~ transform also provides it. That being the case, we might as well start with -~ whatever's most urgent - which is, of course, the debugging tools. - - -~ Debugging tools for real -~ ~~~~~~~~~~~~~~~~~~~~~~~~ - -: stack - s0 @ 8 - { dup value@ 8 + != } - { dup s0 @ 8 - != { space } if dup @ . 8 - } - while drop newline ; - -: stackhex - s0 @ 8 - { dup value@ 8 + != } - { dup s0 @ 8 - != { space } if dup @ .hex64 8 - } - while drop newline ; - -~ (pointer -- boolean) -: is-in-log dup log @ <= swap here @ > && ; - -~ (-- entry pointer or 0) -: oldest-entry - latest @ { dup @ } { @ } while ; - -~ (dictionary handle -- entry pointer or 0) -: oldest-entry-in - dup - dup { { dup @ } { @ } while } if - dup 3roll = { drop 0 } if ; - -~ (entry pointer -- entry pointer or 0) -: next-newer-entry - latest @ - 2dup = { 2drop 0 exit } if - { dup { 2dup @ != } if } - { @ } while swap drop ; - -~ (entry pointer, dictionary handle -- entry pointer or 0) -: next-newer-entry-in - @ - 2dup = { 2drop 0 exit } if - { dup { 2dup @ != } if } - { @ } while swap drop ; - -~ (entry pointer -- pointer) -: guess-entry-end - dup entry-flags@ 64 & 64 = { exit } if - dup next-newer-entry dup - { drop dup is-in-log { drop here @ } { drop } if-else - exit } unless - swap drop ; - -~ (pointer -- entry pointer or 0) -: containing-entry - dup is-in-log { drop 0 exit } unless - latest @ { dup { 2dup > over is-in-log && } { 0 } if-else } - { @ } while swap drop ; - -~ (entry pointer -- boolean) -: is-assembly-word - entry-to-execution-token dup 8 + swap @ = ; - -~ (entry pointer -- boolean) -: is-docol-itself - entry-to-name s" docol" stringcmp 0 = ; - -~ The word named "docol" has the job of returning the value that gets used -~ as the actual codeword. We make the assumption that the codeword will -~ point somewhere near the entry header; we allow for the possibility that -~ it might be before or after. -~ -~ Generally, it's possible for there to be several copies of docol due to -~ alternate logs and things like that, so the goal is to recognize any of -~ them. -~ -~ (entry pointer -- boolean) -: is-docol-codeword - dup is-in-log { drop 0 exit } unless - containing-entry dup - { dup is-docol-itself - { drop 1 } - { next-newer-entry dup { is-docol-itself } if } if-else - } if ; - - -~ TODO this only works on log words -~ -~ (entry pointer -- boolean) -: is-docol-interpreted-word - dup is-assembly-word { drop 0 exit } if - entry-to-execution-token @ is-docol-codeword ; - - -~ (pointer -- boolean) -: is-codeword-pointer - dup is-in-log { drop 0 exit } unless - dup containing-entry dup { 2drop 0 exit } unless - entry-to-execution-token = ; - - -~ (width --) -: indent { dup } { space 1- } while drop ; - -~ (entry pointer --) -: word-heading - dup entry-to-name dup emitstring space - stringlen 1+ 54 swap - 0 max indent dup .hex64 - dup entry-flags@ dup - { space - dup 0x80 & { s" H" emitstring } if - dup 0x40 & { s" M" emitstring } if - dup 0x01 & { s" I" emitstring } if - } if drop - dup is-assembly-word { s" asm" emitstring } - { dup is-docol-interpreted-word { s" raw" emitstring } unless - } if-else drop - newline ; - - -: list-dictionary - oldest-entry { dup } - { dup word-heading next-newer-entry } while drop ; - - -~ (byte -- boolean) -: is-printable - dup 0x20 <= swap 0x7F > && ; - - -~ (content end, content start, label start --) -: hexdump-row - 2 indent dup .hex32 dup 4 unroll - ~ (label start, content end, content start, label start) - 0 { dup 16 > } { - ~ (label start, content end, content start, label start, offset within row) - dup 7 & 0 = { space } if space - 2dup + dup 4 pick <= swap 5 pick > && - { 2dup + 8@ .hex8 } { space space } if-else - 1+ } while - drop - 2 indent s" |" emitstring - 0 { dup 16 > } { - ~ (label start, content end, content start, label start, offset within row) - 2dup + dup 4 pick <= swap 5 pick > && - { 2dup + 8@ - dup is-printable - { value@ emitstring } { s" ." emitstring } if-else - drop } - { space } if-else - 1+ } while - s" |" emitstring - newline 5 ndrop ; - - -~ (start, end --) -: hexdump-between - swap dup 16 1- invert & - { dup 3 pick > } - { 3dup hexdump-row 16 + } while 3 ndrop ; - - -~ (start, length --) -: hexdump-from swap dup 3unroll + hexdump-between ; - - -~ (start --) -: hexdump 64 hexdump-from ; - - -~ (entry pointer --) -: describe-hex - dup word-heading - dup guess-entry-end swap entry-to-execution-token - swap hexdump-between ; - - -~ (entry pointer --) -: describe-docol - dup word-heading - dup guess-entry-end swap entry-to-execution-token 8 + - { 2dup < } - { space dup @ dup is-codeword-pointer - { execution-token-to-entry entry-to-name emitstring } - { . } if-else - 8 + } while newline ; - - -~ (entry pointer --) -: describe - dup is-docol-interpreted-word - { describe-docol } { describe-hex } if-else ; - - -: describe-all - oldest-entry { dup } - { dup describe next-newer-entry } while drop ; - - -: describe-compilation - ~ It's always in progress ;) We just need a header like this so it doesn't - ~ get confused with other kinds of debug output. - ." compilation in progress" newline - latest @ hexdump - newline - ." here " here @ .hex64 newline - ." latest " latest @ .hex64 newline - ." name of latest: " latest @ entry-to-name emitstring newline - newline ; - - -: symbolize-pointer - dup is-in-log { - dup containing-entry dup is-in-log { - ~ Any format we're going to use here starts with the entry's name; by - ~ printing it now we don't have to keep track of it later. - dup entry-to-name emitstring - - dup entry-to-execution-token - ~ (scrutinee, entry pointer, codeword pointer) - dup 3 pick >= { - ~ The pointer is somewhere in the word's body, so we compute the - ~ offset from the codeword. - swap drop - - ~ (offset) - dup { - ." +" . - } { - ~ The pointer goes to the codeword. We don't print anything here, - ~ so the output is just the word's name. This will look "right" in - ~ a code listing styled like the ones produced by "describe". - drop - } if-else - } { - ~ The pointer is in the header, so we compute the offset from the - ~ entry address. - drop - - ~ (offset) - - ~ We always print the offset, even if it's zero; this visually - ~ emphasizes the difference between entry addresses and content - ~ addresses... or that's the hope. - ." :" . - } if-else - - ~ All of the above paths printed SOMETHING, so we're done. - exit - } { drop } if-else - } if - - ~ If we fall through, just print it as a number. - ." 0x" .hex64 ; - - -: list-callers - control@ r0 @ < - control@ log @ > || - { ." control stack pointer out of range: " control@ .hex64 newline } if - - control@ { dup r0 @ > } - { dup @ symbolize-pointer newline 8 + } while - drop ; - - - -: bye 0 sys-exit ; - - - -~ Log manipulation -~ ~~~~~~~~~~~~~~~~ - -~ In general, we're going to want to be able to go on little excursions -~ where we define utility words that are only useful for one task, then -~ deallocate that stuff after we're done with it. We implement "forget", -~ which removes both dictionary entries and log allocations for the entry -~ pointer it's given and everything that came after. -~ -~ The implementation strategy is the same as Jonesforth's version, but -~ Jonesforth runs in immediate mode and reads a word to operate on, whereas -~ ours takes an entry pointer and runs in either compiled or immediate -~ modes. -~ -~ (entry pointer --) -: forget dup @ latest ! here ! ; - -~ (value --) -: , here @ swap pack64 here ! ; - -~ We'll be defining a lot of immediate words, so we should set up a terse -~ way to do that. -: make-immediate latest @ dup entry-flags@ 0x01 | swap entry-flags! ; -: make-hidden latest @ dup entry-flags@ 0x80 | swap entry-flags! ; -: make-visible latest @ dup entry-flags@ 0x80 invert & swap entry-flags! ; -: make-metadata latest @ dup entry-flags@ 0x40 | swap entry-flags! ; - -~ Sooner or later we'll want to define recursive words; this one lets us -~ do that. It compiles into a call to the word that's currently being -~ defined (strictly speaking, the one whose definition was most recently -~ begun). -~ -~ TODO it seems like maybe the log-load transform breaks this? hm -: recurse latest @ entry-to-execution-token , ; make-immediate - - -~ The implementation of "find-in" is in core.e, since it's used by the label -~ and transformation facilities. Once we have full log access, we get the -~ nicety of using "find" instead. -~ -~ (string pointer -- entry pointer or 0) -: find latest swap find-in ; - - -~ Allocates bytes on the log by incrementing the global "here" pointer. The -~ "here" pointer is kept aligned to an 8-byte boundary, regardless of the size -~ requested. -~ -~ This does not create dictionary entries, it's just a raw memory interface. -~ It's suitable for allocating data or scratch space. -~ -~ (size -- pointer) -: allocate - here @ dup - ~ (size, here value, here value) - 3roll + 8 packalign here ! ; - - -~ Takes a string pointer which must be equal to the current value of "here", -~ indicating it is in the temporary allocation space, and allocates it -~ permanently by advancing "here" to the next aligned address after it. -~ -~ (string pointer -- string pointer) -: allocate-string - dup dup stringlen 1+ + 8 packalign here ! ; - - -~ Allocate space by incrementing "here", and output a word entry header in -~ it. Also add it to the "latest" linked list. Use zero as the flag values; -~ accept a string pointer on the stack and use its contents as the name. -~ -~ This is the first step of creating a new word. Its responsibility includes -~ everything up to the codeword, not including the codeword; it leaves things -~ all set up to start appending contents to the new word by calling ",". -~ -~ There's a handy diagram of the entry header format under "quick -~ reference", in the description of the exeuction model in exeuction.e. Create -~ is responsible for everything up to the codeword, not including it. -~ -~ When a word is created in interpret mode using s" to provide a string -~ literal, the temporary space that s" uses is in the same place as the -~ entry header we're going to write out. It really is very useful to have -~ that work. Fortunately, it does! We're able to avoid needing a special case -~ by doing things in a very careful way, as described below. -~ -~ (string pointer --) -: create - ~ We add one to the string length in order to include the trailing null - ~ terminator. This will be the length of our name field; we save an extra - ~ copy of it to help with packing later. - dup stringlen 1 + dup 3unroll - ~ (name field length, string pointer, name field length) - - ~ We use memmove to put the string in its final position, because it works - ~ correctly when the destination overlaps with the source. Notice that we - ~ do this before writing anything else in the entry header, to avoid - ~ stepping on it. The name string always starts ten bytes into the header, - ~ so we can use a fixed offset. - here @ 10 + swap memmove - ~ (name field length) - - ~ Now we can get back to the fields that belong at the start of the entry - ~ header. We take the value of "here" and keep a working copy of it on the - ~ stack, which we'll advance every time we write more bytes. - here @ - ~ (name field length, updated "here" pointer) - - ~ Pack the old value of "latest" as the first field of the header, linking - ~ from the newly-defined word to the next-newest word. - ~ - ~ All the entries form a linked list, from newest to oldest. Since the - ~ link is the first field in the entry header, you can get from each entry - ~ to the one before it just by dereferencing the entry pointer. - latest @ pack64 - - ~ This is the flags byte. It starts at zero; our caller can change it if - ~ desired. - 0 pack8 - - ~ This is the "other" null terminator, used when traversing the name - ~ string backwards for execution-token-to-entry. Yes, the name is - ~ null-terminated at both ends. - 0 pack8 - - + ~ The name field is already populated, so just skip past it. - ~ (updated "here" pointer) - - ~ The codeword is aligned to a machine-word boundary, and the padding for - ~ it is create's responsibility. - ~ - ~ By adding the null terminator before adding alignment padding, we've - ~ made sure there's always at least one null byte. Otherwise we'd be missing - ~ the terminator if by chance the name were exactly the wrong length. - 8 packalign - ~ (updated "here" pointer) - - ~ Retrieve the value of "here", which still doesn't reflect our additions, - ~ and store it at the adddress of "latest". It's the start of our - ~ newly-defined word, which makes it the latest word. - here @ latest ! - - ~ Finally, we write our updated value of "here" back into the variable. - here ! ; - - -~ Notionally, it might make sense to define "create" in terms of -~ "create-in". Any change like that is being postponed to after the removal -~ of flatassembler, when refactorings will be easier. -~ -~ The dictionary handle points to a pointer to the first item. -~ -~ (string pointer, dictionary handle --) -: create-in - dup @ here @ swap pack64 -~ (name string pointer, dictionary handle, output point) - 0 pack8 0 pack8 - 3roll packstring - 8 packalign -~ (dictionary handle, output point) - swap here @ swap ! -~ (output point) - here ! - ; - - -: self-codeword here @ 8 + , ; - - -~ A variable is simply a word that returns a specific address, always the -~ same one, at which a value can be stored. This word "variable" takes and -~ address and a word name, and defines the word. Allocating space is its -~ caller's responsibility. -~ -~ TODO the address is constant but the contents vary, confusing, write it up -~ -~ (address for new variable word to point to, string pointer --) -: variable - create - self-codeword - here @ - swap :rax mov-reg64-imm64 - :rax push-reg64 - pack-next - 8 packalign - here ! ; - - -~ A keyword is a word that evaluates to its own address, which makes it -~ suitable for use as a constant. By convention, all our keywords have names -~ starting with a colon, which imitates the way they work in Common Lisp. -~ -~ Specifically, it returns its own execution token. Thus, executing its -~ result repeatedly will keep giving the same value. We aren't in the habit of -~ doing quote-exec kinds of things in Evocation, but it seems as good as any -~ other unique value, so we might as well. -~ -~ Unlike CL, we don't currently have the lexer automatically create keywords -~ for us; we create them explicitly. That's likely to be added at some point, -~ but at the moment the feature is lying fallow to see whether it winds up -~ seeing a lot of use. -~ -~ (string pointer --) -: keyword - create - - ~ Before outputting our codeword, save a copy of the address where it's - ~ going to be. That will be the execution token we return. - here @ dup - ~ (self execution token, output point) - - ~ Now add a codeword. This is an assembly word, so it's a self-codeword, - ~ meaning it points to the word right after itself. - dup 8 + pack64 - ~ (self execution token, output point) - - ~ Now we consume the execution token, using it as part of this instruction. - swap :rax mov-reg64-imm64 - ~ (output point) - - ~ To return it, we push it to the stack. - :rax push-reg64 - - ~ Now just the normal stuff every assembly word ends with. - pack-next - 8 packalign - - here ! ; - - -~ Although we will eventually define the word "'" to give us the symbol of -~ a word, it will rely on being able to compile a literal. Rather than do lots -~ of string processing later, we choose to define this word now to avoid -~ having to look up the word "lit" as part of that. -~ -~ It may be slightly surprising that the construction "lit lit" works as -~ expected, given that ie. "lit 5" will break, as will "lit [", so it's worth -~ explaining why it does. -~ -~ In most respects "lit" is just an ordinary word, which compilation turns -~ into a pointer to its codeword. That's what happens to most words, if -~ they're not a special syntax nor flagged as immediate. It just happens to be -~ a word that it rarely makes sense to use directly, since its purpose is to -~ be generated as part of the output when compiling number literals. The -~ special behavior around number literals is that when "interpret" sees ie. -~ "5", it first compiles "lit", then appends the numeric value 5 as the -~ following item in the compiled word body. -~ -~ The job of "lit" when it's later executed is to push the appropriate value -~ onto the stack and ensure that it doesn't get executed as code. So, whatever -~ you put immediately after it gets treated as a value, even if it's a -~ pointer. -~ -~ The reason that writing "lit 5" in Evocation syntax crashes is that it -~ gets turned into "lit lit 5" when compiled, which treats the second "lit" as -~ a value then tries to use "5" as a codeword pointer. So you can use "lit" -~ to quote whatever you want, it's just if it's already a special syntax you -~ might need to go behind "interpret"'s back to get it into the compiled -~ output. In practice, this is likely the only place that needs to happen, but -~ the mechanism is documented for the sake of whatever comes up in the future. -~ -~ (value -- ) -: literal lit lit , , ; - diff --git a/elf.e b/elf.e deleted file mode 100644 index 2a67c54..0000000 --- a/elf.e +++ /dev/null @@ -1,179 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Executable file format ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ Before we do anything specific to the actual program we're building, we -~ do a lot of ELF-specific stuff to ensure that our output is in a format -~ Linux knows how to run. -~ -~ This relies on the label facility defined in labels.e. Make sure to load -~ that first. -~ -~ This file makes use of magic comments for the hex transform, described in -~ detail in transform.e, but its use is trivial and doesn't require accounting -~ conventions. - -~ ~~~~~~~~~~~~~~~~~~~~~ -~ ~~ ELF file header ~~ -~ ~~~~~~~~~~~~~~~~~~~~~ -~ -~ First, we output ELF's top-level file header. This header describes the -~ entire file. An ELF always has exactly one of this header, which is always -~ at the start of the file. -~ -~ The program we're building should call this word as the first output it -~ generates. -~ -~ The most interesting thing here is the entry pointer. -~ -~ It's also worth noticing that we set the ABI version to 3. An ABI version -~ of 0 (for the System V ABI) would work fine too, but 3 allows FreeBSD's -~ Linux compatibility features to kick in. - -: elf-file-header - ~ : blank-line - ~ : ELF file header - ~ : indent - ~ : * denotes mandatory fields according to breadbox - current-offset 3unroll - - ~ : 1 suppress - 0x7f pack8 s" ELF" pack-raw-string ~ : -4 *magic number - 2 pack8 ~ : -1 64-bit - 1 pack8 ~ : -1 little-endian - 1 pack8 ~ : -1 ELF header format v1 - 3 pack8 ~ : -1 Linux ABI - 0 pack64 ~ : -8 (padding) - ~ : blank-line - - 2 pack16 ~ : -2 *executable - 0x3e pack16 ~ : -2 *Intel x86-64 - 1 pack32 ~ : -4 ELF format version - ~ : blank-line - - L@' cold-start L@' origin + pack64 ~ : -8 *entry point - ~ This includes the origin, intentionally. - - L@' elf-program-header pack64 ~ : -8 *program header offset - ~ We place the program header immediately after the ELF header. This - ~ offset is from the start of the file. - 0 pack64 ~ : -8 section header offset - 0 pack32 ~ : -4 processor flags - ~ : blank-line - - L@' elf-header-size pack16 ~ : -2 ELF header size - L@' elf-program-header-size pack16 ~ : -2 *program header entry size - 1 pack16 ~ : -2 *number of program header entries - 0 pack16 ~ : -2 section header entry size - 0 pack16 ~ : -2 number of section header entries - 0 pack16 ~ : -2 section name string table index - - ~ Though hardcoding the size of this header would work fine, it's easier - ~ to use the label system to keep track of its size. The only place this is - ~ actually referenced is right here in the header. - current-offset 4 roll - L!' elf-header-size - L' elf-header-size set-label-non-offset - ~ : deindent - ; - - -~ ~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ ELF program header ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ Second, we output ELF's program header, which lists the memory regions -~ ("segments") we want to have and where we want them to come from. There may -~ be any number of these entries, one per segment, , and they may be anywhere -~ in the file as long as they're consecutive. -~ -~ We list just a single region, which is the entire contents of the ELF file -~ from disk, and we put the program header immediately after the file header. -~ The program we're building should call this word as the second output it -~ generates. -~ -~ It would be more typical to use this header to ask the loader to give us -~ separate code and data segments, and perhaps a stack or heap, but this keeps -~ things simple, and we can create those things for ourselves later. -~ -~ We do have a little stack space available, though we don't explicitly -~ request any; the kernel allocates it for us as part of exec() so that it can -~ pass us argc and argv (which we ignore). That stack space will be at a -~ random address, different every time, because of ASLR; that's a neat -~ security feature, so we leave it as-is. Note that ASLR doesn't happen when -~ you run under gdb, so if you aren't seeing it, that's probably why. - -~ ~~ -: elf-program-header - ~ : blank-line - ~ : ELF program header - ~ : indent - ~ * denotes mandatory fields according to breadbox - current-offset L!' elf-program-header - current-offset 3unroll - - 1 pack32 ~ : -4 *"loadable" segment type - 0x05 pack32 ~ : -4 *read+execute permission - 0 pack64 ~ : -8 *offset in file - L@' origin pack64 ~ : -8 *virtual address - ~ required, but can be anything, subject to alignment - 0 pack64 ~ : -8 physical address (ignored) - ~ : blank-line - - L@' total-size pack64 ~ : -8 *size in file - L@' total-size pack64 ~ : -8 *size in memory - ~ : blank-line - - 0 pack64 ~ : -8 segment alignment - ~ for relocation, but this doesn't apply to us - - ~ As with the file header, we use the label system to keep track of the - ~ program header's size. - current-offset 4 roll - L!' elf-program-header-size - L' elf-program-header-size set-label-non-offset - ~ : deindent - ; - - -~ This alternate version of the program header isn't used by evoke.e, but -~ may be useful for other programs, such as hex.e. Its only difference from -~ the base version is that it adds the write permission. -: elf-program-header-writable - ~ : blank-line - ~ : ELF program header - ~ : indent - ~ * denotes mandatory fields according to breadbox - current-offset L!' elf-program-header - current-offset 3unroll - - 1 pack32 ~ : -4 *"loadable" segment type - 0x07 pack32 ~ : -4 *read+write+execute permission - 0 pack64 ~ : -8 *offset in file - L@' origin pack64 ~ : -8 *virtual address - ~ required, but can be anything, subject to alignment - 0 pack64 ~ : -8 physical address (ignored) - ~ : blank-line - - L@' total-size pack64 ~ : -8 *size in file - L@' total-size pack64 ~ : -8 *size in memory - ~ : blank-line - - 0 pack64 ~ : -8 segment alignment - ~ for relocation, but this doesn't apply to us - - ~ As with the file header, we use the label system to keep track of the - ~ program header's size. - current-offset 4 roll - L!' elf-program-header-size - L' elf-program-header-size set-label-non-offset - ~ : deindent - ; - -~ ~~~~~~~~~~~~~~~~ -~ ~~ That's it! ~~ -~ ~~~~~~~~~~~~~~~~ -~ -~ ELF is a simple format, really. Now you can output your own machine code -~ that you generate however you want; make sure to define the labels "origin" -~ and "cold-start". Origin will control the address the code loads at; -~ cold-start will be the first thing that runs. The origin is arbitrary, but -~ can't be zero. - diff --git a/evoke.e b/evoke.e index 7e6225f..1b1453b 100644 --- a/evoke.e +++ b/evoke.e @@ -1,34 +1,34 @@ ~ cat evoke.e | ./evoke > evoke2 && chmod 755 evoke2 -s" labels.e" include -s" elf.e" include -s" transform.e" include -s" execution.e" include +s" compilation/labels.e" include +s" compilation/elf.e" include +s" compilation/transform.e" include +s" compilation/execution.e" include : read-inputs here @ dup - s" core.e" pack-file-contents - s" linux.e" pack-file-contents - s" output.e" pack-file-contents - s" amd64.e" pack-file-contents - s" execution-support.e" pack-file-contents - s" log-load.e" pack-file-contents + s" language/static/core.e" pack-file-contents + s" language/static/linux.e" pack-file-contents + s" language/static/output.e" pack-file-contents + s" language/static/amd64.e" pack-file-contents + s" language/static/execution-support.e" pack-file-contents + s" language/static/log-load.e" pack-file-contents 0 pack8 8 packalign here ! s" source-to-precompile" variable here @ dup - s" core.e" pack-file-contents - s" linux.e" pack-file-contents - s" output.e" pack-file-contents - s" amd64.e" pack-file-contents - s" execution-support.e" pack-file-contents - s" log-load.e" pack-file-contents - s" dynamic.e" pack-file-contents - s" input.e" pack-file-contents - s" interpret.e" pack-file-contents - s" flow-control.e" pack-file-contents - s" linux-dynamic.e" pack-file-contents - s" files.e" pack-file-contents + s" language/static/core.e" pack-file-contents + s" language/static/linux.e" pack-file-contents + s" language/static/output.e" pack-file-contents + s" language/static/amd64.e" pack-file-contents + s" language/static/execution-support.e" pack-file-contents + s" language/static/log-load.e" pack-file-contents + s" language/dynamic/dynamic.e" pack-file-contents + s" language/dynamic/input.e" pack-file-contents + s" language/dynamic/interpret.e" pack-file-contents + s" language/dynamic/flow-control.e" pack-file-contents + s" language/dynamic/linux.e" pack-file-contents + s" language/dynamic/files.e" pack-file-contents 0 pack8 8 packalign here ! s" source-to-copy-to-log" variable ; read-inputs diff --git a/execution-support.e b/execution-support.e deleted file mode 100644 index a3d0ca5..0000000 --- a/execution-support.e +++ /dev/null @@ -1,111 +0,0 @@ -~ Execution support -~ ~~~~~~~~~~~~~~~~~ -~ -~ These macros are an important part of the execution model described in -~ execution.e. They're here, in this file, because they need to be statically -~ available via the label transform, so that the log-load transform can rely -~ on them. - - -~ Macro next -~ ~~~~~~~~~~ -~ -~ Include this inline at the end of a word implemented in machine-code. -~ Conceptually, it returns. What it actually does is do the next thing the -~ caller would do, which is call the next word from the caller's array of -~ word pointers. -~ -~ This is a widespread technique in Forth implementation, referred to as -~ indirect threaded code. It's "threaded" in the sense that each word takes -~ responsibility for finishing up by following the notional thread through the -~ metaphorical labyrinth to figure out the next word that its caller wants to -~ run after it. In other words, control never directly returns to the parent, -~ it proceeds directly to the sibling. -~ -~ Registers in: -~ -~ * rsi points to the address of the word to execute -~ -~ Registers out: -~ -~ * rax points to the codeword in the contents of the word that was executed -~ * rsi points to the next word-address after this one -~ -~ Flags -~ * DF = 0 is required -~ -~ (output point -- output point) -: pack-next - ~ : "next" macro - ~ Copy the next word's address from *rsi into rax. Increment rsi (as per - ~ the DF flag). - lods64 - - ~ Load the codeword from the word's contents, and jump to the interpreter - ~ it points to. - :rax jmp-abs-indirect-reg64 ; - - -~ Macro beforenext -~ ~~~~~~~~~~~~~~~~ -~ -~ Sometimes we want to transfer control from a word implemented in -~ machine-code to another word, without coming back after, as if we were -~ simply jumping to it. This is an innovation of ours; Jonesforth doesn't do -~ it. It is similar to the tail-call optimization that many Lisp dialects -~ have. -~ -~ This implementation will work regardless of how the receiving word is -~ implemented. It impersonates the "next" snippet, setting up rax to point -~ to the codeword then jumping to the interpreter. Since it doesn't change -~ the control stack or rsi, when the receiving word eventually invokes -~ "next"; it will pick up in the same place as if this sending word had done -~ it. -~ -~ Thus, notionally we are doing just this one transfer of control before -~ eventually getting around to inlining "next". Hence the name. -~ -~ (output point, target address -- output point) -: pack-beforenext - ~ : "beforenext" macro - ~ Do a permanent transfer of control by setting rax and invoking the - ~ codeword. Of course, we could jump to docol ourselves but this will work - ~ regardless of what the receiving codeword is. - :rax mov-reg64-imm64 - :rax jmp-abs-indirect-reg64 ; - - -~ Macros pushcontrol -~ popcontrol -~ ~~~~~~~~~~~~~~~~~~ -~ -~ Include these inline to push an address onto the control stack, or pop -~ one off of it. You will recall the control stack is kept in rbp. The -~ parameter is given in a user-specified register. -~ -~ Jonesforth's analogous macros are called PUSHRSP and POPRSP but I think -~ that's super confusing, since rsp is also the name of a register, but a -~ different one. I guess it was less confusing in 32-bit, since esp doesn't -~ start with an "r". Anyway, this has to be named something that -~ distinguishes it from Intel's PUSH and POP opcodes, so... -~ -~ "Load effective address" is just a cute way to do arithmetic on a -~ register, here. To push or pop we decrement or increment rbp by 8. To -~ actually interact with the space in the stack, we indirect through rbp. -~ -~ Registers in and out: -~ -~ * rbp points to the top of the control stack. -~ -~ (output point, source register -- output point) -: pack-pushcontrol - ~ : "pushcontrol" macro - swap :rbp -8 :rbp lea-reg64-disp8-reg64 - swap :rbp 0 mov-disp8-reg64-reg64 ; - -~ (output point, target register -- output point) -: pack-popcontrol - ~ : "popcontrol" macro - :rbp 0 3roll mov-reg64-disp8-reg64 - :rbp 8 :rbp lea-reg64-disp8-reg64 ; - diff --git a/execution.e b/execution.e deleted file mode 100644 index 81ec03b..0000000 --- a/execution.e +++ /dev/null @@ -1,592 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Execution model ~~ -~ ~~~~~~~~~~~~~~~~~~~~~ -~ -~ We use Forth-style dual stacks, one for values and one for control. We -~ use rsp for values, just like C does. We use rbp for the control stack, -~ which is a special Forth-y stack: These are pointers into the bodies of -~ Forth words, not return addresses. -~ -~ The choice of rsp and rbp for the stack pointers imitates Jonesforth; -~ I'm hopeful that it gives us convenient addressing modes, and will report -~ back about that when I feel that I understand the implications. -~ -~ In Forth, everything is a "word", including mutable variables. -~ Conceptually, a word is a unit of execution, which may be implemented -~ either in machine code or as an array of pointer to other words. -~ -~ This polymorphism is implemented by having each word's contents begin -~ with a "codeword", which is a pointer to machine code that "interprets" -~ the rest of the contents. In the case of words implemented in machine -~ code, the codeword points directly to that code, which is normally right -~ next to it. -~ -~ Variables, to Forth, are simply one more thing that can be executed; the -~ effect of executing a variable is to push its address onto the value -~ stack. -~ -~ We adopt this model of words, codewords, and variables-as-words. It's -~ really nice how it doesn't force anything else on us, not even a heap, -~ though we do end up using the log as a sort-of heap. -~ -~ We specifically implement a version of calling and returning that Forth -~ calls indirect threaded code: The control stack is a stack of pointers -~ into the middle of interpreted words. The interpreter snippet, called -~ docol, implements calling. Each word is responsible for making sure -~ returning works properly. Interpreted words accomplish this by ending with -~ the word "exit", while machine-code words accomplish it by ending with a -~ verbatim snippet called "next". -~ -~ Conceptually, "next" returns, but more specifically it accomplishes this -~ by doing the caller's next dispatch for it; thus control never actually -~ goes back to the caller's interpreter after initial setup. For performance -~ reasons, "next" is always inlined, so we define it as a macro. -~ -~ The docol routine is just ordinary code, not a macro. It's defined later -~ in this file, as a label. -~ -~ Notionally, we could consider not having a dictionary, and not giving -~ our words names. However, it feels silly to stop when we're so close to -~ being a full Forth, and using names for things solves a bootstrapping -~ problem related to log management - see the write-up of cold-start about -~ how the log is created, below. So, we add an additional header before the -~ codeword for this purpose. -~ -~ The Forth dictionary is usually a linked list of every word that has -~ ever been defined, with the newest at the head; the names of words are -~ stored in string fields, often right next to the link pointer. We adopt -~ this model, with the field sizes and order shown in the quick reference -~ below. We break with Forth tradition in one way: Rather than having a -~ length field, we use a null-terminated string. Thus, there's no length -~ limit on names. This necessitates breaking out the flags (to be explained -~ later) into their own byte, rather than taking bits from the length field -~ for them. -~ -~ There's an important performance consideration: Executable words -~ reference each other by pointers to their respective codewords. However, -~ dictionary entries reference each other by pointers to their respective -~ link fields. Traversing from the link field to the codeword is easy, -~ though it's a non-constant-time operation: Just walk the string. In order -~ to make Forth words easy to "decompile", it would be nice to also have a -~ way to traverse backwards. We solve this by making the name field be -~ null-terminated at both ends. Fun, yeah? -~ -~ -~ -~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ Quick Reference -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ The layout of an interpreted word: -~ -~ (overall start) -~ 0x00 - 0x07 Link (to next-oldest word) -~ 0x08 - 0x08 HM00000I Flags -~ H - hidden -~ M - metadata -~ I - immediate -~ all other bits reserved -~ (name start) -~ 0x09 - 0x09 Null byte (terminates name) -~ 0x0a - name-end - 1 Name, as UTF-8 -~ name-end - name-end Null byte (terminates name) -~ (padding start) -~ name-end + 1 - codeword-start - 1 Zero-pad to 8-byte boundary -~ (it's possible this will be zero bytes long) -~ (codeword start) -~ ... + 0x00 - ... + 0x08 Codeword (ie. address of docol) -~ (8-byte chunks) Addresses of other words -~ - ... (end) Address of "exit" word -~ -~ The layout of a machine-code word is different only from the codeword on: -~ -~ ... + 0x00 - ... + 0x08 Addresss of next byte -~ ... + 0x08 - ???? Arbitrary machine code -~ - ... (end) Inlined implementation of next -~ -~ Also, words always start at 8-byte boundaries. -~ -~ -~ REGISTER usage conventions: -~ -~ * rsi is the "instruction pointer" for the "interpreter". -~ That is, it points to some word-pointer inside an array of -~ word-pointers inside the content of the word they're part of. It always -~ points to the next word that should be executed, whose execution hasn't -~ begun yet. -~ -~ * rbp points to the top of the control stack -~ These are former values of rsi, to eventually be returned to, from -~ successively older callers as you look further up the stack. The stack -~ grows downwards in memory. Since values are kept separately, the only -~ thing on the control stack is return addresses, one per layer of call. -~ -~ * rsp points to the top of the value stack -~ The value stack has no specific format, but it grows downwards in -~ memory. In particular there's no concept of stack frames, because items -~ on the stack don't belong to any particular word; the value stack in -~ Forth is in part a mechanism for passing values between words. -~ -~ Additionally, immediately after beginning execution of a word: -~ -~ * rax points to the address of the codeword being executed -~ The value of rax is purely for the callee's benefit, and does not need -~ to be preserved. -~ -~ Other registers are purely discretionary, and are not preserved across -~ calls. -~ -~ -~ FLAG usage: -~ -~ * DF should be 0 -~ We use lodsq extensively and that makes it increment rsi after using it. -~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -~ The macros next, beforenext, pushcontrol, and popcontrol are implemented -~ in execution-support.e. It's a good idea to go read about them now. -~ -~ TODO the following high-level summary should go... somewhere? -~ When a docol word is invoked, it immediately does pushcontrol (see -~ execution-support.e) to push rsi onto the control stack, whose top is -~ indicated by rbp. When an assembly word is invoked, it leaves rsi and rbp -~ alone; assembly words don't normally call other words, so there's no need -~ for them to appear on the control stack at all. -~ -~ When an assembly word returns, it looks for an execution token pointed -~ to by rsi, increments rsi, and invokes that word as if calling it. This -~ is the threaded calling approach to Forth execution. When a docol word -~ returns, it calls exit, which needs to remove itself from the control -~ stack, so exit pops the top of the control stack into rsi to get back into -~ its caller's context, then does the same steps an assembly word would do. - - -~ Constants -~ ~~~~~~~~~ -~ -~ These are used in cold-start, just below. - -: log-requested-address 0x0000001000000000 ; ~ (very arbitrary) -: log-size 0x0000000001000000 ; ~ 16 MiB -: control-stack-size 0x10000 ; ~ 64 KiB - - -~ Routine cold-start -~ ~~~~~~~~~~~~~~~~~~ -~ -~ This is the entry point of the whole program, the very first code we -~ actually execute. Linkers traditionally call this _start, but let's live a -~ little. Anyway, the ELF header points to it and exec() jumps to it; from the -~ kernel's perspective, there's no such thing as names. Also, though this code -~ could be anywhere in the code part of the output, in order to make the -~ hexdump pretty we put it at the start. -~ -~ The kernel gives us most registers zeroed, and rsp pointing to the -~ command-line stuff (argc, argv, envp), which is at an ASLR'd address with -~ some stack space allocated for us, despite the fact we didn't request any. -~ It also gives us all the flags clear except IF, but we don't rely on that. -~ Lastly, of course, it loads our code segment and sets the instruction -~ pointer where we asked; we don't need to check what those addresses are, -~ because they're not randomized. -~ -~ Notably, though cold-start points rbp to the control stack, it leaves -~ the control stack empty, so trying to return will pop a value that doesn't -~ exist, and crash. Eventually, the bottom value on the control stack will -~ be the word "quit", which loops forever and is the closest thing Forth has -~ to a "main" word, but it's up to warm-start to make that happen. -~ -~ Cold-start is really only responsible for one-time initialization. -~ -~ -~ -~ Registers in: -~ -~ * rsp points to the logical top of the value stack -~ The kernel sets this up for us, and we need to save it somewhere so -~ Forth can use it. -~ -~ Registers out: -~ -~ * rsi points within "warm-start" -~ * rsp points to the top of the value stack -~ * rbp points to the top of the control stack -~ -~ Stack in: -~ -~ * argc, argv, envp in the usual Unix way -~ We ignore them, though. -~ -~ Stack out: -~ -~ * The value of "log", as a pointer -~ The meaning of this will be explained below. -~ -~ Registers within: -~ -~ * rdi points to the base the log was allocated at, once it exists -~ This is the same value that "log" will hold, once we reach a point -~ where we have variables. Of course, variables are stored on the log, -~ hence this temporary measure. -~ -~ We also take this opportunity to define soeme memory layout parameters -~ that this routine will be responsible for doing something with: -~ -~ (output memory start, current output point -~ -- output memory start, current output point) -: output-cold-start - ~ : blank-line - ~ : blank-line - ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - ~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~ : blank-line - ~ : This is the start of the cold-start routine, which is the first code - ~ : of any kind the executable runs. It has the responsibility of creating - ~ : the Forth execution environment, then invoking the warm-start routine, - ~ : which is defined below. - ~ : blank-line - ~ : indent - - current-offset L' cold-start set-label - cld ~ clear the DF flag - - ~ Prepare the log. - ~ - ~ We could ask for a data segment in the program header, but where's the - ~ fun in that? Instead, we call mmap(). - ~ - ~ If we wanted the kernel to do ASLR for us, passing address zero would - ~ cause it to pick somewhere at random, but instead we choose our own - ~ location. It's still not guaranteed to be where we ask for, so we still - ~ do the work to record where it wound up. We could pass the "fixed" flag - ~ and the kernel would trust us, but this gives us more options for - ~ interoperating with other runtimes. - ~ - 9 :rax mov-reg64-imm64 ~ : mmap() - log-requested-address :rdi mov-reg64-imm64 - ~ : 0 address (very arbitrary) - log-size :rsi mov-reg64-imm64 ~ : size (one meg) - 0x07 :rdx mov-reg64-imm64 - ~ : 0 protection (read+write+exec) - 0x22 :r10 mov-extrareg64-imm64 ~ : flags (private+anonymous) - 0 :r8 mov-extrareg64-imm64 ~ : file descriptor (ignored) - 0 :r9 mov-extrareg64-imm64 ~ : offset (ignored) - syscall - - ~ The return value of the system call is in rax, we'll use it in a sec. - ~ We need to save this somewhere in case we ever want to munmap() it; - ~ there's no widely-used name for it so we have to make one up. S0 and r0 - ~ are widely-used names for the physical tops (logical bottoms) of the - ~ value and control stacks, respectively, and we will eventually set those - ~ up as well, so we should keep those names in mind. The control stack - ~ lives within the log, while the value stack is its own segment. This - ~ value, though, is the physical bottom of the segment, meaning that it - ~ stays the same even as we allocate and deallocate things within it. This - ~ is unlike the two stack pointers, so we give it a name that doesn't - ~ suggest similarity: "log". - ~ - ~ Once Forth is fully set up, its internal variables will be accessed - ~ through variable-words like any other Forth data, including "log". To - ~ get to that point, though, we need to be able to hold onto variable data - ~ between now and then. In fact, if we don't have at least one of "log" - ~ and "here" (its counterpart which points to the logical top end), all - ~ our efforts to hold onto anything seem a bit doomed. - ~ - ~ So, we temporarily dedicate rdi to "log" - only within this routine - - ~ and store everything else in ways that let us find things by reference - ~ to it. We choose rdi because it works with the indexing modes we care - ~ about, and its name suggests its function. - ~ - ~ The strategy Jonesforth uses is not applicable to us; Jonesforth - ~ takes advantage of the linker to let its code segment refer to specific, - ~ pre-allocated objects in the data segment. We are our own linker, and we - ~ don't care to have a data segment. Hence, this approach. - ~ - ~ Keying things off "log" is the fundamental decision, but to make sure - ~ our variables are accessible both during early bootstrapping, and later, - ~ we also have to be thoughtful about data structures. More on that in a - ~ moment. - ~ - :rax :rdi mov-reg64-reg64 - - ~ We also initialize rbp. We could hold off and let "quit" do this, but - ~ doing it now is the easiest way to initialize the r0 variable, since - ~ there's no instruction that moves a 64-bit immediate to memory. - ~ - ~ This is the moment at which we decide where the control stack starts! - ~ Fun, right? "Allocation" is just a fancy word for picking where we want - ~ something, then being consistent about it - like placing furniture in - ~ your home. See below for a little more thought about why here in - ~ particular. - ~ - :rdi control-stack-size :rbp lea-reg64-disp32-reg64 - - ~ Now we save some stuff onto the log. These are the locations that - ~ will eventually be the backing stores of the Forth variables, but we - ~ don't create the word headers yet, since there's no requirement that - ~ they be next to the backing stores. We'll do that later, once we have - ~ word-writing infrastructure in place. For now, we just use their offsets - ~ relative to the physical bottom of the log, which are fixed. - ~ - ~ These will be the permanent homes of these values, though we have - ~ copies of them elsewhere while we're still in this routine. - ~ - :rdi control-stack-size 0x00 + :rdi mov-reg64-disp32-reg64 ~ log - :rsp control-stack-size 0x08 + :rdi mov-reg64-disp32-reg64 ~ s0 - :rbp control-stack-size 0x10 + :rdi mov-reg64-disp32-reg64 ~ r0 - L@' final-word-name :rax mov-reg64-imm64 - :rax control-stack-size 0x18 + :rdi mov-reg64-disp32-reg64 ~ latest - :rdi control-stack-size 0x28 + :rax lea-reg64-disp32-reg64 - :rax control-stack-size 0x20 + :rdi mov-reg64-disp32-reg64 ~ here - ~ - ~ * "log" is the physical bottom of the log - ~ The log grows upwards in memory, so this is also the logical - ~ bottom. This comes from the address mmap() just returned to us. - ~ * "s0" is the logical bottom of the value stack - ~ The value stack grows downwards in memory, so this is the physical - ~ top of it. This comes from the stack pointer the kernel initialized us - ~ with. - ~ * "r0" is the logical bottom of the control stack - ~ The control stack also grows downwards, so this is its pysical top - ~ as well. We allocate this dedicated space within the log right here, - ~ in this routine, through our choice of where to put things. - ~ * "here" is the physical start of the unallocated space in the log - ~ We allocate log space from bottom to top, by incrementing this - ~ value. So, it would also be accurate to say that it points immediately - ~ after the physical top of the allocated space. At any rate, the - ~ address it points to is the first one that hasn't been used yet. - ~ * "latest" is the address of the most-recently-defined word's header - ~ Defining new words changes this value. - ~ - ~ s0 and r0 are mostly used when we want to initialize or reinitialize - ~ their respective stacks - that is, discard all their contents at once. - ~ - ~ The value of r0 is the same address these variables start at, so - ~ you'll want to do a close read of the implementation of pushcontrol - ~ and convince yourself that it only ever writes things just below the rbp - ~ address it receives, never right on top of it. - ~ - ~ As an aside, by the way, please notice that strictly speaking, r0 - ~ could be a constant... but it isn't known until runtime, so we might as - ~ well make it a variable. That will play nicely with any astonishing - ~ memory shenanigans someone might wish to do in the future. - ~ - ~ Notice also that "here" points immediately after itself. This is just - ~ a convenience, making it the last one like that so that the concern is - ~ dealt with in a single place and is easy to keep up-to-date with code - ~ changes. - ~ - ~ A little more detail about why we offset everything by - ~ control_stack_size: We're carving out some space at the bottom of the - ~ log - which grows low-to-high - to be the control stack - which grows - ~ high-to-low. So the control stack is allocated out of the log as a - ~ fixed-size, one-time thing, and then the variables come immediately - ~ after that. We do need to use 32-bit displacement indexing to access - ~ them this way, but that's no big deal. - ~ - ~ This is perhaps questionable, they should maybe be separate segments - ~ created with separate calls to mmap(), but for now we're not worried - ~ about overflow so we use the same allocation for both. - ~ - ~ We'll come back to these variables a bit later and generate the word - ~ headers that point at them, but now we're almost ready to switch to - ~ proper threaded-execution, so we finish that setup first... - - ~ Push the value of "log" onto the value stack so that it can be the - ~ breadcrumb the threaded code needs to find... the backing store of - ~ "log". Yes, self-reference can be weird like that sometimes. There's - ~ nothing stopping "quit" from reading rdi, it just violates the - ~ abstraction... - :rdi push-reg64 - - ~ We are about to set up rsi, we did rbp already, and rsp came to us - ~ already set up. That's all that "next" needs, so take it away! - L@' warm-start L@' origin + :rsi mov-reg64-imm64 - pack-next - ~ : deindent - ; - - -~ Routine warm-start -~ ~~~~~~~~~~~~~~~~~~ -~ -~ This routine runs as Forth code. That is, indirect threaded execution has -~ been initialized, and the structure of this routine is an array of codeword -~ pointers. It was directly jumped to from cold-start. There's nowhere to -~ return to, so it needs to never return. -~ -~ (output buffer start, output point, input string pointer -~ -- output buffer start, output point) -: output-warm-start - ~ : blank-line - ~ : blank-line - ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - ~ : ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ - ~ : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ~ : blank-line - ~ : This is the start of the warm-start routine, which is the first Forth - ~ : code the executable runs, after the cold-start routine has created the - ~ : Forth execution environment. - ~ : - ~ : It does some initial setup here at the top; then the vast bulk of it - ~ : is actually the log-load routine, directly included; then finally there - ~ : is a small amount of finishing work done at the tail end of the - ~ : warm-start routine. - ~ : - ~ : The routine's body is interpreted Forth code, meaning that it is an - ~ : an array of pointers to the codewords of Forth words, occasionally - ~ : interspersed with literal values. - ~ : - ~ : The codeword pointers were located by using the label system, which - ~ : means the labels they reference must have been defined somewhere else, - ~ : normally by the label transform. The label-transformed code normally - ~ : occurs after the warm-start routine in the executable, which means these - ~ : are forward references to words defined far below. - ~ : blank-line - ~ : indent - - ~ While it's not actually a requirement that codeword pointers be - ~ word-aligned, it's highly likely that it helps performance. (Whether it - ~ does is up to Intel's microcode.) - 3unroll - 8 packalign - current-offset L!' warm-start - ~ (input string pointer, output buffer start, output point) - - ~ Before handing off to us, cold-start pushed a single value onto the - ~ stack, a pointer to the beginning of the log. Now, we load our entire - ~ Forth implementation onto that log, beginning with the minimal set of - ~ words needed to define more words. We do this because we need variables as - ~ infrastructure so we can eventually have dynamic definitions. - ~ - ~ There's something non-obvious here: words implemented statically as - ~ part of the executable image can't contain things that vary at runtime. - ~ That means that even if these words tried to implement some sort of - ~ dynamic lookup, they would have no way to find the root of whatever - ~ dynamic data structure they use. Dynamism needs to be bootstrapped. - ~ - ~ In a more traditional C-style program, static code could look up - ~ variables based on fixed addresses that are the same on every run. - ~ Failing that, we could dedicate a register to it, though that's a - ~ considerable expense. We chose not to do either of those things, because - ~ we want the versatility that comes with not being picky about our - ~ address space: It allows us to contemplate future improvements such as - ~ ASLR, or embedding into other processes that impose their own addressing - ~ constraints, or even coexisting with multiple versions of ourselves. - ~ That choice does mean we have the hard version of this bootstrapping - ~ problem, and copying ourselves to the log is how we solve it. - ~ - ~ We do have the log address right now, though that won't last. In case - ~ it's unclear why not: keeping it on the stack would require all future - ~ references to walk the stack, and somehow know when they've reached the - ~ bottom. The stack is a good place to keep things with clearly delimited - ~ lifetimes and visibility, but when we want something to live for our - ~ entire program and be easy to find from any code within it, we need to - ~ do something else. Anyway, since we have the address, we can use it for - ~ the next little bit of setup. We have a bunch of helper words, from - ~ log-load.e, which make this easier. - ~ - ~ The first few words we define are our variables, which hardcode the - ~ addresses they will return - but since we're doing this at runtime, - ~ "hardcoding" can reflect where our log is. This is the fundamental - ~ trick that makes the log usable. - ~ - ~ One more thing to notice: We already allocated the backing stores of - ~ these variables, and populated their initial values, in cold-start. The - ~ words we're defining return those same addresses for the same backing - ~ stores. So, we have continuity: Stuff defined in terms of the - ~ variable-words we're defining now will interoperate with the stuff that - ~ we define using the log-load helpers, which includes those very words. - ~ Both the log-load code and the later code are dealing with the same data - ~ structures, they're just using a different technique to find them. - ~ - ~ This is the only hardcoding we need to do; by building on top of it, - ~ we will soon reach a point where the rest of the system can be defined - ~ within itself. - - L@' log-load-log offset-to-target-address-space pack64 - ~ : -8 log-load-log #-- (codeword pointer) - L@' litstring offset-to-target-address-space pack64 - ~ : -8 litstring #-- (codeword pointer) - s" log" packstring 8 packalign - L@' log-load-variable offset-to-target-address-space pack64 - ~ : -8 log-load-variable #-- (codeword pointer) - - L@' log-load-s0 offset-to-target-address-space pack64 - ~ : -8 log-load-s0 #-- (codeword pointer) - L@' litstring offset-to-target-address-space pack64 - ~ : -8 litstring #-- (codeword pointer) - s" s0" packstring 8 packalign - L@' log-load-variable offset-to-target-address-space pack64 - ~ : -8 log-load-variable #-- (codeword pointer) - - L@' log-load-r0 offset-to-target-address-space pack64 - ~ : -8 log-load-r0 #-- (codeword pointer) - L@' litstring offset-to-target-address-space pack64 - ~ : -8 litstring #-- (codeword pointer) - s" r0" packstring 8 packalign - L@' log-load-variable offset-to-target-address-space pack64 - ~ : -8 log-load-variable #-- (codeword pointer) - - L@' log-load-latest offset-to-target-address-space pack64 - ~ : -8 log-load-latest #-- (codeword pointer) - L@' litstring offset-to-target-address-space pack64 - ~ : -8 litstring #-- (codeword pointer) - s" latest" packstring 8 packalign - L@' log-load-variable offset-to-target-address-space pack64 - ~ : -8 log-load-variable #-- (codeword pointer) - - L@' log-load-here offset-to-target-address-space pack64 - ~ : -8 log-load-here #-- (codeword pointer) - L@' litstring offset-to-target-address-space pack64 - ~ : -8 litstring #-- (codeword pointer) - s" here" packstring 8 packalign - L@' log-load-variable offset-to-target-address-space pack64 - ~ : -8 log-load-variable #-- (codeword pointer) - - ~ Having done that, nothing else needs to be defined in an unusual way, so - ~ we can go ahead and dispatch to the log-load transform, and do the rest of - ~ the code through that. - - ~ (input string pointer, output buffer start, output point) - 3roll log-load-transform - ~ (output buffer start, output point) - - ~ : blank-line - ~ : We're now done with the log-load routine; the next little bit of code - ~ : here is the final bit of the warm-start routine. - - ~ Now everything we need has been added to the log and we're almost ready - ~ to jump into it. It's inconvenient for code under the log-load transform - ~ to interact with the label system, so if we want to point - ~ main-input-buffer at a string, this is the place to do it. - - ~ The next layer is built now, so let's move on to it. - L@' litstring offset-to-target-address-space pack64 - ~ : -8 litstring #-- (codeword pointer) - s" quit" packstring 8 packalign - L@' log-load-find-execution-token offset-to-target-address-space pack64 - ~ : -8 log-load-find-execution-token #-- (codeword pointer) - L@' swap offset-to-target-address-space pack64 - ~ : -8 swap #-- (codeword pointer) - ~ : Get rid of that heap pointer on the stack, we're finally done with it! - L@' drop offset-to-target-address-space pack64 - ~ : -8 drop #-- (codeword pointer) - L@' execute offset-to-target-address-space pack64 - ~ : -8 execute #-- (codeword pointer) - ~ : deindent - ; - - -~ Where next? -~ ~~~~~~~~~~~ -~ -~ The definitions of "docol" and "exit" are very tightly bound up with the -~ execution model. They're defined and explained in core.e, because they need -~ to be part of the build process in two different ways, like the other core -~ functionality. - diff --git a/files.e b/files.e deleted file mode 100644 index 9f353c5..0000000 --- a/files.e +++ /dev/null @@ -1,161 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ File manipulation ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ This file has high-level features for working with files and the -~ filesystem. There's a tension as to what belongs here vs. what belongs in -~ input.e or output.e, and it's likely there will be some refactoring as the -~ boundaries become clear. - - -~ (output point, filename -- output point) -: pack-file-contents - dup 0 0 sys-open - ~ (output point, filename, open result code or file descriptor) - dup 0 > { - ." Couldn't open " swap emitstring space - ." because " space . ." ." newline - 2 ndrop exit - } if - - ~ (output point, filename, file descriptor) - { - dup 3 pick 1024 sys-read - ~ (output point, filename, file descriptor, read result code or length) - - dup 0 > { - over sys-close drop - ~ Ignore a failed close. - - ." Error while reading from " 3roll emitstring - ." because " space . ." ." newline - drop exit - } if - - dup 0 = { - over sys-close drop - ~ Ignore a failed close. - - 3 ndrop exit - } if - - 4 roll + 3unroll - } forever ; - - -~ TODO probably make this more similar to pack-file-contents -~ (delimiter pointer, buffer size -- buffer address) -: read-to-buffer - dup allocate dup dup - ~ (buffer size, buffer address, word start, output point) - { key - ~ Exit if it's a zero byte. - dup not { - ~ Make sure to pack the zero to serve as a null terminator. - pack8 - drop drop swap drop swap drop exit } if - - ~ If it's a space character, we need to check if we just consumed the - ~ magic word, and do some handling to reset the word tracking. - dup is-space - { ~ (buffer size, buffer address, word start, output point, key) - ~ Tuck the key out of the way until we've done some stuff. - 3unroll - - ~ Add a null terminator so we can use stringcmp - dup 0 swap 8! - - ~ Check for the magic word. - over 6 pick stringcmp 0 = - { ~ It's magic, so exit. - ~ Make sure to pack a zero to serve as a null terminator. - 0 pack8 - drop drop drop swap drop swap drop exit } - { ~ It's not magic, so reset the word start. Of course whitespace is - ~ not a word but this will help us keep track of things. - 3roll pack8 - swap drop dup } if-else } - { ~ (buffer size, buffer address, word start, output point, key) - ~ Tuck the key out of the way again. - 3unroll - ~ Check if the word just started and the previous character is space. - 2dup = dup { drop dup @ is-space } if - { ~ If so, this is the actual first character of the word. - drop swap pack8 dup } - { ~ If not, leave the word start alone. - 3roll pack8 } if-else } if-else } forever ; - - -~ In logical terms, this modifies an input buffer metadata structure -~ in-place to push a new, zeroed one into the start of the linked list formed -~ through the next-source field. -~ -~ In physical terms, it works by allocating a new structure, copying the -~ fields of the existing one into it, and zeroing the existing one. That's -~ necessary because otherwise we'd need a mutable handle (a pointer to a -~ pointer) to update the start of the list, and there's no way to do that with -~ the main-input-buffer variable working the way it presently does. -~ -~ (input buffer metadata pointer --) -: push-input-buffer - allocate-input-buffer-metadata - ~ (original metadata pointer, new metadata pointer) - 2dup 7 8 * memcopy - ~ (original metadata pointer, new metadata pointer) - swap dup zero-input-buffer-metadata - input-buffer-next-source ! ; - - -~ This does the inverse of push-input-buffer. In the event that the -~ next-source field is null, it zeroes the buffer. -~ -~ Note, however, that it doesn't deallocate the memory, because that's not -~ how memory allocation on the log works. If necessary, it can be deallocated -~ with "forget", though as usual that requires careful planning. -~ -~ (input buffer metadata pointer --) -: pop-input-buffer - dup input-buffer-next-source @ - ~ (original metadata pointer, next source metadata pointer) - dup { swap 7 8 * memcopy } - { drop zero-input-buffer-metadata } if-else ; - - -: default-buffer-size 1024 ; - -~ (input buffer metadata pointer, file descriptor --) -: attach-input-buffer-to-file-descriptor - over buffer-file-descriptor ! - ~ (metadata pointer) - default-buffer-size allocate dup 2 pick buffer-physical-start ! - ~ (metadata pointer, buffer pointer) - over buffer-logical-start ! - ~ (metadata pointer) - default-buffer-size over buffer-physical-length ! - 0 over buffer-logical-length ! - ' refill-input-buffer-from-stream entry-to-execution-token - swap input-buffer-refill ! ; - - -~ Zero indicates success, nonzero indicates failure. -~ -~ (filename -- *, success) -: include - dup 0 0 sys-open - dup 0 > { - ." Couldn't open " swap emitstring space - ." because " space . ." ." newline - drop 1 exit - } if - ~ (file descriptor) - - main-input-buffer dup push-input-buffer - swap attach-input-buffer-to-file-descriptor - - { peek -1 != } { interpret } while - - main-input-buffer buffer-file-descriptor @ sys-close drop - ~ Ignore a failed close. - - main-input-buffer pop-input-buffer 0 ; - diff --git a/flow-control.e b/flow-control.e deleted file mode 100644 index 25a1931..0000000 --- a/flow-control.e +++ /dev/null @@ -1,151 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ High-level flow-control ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ We use a novel suffix-based approach to flow control. We define words -~ { and } which describe the boundaries of blocks of code, leaving a -~ description on the value stack, while still compiling the contents -~ normally. -~ -~ Then follow-up words such as "if" can use that information to slide -~ the blocks around and insert any needed branches and other logic. -~ -~ Both the label transform and the log-load transform go out of their way -~ to make sure these words work. Because of that, we actually get to use these -~ before defining them... just keep in mind nothing under the transform is -~ calling THESE versions. - - -~ (-- start pointer) -: { here @ ; make-immediate - -~ (start pointer -- start pointer, length) -: } dup here @ swap - ; make-immediate - - -~ (start pointer, length --) -: if - 2dup swap dup 5 8 * + 3roll - ~ (start pointer, length, start pointer, adjusted start pointer, length) - memmove - ~ (start pointer, length) - - swap here @ swap here ! swap - ~ (old here, length) - - ' lit entry-to-execution-token , 0 , - ' != entry-to-execution-token , - - ~ 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. - ' 0branch entry-to-execution-token , dup 8 + , - ~ (old here, length) - - drop 5 8 * + here ! - ; make-immediate - - -~ (start pointer, length --) -: unless - 2dup swap dup 5 8 * + 3roll - ~ (start pointer, length, start pointer, adjusted start pointer, length) - memmove - ~ (start pointer, length) - swap here @ swap here ! swap - ~ (old here, length) - ' lit entry-to-execution-token , 0 , - ' = entry-to-execution-token , - ~ 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. - ' 0branch entry-to-execution-token , dup 8 + , - ~ (old here, length) - drop 5 8 * + here ! ; make-immediate - - -~ (true start, true length, false start, false length --) -: if-else - - ~ 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 - ~ (true start, true length, false start, false length) - 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) - ' lit entry-to-execution-token , 0 , - ' != entry-to-execution-token , - ~ Branch past the length field, the true-block, and the unconditional - ~ branch in the middle. - ' 0branch entry-to-execution-token , - 3roll dup 4 unroll 3 8 * + , - - ~ Next, write out the unconditional branch in the middle. - swap dup 3unroll 5 8 * + here ! - ' branch entry-to-execution-token , - ~ Branch past the length field and the false-block. - dup 8 + , - - ~ Set "here" to point to the true end. - drop drop drop drop 7 8 * + here ! - ; make-immediate - - -~ (start, length --) -: forever - ' branch entry-to-execution-token , 8 + -1 * , drop - ; make-immediate - - -~ This slides the body forward, leaving the test where it is. It puts a -~ conditional branch in-between them, then appends an unconditional branch -~ at the end. -~ -~ (test start, test length, body start, body length --) -: while - ~ 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) - ' lit entry-to-execution-token , 0 , - ' != entry-to-execution-token , - ~ Branch past the length field, the body, and the unconditional branch. - ' 0branch entry-to-execution-token , - dup 3 8 * + , - ~ Set "here" to the new end. - 5 8 * 6 roll + here ! - ~ (test start, test length, body start, body length) - ~ Unconditionally branch backwards past the branch word, the body, the - ~ conditional branch, and the test. - ' branch entry-to-execution-token , - 6 8 * + swap drop + swap drop -1 * , - ; make-immediate - - -~ This is a helper which does non-local exit by directly overwriting the -~ control stack, then calling regular "exit" (implicitly as part of its own -~ semicolon). The name "nexit" is short for n-exit, meaning that it takes a -~ parameter which tells it how many times to exit. -~ -~ 1 nexit is equivalent to regular "exit". 2 nexit is equivalent to asking -~ your own caller to exit. 0 nexit does nothing. -~ -~ This style of programming isn't encouraged, but may be useful when doing -~ code that transforms other code. -~ -~ This is much lower-level than the other flow-control stuff, but it isn't -~ compatible with the label transform due to relying on r0, so it needs to go -~ somewhere other than core.e, and this was the closest fit. -~ -~ Anecdotally, this feature is traditionally called "shunt", and sometimes -~ "rdrop". -~ -~ (count --) -: nexit 8 * control@ + r0 @ min control! ; - diff --git a/hex.e b/hex.e index 3f9a1d8..cc4e0ce 100644 --- a/hex.e +++ b/hex.e @@ -1,8 +1,8 @@ ~ cat hex.e | ./evoke > hex && chmod 755 hex -s" labels.e" include -s" elf.e" include -s" transform.e" include +s" compilation/labels.e" include +s" compilation/elf.e" include +s" compilation/transform.e" include ~ (buffer start, output point, label offset ~ -- buffer start, output point) diff --git a/input.e b/input.e deleted file mode 100644 index 16fa836..0000000 --- a/input.e +++ /dev/null @@ -1,289 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~ -~ ~~ Input streams ~~ -~ ~~~~~~~~~~~~~~~~~~~ - -~ (pointer to buffer metadata -- pointer to buffer "physical-start" field) -: buffer-physical-start ; - ~ The physical-start field happens to be the first thing in the metadata, so - ~ this is an nop, but it still exists as a word because having it reduces - ~ confusion. -~ (pointer to buffer metadata -- pointer to buffer "physical-length" field) -: buffer-physical-length 8 + ; -~ (pointer to buffer metadata -- pointer to buffer "logical-start" field) -: buffer-logical-start 2 8 * + ; -~ (pointer to buffer metadata -- pointer to buffer "logical-length" field) -: buffer-logical-length 3 8 * + ; -~ (pointer to buffer metadata -- pointer to buffer "file-descriptor" field) -: buffer-file-descriptor 4 8 * + ; -~ (pointer to input buffer metadata -- pointer to input buffer "refill" field) -: input-buffer-refill 5 8 * + ; -~ (pointer to input buffer metadata -~ -- pointer to input buffer "next-source" field) -: input-buffer-next-source 6 8 * + ; - - -~ Given an initialized buffer (input or otherwise), sets its logical-start -~ and logical-length fields to indicate the buffer is empty. This relies on -~ the buffer having a backing store attached, but does not alter the backing -~ store or its contents. -~ -~ (pointer to buffer metadata --) -: clear-buffer - dup buffer-physical-start @ swap - ~ (address of backing store, metadata pointer) - dup 3unroll - ~ (metadata pointer, address of backing store, metadata pointer) - buffer-logical-start ! - buffer-logical-length 0 swap ! ; - - -~ Sets all fields in an input buffer metadata structure to their default -~ values, mostly zero, effectively detaching and leaking any backing store -~ that had been attached to it. Suitable for use during initialization. -~ -~ (pointer to input buffer metadata --) -: zero-input-buffer-metadata - dup buffer-physical-start 0 swap ! - dup buffer-physical-length 0 swap ! - dup buffer-logical-start 0 swap ! - dup buffer-logical-length 0 swap ! - dup buffer-file-descriptor -1 swap ! - dup input-buffer-refill 0 swap ! - ~ Notice the absence of a dup this time. - input-buffer-next-source 0 swap ! ; - - -~ Allocates input-buffer metadata, with no backing store attached. -~ Initializes the metadata to all zeroes. -~ -~ (-- pointer to input buffer metadata) -: allocate-input-buffer-metadata - 7 8 * allocate - dup zero-input-buffer-metadata ; - - -~ Allocates input buffer metadata and a backing store, in one operation. -~ Points the metadata to the backing store. -~ -~ (buffer capacity in bytes -- pointer to input buffer metadata) -: allocate-input-buffer - dup 7 8 * + allocate - dup zero-input-buffer-metadata - ~ (capacity in bytes, metadata pointer) - dup dup 7 8 * + - ~ (capacity in bytes, metadata pointer, metadata pointer, physical start) - swap buffer-physical-start ! - ~ (capacity in bytes, metadata pointer) - dup 3unroll buffer-physical-length ! - ~ (metadata pointer) - dup clear-buffer ; - - -~ Sets the backing store of an input buffer to point at a null-teriminated -~ string and read from it. -~ -~ (buffer metadata pointer, string pointer --) -: attach-string-to-input-buffer - swap - ~ (string pointer, metadata pointer) - 2dup buffer-physical-start ! - ~ (string pointer, metadata pointer) - 2dup buffer-logical-start ! - ~ (string pointer, metadata pointer) - swap stringlen swap - ~ (string length, metadata pointer) - 2dup buffer-physical-length ! - ~ (string length, metadata pointer) - dup 3unroll buffer-logical-length ! - ~ (metadata pointer) - -1 swap buffer-file-descriptor ! ; - - -~ (metadata pointer --) -: consume-from - ~ If the length is zero, exit without doing anything. - dup buffer-logical-length @ 0 = { drop exit } if - - ~ Decrement the logical length. We do this now to get it over with, since - ~ adjusting the start pointer is more complex. - dup buffer-logical-length dup @ 1 - swap ! - ~ (metadata pointer) - - ~ We compute the physical end. We'll need it in adjusting the logical start, - ~ and doing it now means less stack juggling later. - dup dup buffer-physical-start @ swap buffer-physical-length @ + swap - ~ (physical end, metadata pointer) - - ~ Compute the incremented logical start. - dup buffer-logical-start @ 1 + - ~ (physical end, metadata pointer, updated start pointer) - - ~ Check whether the updated start is equal to the physical end. - dup 4 roll = - ~ (metadata pointer, updated start, updated start, physical end) - { - ~ If the logical start pointer is now equal to the physical end pointer, - ~ we want to wrap to the physical start. That's what makes it a circular - ~ buffer. - ~ (metadata pointer, updated start) - drop dup buffer-physical-start @ - } if - - ~ However we got here, save the updated logical start pointer. - ~ (metadata pointer, updated start) - swap buffer-logical-start ! ; - - -~ We use -1 as a return value to indicate end-of-file. This can be -~ distinguished from valid data, because it's a full 64 bits, whereas a byte -~ of 0xFF wouldn't be. -~ -~ (metadata pointer -- byte or -1) -: peek-from - dup buffer-logical-length @ { - ~ If the length is zero, there is no input, but we can still try calling - ~ the "refill" word. - ~ (metadata pointer) - dup input-buffer-refill @ dup { - ~ If the refill word is zero, we can't help, just return EOF. - ~ (metadata pointer, refill word) - drop drop -1 exit - } unless - - ~ If the refill word is nonzero, call it. It expects a copy of the metadata - ~ pointer as its parameter, so set that up. - ~ (metadata pointer, refill word) - swap dup 3roll execute - ~ (metadata pointer) - ~ Now we check if the length is still zero. - dup buffer-logical-length @ { - ~ The length is zero even after calling the refill word, so return EOF. - ~ (metadata pointer) - drop -1 exit - } unless - } unless - - ~ The buffer is non-empty, so read a byte from it. We might have reached - ~ this point either from the original check, or from the second check after - ~ calling the refill word. - ~ - ~ While it might be more extensible to call an "unpack" word here, such as - ~ unpack8, we actually just want to get the value, and delegate the pointer - ~ adjustments to "consume". - ~ - ~ (metadata pointer) - buffer-logical-start @ 8@ ; - - -~ Just as with peek-from, we use -1 for EOF. -~ -~ (metadata pointer -- byte or -1) -: key-from - dup peek-from - ~ (metadata pointer, result byte) - ~ We unconditionally consume, because we have no way to distinguish between - ~ reading a zero byte and having nothing left to read. - swap consume-from ; - - -~ If the buffer is empty, make sure its logical position is at the -~ physical start. Otherwise, leave it alone. -~ -~ (metadata pointer --) -: normalize-buffer - dup buffer-logical-length @ 0 = - { dup buffer-physical-start @ swap - buffer-logical-start ! } { drop } if-else - ; - - -~ Find the next contiguous area of a buffer to write incoming data to. -~ This will begin at the logical end. Depending on the order things are in, -~ the available space might run from there to the physical end, or to the -~ logical start. Those are the only two possibilities. -~ -~ If the buffer is full, this will return as normal but the length will -~ be zero. The caller should make sure to respect that. -~ -~ (metadata pointer -- destination start, destination length) -: compute-next-buffer-free-block - dup buffer-physical-start @ swap dup buffer-physical-length @ - swap 3unroll + swap - ~ (physical end, metadata pointer) - dup buffer-logical-start @ swap dup buffer-logical-length @ - swap 3unroll + swap 3unroll - ~ (metadata pointer, physical end, logical end not yet wrapped) - - 2dup >= { - ~ If the logical end is greater than or equal to the physical end, find - ~ where it wraps to and start from there. - swap - swap dup buffer-physical-start @ swap 3unroll + - ~ (metadata pointer, destination start) - ~ In this scenario, the logical start is the end of the free space, so - ~ compute how far away it is. - dup 3roll - ~ (destination start, destination start, metadata pointer) - buffer-logical-start @ swap - - } { - 3roll drop - dup 3roll swap - - ~ If the logical end is less than the physical end, it is the destination; - ~ the physical end is also the end of the free space, so compute how far - ~ away it is. - } if-else ; - - -~ (metadata pointer --) -: refill-input-buffer-from-stream - dup normalize-buffer - dup compute-next-buffer-free-block - ~ (metadata pointer, destination start, destination length) - ~ Check whether the buffer is full. If not, do a read. If so, that's not - ~ an error, just clean up and take no action. - dup { swap - ~ (metadata pointer, destination length, destination start) - { 3 ndup 3roll buffer-file-descriptor @ 3unroll swap sys-read - ~ (metadata pointer, destination length, destination start, - ~ read result) - dup 0 > { - dup -4 = - { - ~ This is the EINTR case, so we're supposed to try the same - ~ read again. To that end, this whole thing is running in a - ~ loop, and all the other paths exit. - drop - ~ (metadata pointer, destination length, destination start) - } - { drop drop drop drop - ." Read error." 0 sys-exit } if-else } - { 3unroll drop drop - ~ (metadata pointer, read result) - swap dup buffer-logical-length @ 3roll + - ~ (metadata pointer, adjusted logical length) - swap buffer-logical-length ! exit } if-else } forever } - { drop drop drop } if-else ; - - - -~ Here we have some imperative code that runs immediately, to initialize -~ some runtime data structures. -~ -~ First, we insert a metadata word header to delimit the space. Otherwise -~ "describe" would crash when attempting to describe -~ "attach-string-to-input-buffer". - -s" main-input-buffer-metadata" create -s" main-input-buffer-metadata" find 0x01 swap entry-flags! - -~ Having done that, now we do the runtime allocation. Then we also define -~ the variable "main-input-buffer" so we can find it again. -allocate-input-buffer-metadata -s" main-input-buffer" variable - -~ We'll leave it to warm-start, in execution.e, to attach the buffer. It's -~ easier that way. - -: peek main-input-buffer peek-from ; -: consume main-input-buffer consume-from ; -: key main-input-buffer key-from ; - diff --git a/inscribe-evoke.e b/inscribe-evoke.e index 2b459fe..9bb7ddc 100644 --- a/inscribe-evoke.e +++ b/inscribe-evoke.e @@ -1,27 +1,27 @@ ~ cat inscribe-evoke.e | ./evoke > evoke.hex -s" labels.e" include -s" elf.e" include -s" transform.e" include +s" compilation/labels.e" include +s" compilation/elf.e" include +s" compilation/transform.e" include : prepare here @ dup - s" core.e" pack-file-contents - s" linux.e" pack-file-contents - s" output.e" pack-file-contents - s" amd64.e" pack-file-contents - s" execution-support.e" pack-file-contents - s" log-load.e" pack-file-contents - s" dynamic.e" pack-file-contents - s" input.e" pack-file-contents - s" interpret.e" pack-file-contents - s" flow-control.e" pack-file-contents - s" linux-dynamic.e" pack-file-contents - s" files.e" pack-file-contents - s" labels.e" pack-file-contents - s" elf.e" pack-file-contents - s" transform.e" pack-file-contents - s" execution.e" pack-file-contents + s" language/static/core.e" pack-file-contents + s" language/static/linux.e" pack-file-contents + s" language/static/output.e" pack-file-contents + s" language/static/amd64.e" pack-file-contents + s" language/static/execution-support.e" pack-file-contents + s" language/static/log-load.e" pack-file-contents + s" language/dynamic/dynamic.e" pack-file-contents + s" language/dynamic/input.e" pack-file-contents + s" language/dynamic/interpret.e" pack-file-contents + s" language/dynamic/flow-control.e" pack-file-contents + s" language/dynamic/linux.e" pack-file-contents + s" language/dynamic/files.e" pack-file-contents + s" compilation/labels.e" pack-file-contents + s" compilation/elf.e" pack-file-contents + s" compilation/transform.e" pack-file-contents + s" compilation/execution.e" pack-file-contents s" evoke.e" pack-file-contents 0 pack8 8 packalign here ! s" evoke-source" variable diff --git a/inscribe-hex.e b/inscribe-hex.e index e51b9f5..8dd6df8 100644 --- a/inscribe-hex.e +++ b/inscribe-hex.e @@ -1,25 +1,25 @@ ~ cat inscribe-hex.e | ./evoke > hex.hex -s" labels.e" include -s" elf.e" include -s" transform.e" include +s" compilation/labels.e" include +s" compilation/elf.e" include +s" compilation/transform.e" include : prepare here @ dup - s" core.e" pack-file-contents - s" linux.e" pack-file-contents - s" output.e" pack-file-contents - s" amd64.e" pack-file-contents - s" execution-support.e" pack-file-contents - s" log-load.e" pack-file-contents - s" dynamic.e" pack-file-contents - s" input.e" pack-file-contents - s" interpret.e" pack-file-contents - s" flow-control.e" pack-file-contents - s" linux-dynamic.e" pack-file-contents - s" files.e" pack-file-contents - s" labels.e" pack-file-contents - s" elf.e" pack-file-contents + s" language/static/core.e" pack-file-contents + s" language/static/linux.e" pack-file-contents + s" language/static/output.e" pack-file-contents + s" language/static/amd64.e" pack-file-contents + s" language/static/execution-support.e" pack-file-contents + s" language/static/log-load.e" pack-file-contents + s" language/dynamic/dynamic.e" pack-file-contents + s" language/dynamic/input.e" pack-file-contents + s" language/dynamic/interpret.e" pack-file-contents + s" language/dynamic/flow-control.e" pack-file-contents + s" language/dynamic/linux.e" pack-file-contents + s" language/dynamic/files.e" pack-file-contents + s" compilation/labels.e" pack-file-contents + s" compilation/elf.e" pack-file-contents s" hex.e" pack-file-contents 0 pack8 8 packalign here ! s" hex-source" variable diff --git a/interpret.e b/interpret.e deleted file mode 100644 index 7695d0b..0000000 --- a/interpret.e +++ /dev/null @@ -1,596 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~ -~ ~~ Interpreter ~~ -~ ~~~~~~~~~~~~~~~~~ -~ -~ The code in this file defines the basic syntax and semantics of Forth as -~ a text-based language. It's written in terms of the underlying executor, -~ which is implemented and explained in execution.e. The execution model gives -~ us the concept of "words"; the control and value stacks; and the ability to -~ call things. It has nothing to say about text, only about the binary form of -~ the language. -~ -~ It's traditional in Forth to refer to an act of "compiling" code, which -~ in this context means turning it from text into its binary representation. -~ That binary representation most commonly takes the form of a word entry -~ header followed by an array of codeword pointers. -~ -~ It would be legitimate to critique the terminology by saying that codeword -~ pointers are still, in some sense, interpreted: They are not machine code to -~ be directly executed by the CPU; they rely on "docol" and "next" at runtime. -~ However, in language design circles, the term "compilation" takes on a -~ broader meaning, referring to any process which requires some or all of the -~ types of infrastructure we regard as being compiler internals: A successive -~ translation of code from one form into another, discarding some types of -~ information while computing others, in a careful order that results in -~ logically consistent output which in some sense has the same meaning as the -~ input. Sometimes this output may be machine code, but often it is another -~ language meant for human consumption, or an intermediate layer meant to be -~ fed into another process. -~ -~ Forth compilation is compilation in this sense, so there is no conflict -~ and we run with the established terminology. In addition, it must be noted -~ that Evocation, like many Forths, makes extensive use of words which are -~ implemented directly in machine code; the Forth execution model allows these -~ words to co-exist with words that are interpreted by "docol". -~ -~ At any rate, the code in this file is responsible for that compilation. -~ -~ It is primarily concerned with managing the contents of an area of memory -~ we call the "log"; see log-load.e for more detail on terminology. - -~ As a convenience for "word", we have some facilities for working with -~ stack-allocated strings. Yeah, trippy concept. Also, it would be a -~ buffer overrun hazard if we were worried about that, which is why this -~ is no longer common practice in C. -~ -~ The most important of these is accumulate-string, but we need some -~ smaller pieces first. - -~ (stack string..., items to be left alone..., item to be unrolled, -~ number of items above string that participate in the unroll -~ -- item that was unrolled, stack string..., items left alone) -: unroll-past-string - 8 * - ~ (string, other items, top item, byte offset to string start) - dup value@ + - ~ We have two copies of the offset present, in addition to the stuff we want - ~ to rotate. So, the actual string starts two words on... We could have - ~ adjusted the offset instead, but we'll want the unmodified offset again - ~ later. - 16 + - ~ (string, other items, top item, offset to start, string pointer) - stringlen - ~ Same reasoning as in accumulate-string (see below). - 1 + 8 align-size - ~ (string, other items, top item, offset to start, string length w/ padding) - + 8 /% swap drop - ~ (string, other items, top item, number of words to unroll) - unroll ; - - - -~ (stack string..., item to be swapped -~ -- item that was swapped, stack string...) -: swap-past-string 1 unroll-past-string ; - - -~ (stack string... --) -: dropstring - value@ stringlen - ~ Same reasoning as in accumulate-string (see below). - 1 + 8 align-size value@ + - ~ At the time we fetched the stack pointer, there was an extra value atop - ~ it, so we have to add one more word. - 8 + value! ; - - -~ (stack string..., item to be kept -~ -- item that was kept) -: dropstring-with-result swap-past-string dropstring ; - - -~ (stack string-so-far..., new character byte -~ -- updated string-so-far) -: accumulate-string - ~ Compute the address of the final word of the string. - ~ - ~ It's a little bit difficult to get the start pointer right, since all - ~ our intermediate products affect what we get from value@, so we compute - ~ that just once, here at the beginning. - value@ 8 + - ~ (string so far, new character byte, pointer to start of string) - dup stringlen - ~ There are two concerns here that overlap: First, we always want at least - ~ one word. Recall that a length of zero bytes won't receive any alignment - ~ padding because it's already divisible by 8. Second, the result of - ~ stringlen doesn't include the null byte, which might be in a word by - ~ itself that needs to be counted. We can address both of them by - ~ unconditionally adding 1 to the length before applying alignment. - 1 + - ~ Pad the length for alignment. - 8 align-size - ~ We want an offset from the first word of the string to the last word of - ~ the string, so we subtract one word from the length. - 8 - + - ~ (string so far, new character byte, address of final word) - - ~ Examine the final word of the string, leaving other stuff undisturbed. - ~ Work low-to-high to figure out where to store the new byte, taking the - ~ first one that's available. - ~ (string so far, new character byte, address of final word) - dup @ dup 0x00000000000000FF & { 3roll | swap ! exit } unless - ~ (string so far, new character byte, address of final word, old value) - - ~ This next part is repeated several times, changing only the offsets, for - ~ bytes 1 through 6; bytes 0 (above) and 7 (way below) are different. - ~ (string so far, new character byte, address of final word, old value) - dup 0x000000000000FF00 & { 3roll 0x0000000000000100 * | swap ! exit } unless - dup 0x0000000000FF0000 & { 3roll 0x0000000000010000 * | swap ! exit } unless - dup 0x00000000FF000000 & { 3roll 0x0000000001000000 * | swap ! exit } unless - dup 0x000000FF00000000 & { 3roll 0x0000000100000000 * | swap ! exit } unless - dup 0x0000FF0000000000 & { 3roll 0x0000010000000000 * | swap ! exit } unless - dup 0x00FF000000000000 & { 3roll 0x0001000000000000 * | swap ! exit } unless - - ~ The top byte of the final word is always zero (or else stringlen - ~ wouldn't have called it the final word), so we don't need to check it, we - ~ can just use it. - ~ - ~ We need to put the new value in the top byte, which will mean we have no - ~ null terminator, so we also need to start a new word. - ~ - ~ There is a fiddly order-dependency here: unroll-past-string relies on - ~ being able to find the null terminator, which won't work if we've gotten - ~ rid of it. Also, calling it will move all the earlier words, including - ~ the one we intend to write to, which will invalidate any pointer we're - ~ keeping at that point. There's a few ways to resolve this; what we do is - ~ put the new terminator in place first, manually nudge the pointer, and - ~ then write the new value. - ~ (string so far, new character byte, address of final word, old value) - 3roll 0x0100000000000000 * | swap - ~ (string so far, new value, address of final word) - 0 3 unroll-past-string - ~ (new null terminator, string so far, new value, invalid address) - 8 - - ~ (new null terminator, string so far, new value, updated address) - ! ; - - -~ (byte -- boolean) -: is-space - dup 0x20 = { drop 1 exit } if - dup 0x09 = { drop 1 exit } if - dup 0x0a = { drop 1 exit } if - dup 0x0b = { drop 1 exit } if - dup 0x0c = { drop 1 exit } if - dup 0x0d = { drop 1 exit } if - drop 0 ; - - -~ (character -- 1 for true or 0 for false) -: is-alphanumeric - ~ We don't have a character-literal syntax; the hex constants here are - ~ ASCII codes. - dup 0x30 > { drop 0 exit } if ~ Less than "0". - dup 0x39 >= { drop 1 exit } if ~ Less than or equal to "9". - dup 0x41 > { drop 0 exit } if ~ Less than "A". - dup 0x5a >= { drop 1 exit } if ~ Less than or equal to "Z". - dup 0x61 > { drop 0 exit } if ~ Less than "a". - dup 0x7a >= { drop 1 exit } if ~ Less than or equal to "z". - drop 0 ; ~ Greater than "z". - - -~ Okay, this is the big one, the lexer! Wow. -~ -~ The only way this can ever return a zero-length string is if it hit EOF, -~ and callers can rely on that. -~ -~ (-- stack string occupying multiple words) -: word - ~ We allocate an empty string first, so that the result of "key" will - ~ conveniently be on the easy-to-find end of it. - 0 - - ~ Skip whitespace. - { key dup is-space } { drop } while - - ~ Early exit if it's an EOF. We leave the accumulated string on the stack; - ~ since we're not in the loop yet, it will be empty and this will function - ~ as the caller's indication we're at EOF. - dup -1 = { drop exit } if - - accumulate-string - - { - peek dup is-space { drop exit } if - - ~ If it's an EOF, exit, leaving the accumulated string on the stack. - ~ It's nonempty, since we're in the loop already, and from the caller's - ~ perspective it's valid input. - dup -1 = { drop exit } if - - consume accumulate-string - } forever ; - - - -~ (character -- value) -: generalized-digit-value - ~ We don't have a character-literal syntax; the hex constants here are - ~ ASCII codes. - dup 0x61 <= { 0x61 - 10 + exit } if ~ lowercase "a" - dup 0x41 <= { 0x41 - 10 + exit } if ~ uppercase "a" - 0x30 - ; ~ digit "0" - - -~ (character, base -~ -- value (if successful), -~ error indicator (zero equals success)) -: decode-generalized-digit - swap dup is-alphanumeric { - ~ It's alphanumeric. - ~ (base, character) - generalized-digit-value - ~ (base, value) - dup 3roll - ~ (value, value, base) - > { - ~ It's in range. - ~ (value) - 0 exit } if - ~ It's out of range. - ~ (value) - drop 1 exit } if - ~ It's not alphanumeric. - drop drop 1 ; - - -~ (string pointer, base -~ -- result (if successful), -~ error indicator (zero equals success)) -: read-base-unsigned - swap - - ~ If the first byte is null, this is an error - unpack8 - ~ (numeric base, current point in string, character) - dup 0 = { drop drop drop 1 exit } if - - ~ Decode the first byte as a generalized digit in the base. - ~ (numeric base, current point in string, character) - ~ If the first byte is less than "0", this is an error. - 3roll dup 4 unroll - ~ (numeric base, current point in string, character, numeric base) - decode-generalized-digit { - ~ (numeric base, current point in string) - drop drop 1 exit } if - - ~ The first byte is a valid generalized digit in the appropriate base, so - ~ let's get started. - ~ (numeric base, current point in string, initial value) - swap - - { - ~ (numeric base, result so far, current point in string) - unpack8 dup 0 = { - ~ A null after the first character is valid, and indicates we're done. - drop drop swap drop 0 exit } if - - ~ Decode the latest byte as a generalized digit in the base. - ~ (numeric base, result so far, current point in string, latest byte) - 4 roll dup 5 unroll - ~ (numeric base, result so far, current point in string, character - ~ numeric base) - decode-generalized-digit { - ~ If the latest character is not a valid digit, that's an error. - ~ (numeric base, result so far, current point in string) - drop drop drop 1 exit } if - - ~ The latest character is valid, so incorporate it and loop. - ~ (numeric base, result so far, current point in string, latest value) - 3roll 4 roll dup 5 unroll * + swap - } forever ; - - -~ (string pointer -~ -- result (if successful), -~ error indicator (zero equals success)) -: read-integer-unsigned - ~ We don't have a character-literal syntax; the hex constants here are - ~ ASCII codes. - dup unpack8 0x30 != { ~ digit "0" - ~ This is the case where the leading digit is not a zero. - ~ (original string pointer, advanced string pointer) - drop 10 read-base-unsigned exit } if - - ~ This is the case where the leading digit is a zero. - ~ (original string pointer, advanced string pointer) - unpack8 dup 0x78 = { ~ lowercase "x" - ~ (original string pointer, doubly advanced string pointer, character) - drop swap drop 16 read-base-unsigned exit } if - - dup 0x6f = { ~ lowercase "o" - ~ (original string pointer, doubly advanced string pointer, character) - drop swap drop 8 read-base-unsigned exit } if - - dup 0x62 = { ~ lowercase "b" - ~ (original string pointer, doubly advanced string pointer, character) - swap drop swap 2 read-base-unsigned exit } if - - ~ This is the case where the second character is something else. - ~ (original string pointer, doubly advanced string pointer, character) - drop drop 10 read-base-unsigned ; - - -~ (string pointer -~ -- result (if successful), -~ error indicator (zero equals success)) -: read-integer - ~ We don't have a character-literal syntax; this is ASCII for a hyphen. - dup unpack8 0x2d != { - ~ This is the case where it's non-negative. - ~ (original string pointer, advanced string pointer) - drop read-integer-unsigned exit - } if - - ~ This is the case where it's negative. - ~ (original string pointer, advanced string pointer) - swap drop read-integer-unsigned - ~ (result maybe, exit code) - dup { - ~ Failure - ~ (non-zero exit code) - exit - } if - - ~ Success - ~ (result, zero exit code) - swap -1 * swap ; - - -~ (string pointer -~ -- result (if successful), -~ error indicator (zero equals success)) -: read-decimal - ~ We don't have a character-literal syntax; this is ASCII for a hyphen. - dup unpack8 0x2d != { - ~ This is the case where it's non-negative. - ~ (original string pointer, advanced string pointer) - drop 10 read-base-unsigned exit - } if - - ~ This is the case where it's negative. - ~ (original string pointer, advanced string pointer) - swap drop 10 read-base-unsigned - ~ (result maybe, exit code) - dup { - ~ Failure - ~ (non-zero exit code) - exit - } if - - ~ Success - ~ (result, zero exit code) - swap -1 * swap ; - -~ Here, we allocate a single machine word's worth of space to use as the -~ backing store of a mutable variable, initialized to zero. Then we define the -~ variable which points to that address. -~ -~ We don't actually need a word header for interpreter-flags-storage, we -~ could just append a zero and point to it directly, but that would make life -~ harder for words that attempt to work with the contents of other words. So -~ we give it a name. - -s" interpreter-flags-storage" create make-hidden -here @ 0 , s" interpreter-flags" variable - - -~ There's an important bootstrapping concern: If you're loading this -~ interpreter into a running Evocation, it's important to not use the wrong -~ interpreter state value. The way we actually load this is under the log-load -~ transform, which will be running its alternate versions of these words and -~ therefore won't have trouble, but for the sake of making it easy to -~ experiment with modified versions of this file, we do the whole hide-show -~ dance. - -: [ interpreter-flags @ 0x01 invert & interpreter-flags ! - ; make-immediate make-hidden -latest @ -~ (pointer to [ entry) - -: ] interpreter-flags @ 0x01 | interpreter-flags ! - ; make-hidden -latest @ -~ (pointer to [ entry, pointer to ] entry) - -~ It may seem nonsensical to use : to define :, but the log-load transform -~ provides an alternate for it, so it works. The same, of course, goes for all -~ these other word-defining words. The syntax-centric ones such as : are here -~ in interpret.e because they need to interact with interpreter-flags, which -~ isn't defined before this point. -~ -~ If the ] at the end feels backwards, imagine to yourself that everything -~ that ISN'T defining a word body is part of an implicit [ ... ] sequence. -~ Doing so doesn't really change anything, but may make you happier. -: : word value@ create dropstring docol , make-hidden - [ dup entry-to-execution-token , ] ; - -~ The counterpart of : is ;. -: ; - ~ See commentary on "literal", in dynamic.e, regarding "lit exit". - ~ - ~ In regard to the magic comment, this is in the same category as strings - ~ and high-level flow control, where it's implemented in the base code here - ~ because that could be relevant to end-user code that compiles things - ~ without using the transforms, but in the regular compiler it's not used - ~ because the transforms override this whole implementation. - lit exit , ~ : -8 exit #-- (codeword pointer) - make-visible - ~ See above regarding [. Since it's an immediate word, we have to go to - ~ extra trouble to compile it as part of ;. Since it's also hidden, we have - ~ to go behind the interpreter's back to even get its entry pointer. - ~ - ~ Adding insult to injury, the log transform breaks , for unclear reasons, - ~ so we do that by hand as well. - [ over entry-to-execution-token , ] - ; make-immediate make-hidden -latest @ -~ (pointer to [ entry, pointer to ] entry, pointer to ; entry) - - -: ;asm - here @ pack-next 8 packalign here ! - make-visible - latest @ entry-to-execution-token dup 8 + swap ! - ~ See above. - [ 2 pick entry-to-execution-token , ] - ; make-immediate make-hidden -latest @ -~ (pointer to [ entry, pointer to ], pointer to ;, pointer to ;asm) - - -~ The word "'", often pronounced "tick", quotes the following word, looking -~ it up and treating it as a constant. In immediate mode, the constant winds -~ up on the stack; in compile mode it gets compiled. -~ -~ There are a few possible implementation strategies here. Running as an -~ immediate word means there's a clear and unambiguous concept of "the -~ following word", so that's what we do; otherwise we'd have to get clever -~ about somehow finding out where we were called from. That means we take on -~ what would otherwise be the interpreter's responsibility, of checking what -~ mode we're in. Happily, that's easy to do. -~ -~ There's a cyclic dependency where "if" relies on "'", and "'" relies on -~ "if". Fortunately flow-control is done with alternates by the log-load -~ transform, so we don't have to worry about it. -: ' word value@ find dropstring-with-result - interpreter-flags @ 0x01 & { literal } if - ; make-immediate - - -~ Let's have strings now. -: s" - consume - interpreter-flags @ 0x01 & { - [ s" litstring" find literal ] - ~ The magic comment isn't active in the compiler as-written, since the - ~ transformations do this bit themselves, but should still be here for - ~ completeness; it could affect other things people compile. - entry-to-execution-token , ~ : -8 litstring #-- (codeword pointer) - } if - here @ key { dup dup 0x22 != && } { pack8 key } while - drop 0 pack8 - interpreter-flags @ 0x01 & - { 8 packalign here ! } - { drop here @ } if-else - ; make-immediate - - -~ Finicky semantics, but also important. -: ." - ' s" entry-to-execution-token execute - interpreter-flags @ 1 & - { [ s" emitstring" find literal ] - ~ As with s", the magic comment is for completeness only. - entry-to-execution-token , ~ : -8 emitstring #-- (codeword pointer) - } { emitstring } if-else - ; make-immediate - - -~ While we're thinking about input, let's also have comments. -: ~ - key { dup dup 10 != && } { drop key } while drop - ; make-immediate - - -~ Now the single most important word... -: interpret - word - - ~ If no word was returned, exit. - dup 0 = { drop 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@ find - - ~ Check whether the word was found in the dictionary. - dup { - ~ If the word is in the dictionary, check what mode we're in, then... - dropstring-with-result - ~ (entry pointer) - interpreter-flags @ 0x01 & { - ~ ... if we're in compile mode, there's still a chance it's an immediate - ~ word, in which case we fall through to interpret mode... - dup entry-flags@ 1 & 0 = - - ~ ... but it's a regular word, so append it to the heap. - { entry-to-execution-token , exit } if - } if - - ~ ... if we're in interpret mode, or the word is immediate, run it. - entry-to-execution-token execute exit - } if - - ~ If it's not in the dictionary, check whether it's an integer literal. - drop - ~ As before, we get the stack address and use it as a string pointer. - ~ (string) - value@ read-integer 0 = { - ~ It's a number. - interpreter-flags @ 0x01 & { - ~ We're in compile mode; append first "lit", then the number, to the - ~ heap. The version of "lit" we use is the one that's current when we - ~ ourselves are compiled, hardcoded; doing a dynamic lookup would - ~ require dealing with what happens if it's not found. - dropstring-with-result - ' lit entry-to-execution-token - , , - 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 exit - } if - - ~ If it's neither in the dictionary nor a number, just print an error. - ." No such word: " value@ emitstring newline dropstring ; - -: quit r0 @ control! { interpret } forever ; - -~ Now we enable the three words we'd been keeping hidden. It would be a -~ good idea to call "quit" as soon as possible after this, but we leave it to -~ the user. -dup entry-flags@ 0x80 invert & swap entry-flags! -dup entry-flags@ 0x80 invert & swap entry-flags! -dup entry-flags@ 0x80 invert & swap entry-flags! -dup entry-flags@ 0x80 invert & swap entry-flags! - -~ Though we only do it once, this is a bit involved so we provide it as a -~ word. Notionally there are situations in which it could come up again, so -~ it seems worth having around. -~ -~ It actually needs to run as a compiled word no matter what; if it were -~ run in interpret mode it would cut itself off from the rest of itself. -~ However, if we didn't want to keep it around we could have it forget -~ itself... -~ -~ It depends on ', so it's here in interpret.e. -: relink-main-input-buffer-to-stdin - 1024 allocate dup main-input-buffer buffer-physical-start ! - main-input-buffer buffer-logical-start ! - 1024 main-input-buffer buffer-physical-length ! - 0 main-input-buffer buffer-logical-length ! - 0 main-input-buffer buffer-file-descriptor ! - [ s" refill-input-buffer-from-stream" - find entry-to-execution-token literal ] - main-input-buffer input-buffer-refill ! - ; - -~ Of course it is perfectly reasonable to change this, but for now it's -~ hardcoded. -relink-main-input-buffer-to-stdin - diff --git a/labels.e b/labels.e deleted file mode 100644 index 6ac26b2..0000000 --- a/labels.e +++ /dev/null @@ -1,296 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Machine label facility ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ Compilers and assemblers always have a need to resolve symbolic names for -~ parts of their code to numeric values. Usually, these symbolic names are -~ called labels. -~ -~ It's a surprisingly deep problem. The output itself can end up depending -~ on the actual values, for a variety of reasons. For example, the size of -~ a relative-jump instruction may vary depending on how far away its target -~ is, which changes the position of everything after. Or, there may be a size -~ limit on some particular segment and code may have to be entirely -~ reorganized to make things fit, splitting it into pieces or adding -~ trampolines. -~ -~ Often, this winds up being a hidden layer with immense complexity, -~ implemented as part of a linker, that even compiler maintainers find obscure -~ and confusing. -~ -~ It's Irenes' position that we should engage with complexity rather than -~ encysting it. So, in Evocation we take a different approach, heavily -~ inspired by the semantics of a tool called flatassembler. We provide -~ downstream code with the basic operations set-label and use-label which it -~ can combine in whatever order it wants. We also provide a harness, -~ label-loop, which takes an execution token for the downstream code -~ generator and runs it over and over, computing the mathematical fixed point -~ of the label assignments. -~ -~ On the first pass, label-loop guesses a value of zero for any label that's -~ used before it's set. On subsequent passes, each label starts with the value -~ it had on the previous pass. When we have a pass where labels end with the -~ same value they started with, we say they've converged, and we announce -~ success. If a hundred passes go by without convergence, we fail instead. -~ -~ Importantly, the label facility does not have an opinion on where or how -~ the values of labels should be output, nor does it have concepts of -~ dependency tracking or topological sorting. It only cares about the sequence -~ of set- and use-operations. Code relying on the facility is free to make -~ arbitrarily complex decisions about the layout, size, contents etc of its -~ output, and to use label values as part of those decisions. It is the -~ responsibility of this relying code to ensure the process converges, by -~ whatever means it wishes. -~ -~ Since the label facility is not directly involved in output, it is also -~ permissible for code relying on it to make retroactive changes to the -~ output, as long as all such changes are completed before returning control -~ to label-loop. -~ -~ Most of the time, the shorthand words L@' and L!' will be all you need to -~ use from your own code. - -~ The labels data structure is a linked list of dictionary entries, with -~ the same header format as the main Evocation dictionary, but instead of -~ being executable, each holds two words of data: status bits, and a value, -~ in that order. There's no "docol" pointer or anything of the sort. -~ -~ Status is a bit field: -~ bit zero is whether it's been used -~ bit one is whether it's been defined -~ bit two is whether it was used before being defined -~ bit three is whether the guessed value wound up equaling the actual value -~ -~ Just as the Evocation dictionary uses the global variable "latest" as a -~ handle (a pointer to a pointer) beginning a linked list of entries, so the -~ label dictionary also uses a handle variable, named "labels". We initialize -~ it here. -8 allocate s" labels" variable 0 labels ! - -~ This is analogous to word-heading, but prints label information. -~ (entry pointer --) -: label-heading - dup entry-to-name dup emitstring space - stringlen 1+ 54 swap - 0 max indent - entry-to-execution-token dup 8 + @ .hex64 space @ .hex8 - newline ; - -~ This prints the headings for all the labels that have been created. Note -~ that labels that have been created once stay in the dictionary forever, even -~ if subsequent passes neither use nor define them. That's because the control -~ loop has no way to know if they're still important; it's up to downstream -~ code to decide that. Everything has been carefully set up so that disused -~ labels don't hurt anything. -: list-labels - labels oldest-entry-in { dup } - { dup label-heading labels next-newer-entry-in } while drop ; - -~ This looks up a label by name if it exists, or returns 0 if it doesn't. -~ The return value if it's found is an entry pointer. -~ -~ Keep in mind that this is a pointer to the entry in the label dictionary, -~ not the label's value. It's common for a label's value to itself be a -~ pointer to a dictionary entry, in the program being compiled, so it's easy -~ to confuse that. -~ -~ (name string pointer -- label entry pointer) -: find-label labels swap find-in ; - -~ This creates a new label given a name for it, initializing its value and -~ status to zero and adding it to the label dictionary. This is responsible -~ for the initial guess of zero on the first pass. -~ -~ (name string pointer -- ) -: new-label labels create-in 0 , 0 , ; - -~ These helpers take a label entry pointer and return pointers to the status -~ and value fields. -: label-status entry-to-execution-token ; -: label-value entry-to-execution-token 8 + ; - -~ This looks up a label by name if it exists, or creates it if it doesn't. -~ Either way, it returns an entry pointer. It's named after the function -~ "intern" that many Lisp dialects have. -~ -~ (name string pointer -- label entry pointer) -: intern-label - dup find-label - dup { swap drop } - { drop dup new-label labels swap find-in } if-else ; - -~ This returns the value of a label, also doing all necessary status checks -~ and updates to keep track of the circumstances under which it was used. The -~ label loop relies on all read accesses going through this word. -~ -~ (label entry pointer -- label value) -: use-label - ~ If it hasn't been defined yet, mark it used-before-set. - dup label-status dup @ dup 0x02 & not - { 0x04 | swap ! } { drop drop } if-else - - ~ Mark it used. It's faster to just do this than to check if it's needed. - dup label-status dup @ 0x01 | swap ! - - ~ TODO putting a provide-label magic comment command here would be lovely - - ~ Return the guessed value. - label-value @ ; - -~ This overwrites the value of a label, also doing all necessary status -~ checks and updates to keep track of the cirumstances under which it was -~ set. The label loop relies on all write accesses going through this word. -~ -~ (new label value, label entry pointer --) -: set-label - dup label-status @ - ~ (new value, entry, initial status) - - ~ Exit, and print a diagnostic, if the label was already set on this pass. - ~ - ~ Without cooperation from user code, there's no great way to communicate - ~ up the call stack that execution should stop, so we don't try to. - dup 0x02 & { drop swap drop - ." Failed by attempting to redefine " - entry-to-name emitstring newline exit } if - - ~ We always set the defined bit to true. We leave the other status bits - ~ as-is, except that we check whether it's unused up to now, and whether - ~ the previous value equals the new value. If either of those holds, we set - ~ the guessed-equals-actual bit to true. - 0x02 | - ~ (new value, entry, updated status) - 3unroll dup 4 unroll label-value @ swap dup 3unroll = - ~ (entry, updated status, new value, equality) - 3roll dup 4 unroll 0x01 & not - ~ (entry, updated status, new value, equality, unused) - || { swap 0x08 | swap } if - ~ (entry, updated status, new value) - 3roll dup 3unroll - ~ (updated status, entry, new value, entry) - label-value ! label-status ! ; - -~ Since labels have dictionary entry headers but aren't in the main -~ dictionary, we get to use the entry flag bits for other things. The only one -~ we have right now is a feature that acts as a hint to anything trying to -~ display metadata about labels, to the effect that this one represents -~ something other than an offset in the file. -~ -~ (label entry pointer --) -: set-label-non-offset dup entry-flags@ 0x01 | swap entry-flags! ; -~ (label entry pointer -- boolean) -: is-label-non-offset entry-flags@ 0x01 & ; - -~ This is a convenience helper which downstream code can use to check how -~ many bytes it has output thus-far. -~ (output memory start, current output point -~ -- output memory start, current output point, offset) -: current-offset 2dup swap - ; - -~ This is a concise syntax for referencing the entry pointer of a label, -~ when you know its name statically. It reads a word of text input and calls -~ intern-label on it. -: L' - word value@ - interpreter-flags @ 0x01 & - { ' litstring entry-to-execution-token , - here @ swap packstring 8 packalign here ! - ' intern-label entry-to-execution-token , - dropstring } - { intern-label dropstring-with-result } if-else - ; make-immediate - -~ This is a concise syntax for calling use-label with a label whose name -~ you know statically. It performs L', then calls use-label. -: L@' - ' L' entry-to-execution-token execute - interpreter-flags @ 1 & - { ' use-label entry-to-execution-token , } - { use-label } if-else - ; make-immediate - -~ This is a concise syntax for calling set-label with a label whose name -~ you know statically. It performs L', then calls set-label. -: L!' - ' L' entry-to-execution-token execute - interpreter-flags @ 1 & - { ' set-label entry-to-execution-token , } - { set-label } if-else - ; make-immediate - -~ This is an internal helper that label-loop uses to check if a specific -~ label entry has "converged", based on its status bits. Downstream code won't -~ need to call this directly. -~ -~ For a label to have "converged", at least one of the following must be -~ true: -~ -~ 1. The label must never have been used (bit zero clear); -~ 2. The label was both used and defined, but not used before it was defined -~ (bits zero and one set; bit two clear); -~ 3. The label was both used and defined, and the guessed value equalled the -~ actual value (bits zero, one, and three set). -~ -~ (label entry pointer -- boolean) -: check-label-converged - label-status @ - dup 0x01 & not swap - dup 0x03 & 0x03 = swap dup 0x04 & not swap 3unroll && swap - 0x0b & 0x0b = - || || ; - -~ This is an internal helper that label-loop uses to check if the overall -~ label assignments have converged, based on their status bits. Downstream -~ code won't need to call this directly. -~ -~ This returns true if and only if check-label-converged returns true for -~ all the labels that have been created. -~ -~ (-- boolean) -: check-labels-converged - 1 - labels @ { dup } - { dup check-label-converged 3roll && swap - @ } while drop ; - -~ This is an internal helper that label-loop calls between passes, to update -~ the status bits and get ready for the next one. Downstream code won't need -~ to call this directly. -~ -: reset-labels - labels @ { dup } - { dup label-status 0 swap ! - @ } while drop ; - -~ This is the top-level word that invokes the entire label system. All the -~ code generation happens inside it. -~ -~ The execution token it's passed should have the interface: -~ -~ (output start, current output pointer -~ -- output start, current output pointer) -~ -~ In general, this is the same interface that code generation words should -~ use to communicate with each other. For example, all the words in elf.e -~ use this interface. -~ -~ (execution token -- output start, output length) -: label-loop - 0 swap - ~ TODO every time you double this to fix a crash, you must publicly - ~ apologize for deferring a real fix. those are the rules - 0x80000 allocate dup - ~ (iteration count, execution token, output start, output point) - { 3 pick 100 > } - { 2 pick execute 4 roll 1+ 4 unroll - - check-labels-converged - { 4 roll drop - 3 roll drop - current-offset swap drop - exit } if - drop dup - reset-labels } while - ~ TODO run some analysis on the labels to detect labels that are never - ~ defined, but are referenced. List them. - drop drop drop ." Failed after " . ." iterations." newline ; - diff --git a/language/dynamic/dynamic.e b/language/dynamic/dynamic.e new file mode 100644 index 0000000..270e860 --- /dev/null +++ b/language/dynamic/dynamic.e @@ -0,0 +1,560 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Dynamic definitions ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ This file provides additional facilities which are fundamental parts of +~ Evocation as a language, but which it's not possible to define until global +~ variables are available. Therefore it is incompatible with the label +~ transform, but compatible with the log-load transform and written to obey +~ its constraints; see compilation/transform.e for more details on that. +~ +~ The code here relies on the words "log", "s0", "r0", "latest", and "here". +~ These five global variables are the root of all our other data structures. +~ They are defined specially by warm-start in compilation/execution.e, since +~ there is no way to create regular definitions for them. Thus, they come to +~ us already set up. +~ +~ It may not be obvious, but when a regular docol-based Evocation word is +~ compiled, it hardcodes pointers to all the words it references, which will +~ be part of it forever after. Thus, these words can reference "here" and so +~ on, and they'll just know where to find it, no runtime mechanism for looking +~ it up is needed. That's important, because there are no good ways to build +~ such a mechanism! It would have to dedicate a register or something of that +~ nature, and registers are far too precious for such a use. +~ +~ In this file, we define a bunch of more sophisticated ways to work with +~ the log, then we use it to define a high-level flow control facility which +~ saves us from having to compute branch offsets by hand. Pleasantly, we get +~ to use this facility before it's actually defined, since the log-load +~ transform also provides it. That being the case, we might as well start with +~ whatever's most urgent - which is, of course, the debugging tools. + + +~ Debugging tools for real +~ ~~~~~~~~~~~~~~~~~~~~~~~~ + +: stack + s0 @ 8 - { dup value@ 8 + != } + { dup s0 @ 8 - != { space } if dup @ . 8 - } + while drop newline ; + +: stackhex + s0 @ 8 - { dup value@ 8 + != } + { dup s0 @ 8 - != { space } if dup @ .hex64 8 - } + while drop newline ; + +~ (pointer -- boolean) +: is-in-log dup log @ <= swap here @ > && ; + +~ (-- entry pointer or 0) +: oldest-entry + latest @ { dup @ } { @ } while ; + +~ (dictionary handle -- entry pointer or 0) +: oldest-entry-in + dup + dup { { dup @ } { @ } while } if + dup 3roll = { drop 0 } if ; + +~ (entry pointer -- entry pointer or 0) +: next-newer-entry + latest @ + 2dup = { 2drop 0 exit } if + { dup { 2dup @ != } if } + { @ } while swap drop ; + +~ (entry pointer, dictionary handle -- entry pointer or 0) +: next-newer-entry-in + @ + 2dup = { 2drop 0 exit } if + { dup { 2dup @ != } if } + { @ } while swap drop ; + +~ (entry pointer -- pointer) +: guess-entry-end + dup entry-flags@ 64 & 64 = { exit } if + dup next-newer-entry dup + { drop dup is-in-log { drop here @ } { drop } if-else + exit } unless + swap drop ; + +~ (pointer -- entry pointer or 0) +: containing-entry + dup is-in-log { drop 0 exit } unless + latest @ { dup { 2dup > over is-in-log && } { 0 } if-else } + { @ } while swap drop ; + +~ (entry pointer -- boolean) +: is-assembly-word + entry-to-execution-token dup 8 + swap @ = ; + +~ (entry pointer -- boolean) +: is-docol-itself + entry-to-name s" docol" stringcmp 0 = ; + +~ The word named "docol" has the job of returning the value that gets used +~ as the actual codeword. We make the assumption that the codeword will +~ point somewhere near the entry header; we allow for the possibility that +~ it might be before or after. +~ +~ Generally, it's possible for there to be several copies of docol due to +~ alternate logs and things like that, so the goal is to recognize any of +~ them. +~ +~ (entry pointer -- boolean) +: is-docol-codeword + dup is-in-log { drop 0 exit } unless + containing-entry dup + { dup is-docol-itself + { drop 1 } + { next-newer-entry dup { is-docol-itself } if } if-else + } if ; + + +~ TODO this only works on log words +~ +~ (entry pointer -- boolean) +: is-docol-interpreted-word + dup is-assembly-word { drop 0 exit } if + entry-to-execution-token @ is-docol-codeword ; + + +~ (pointer -- boolean) +: is-codeword-pointer + dup is-in-log { drop 0 exit } unless + dup containing-entry dup { 2drop 0 exit } unless + entry-to-execution-token = ; + + +~ (width --) +: indent { dup } { space 1- } while drop ; + +~ (entry pointer --) +: word-heading + dup entry-to-name dup emitstring space + stringlen 1+ 54 swap - 0 max indent dup .hex64 + dup entry-flags@ dup + { space + dup 0x80 & { s" H" emitstring } if + dup 0x40 & { s" M" emitstring } if + dup 0x01 & { s" I" emitstring } if + } if drop + dup is-assembly-word { s" asm" emitstring } + { dup is-docol-interpreted-word { s" raw" emitstring } unless + } if-else drop + newline ; + + +: list-dictionary + oldest-entry { dup } + { dup word-heading next-newer-entry } while drop ; + + +~ (byte -- boolean) +: is-printable + dup 0x20 <= swap 0x7F > && ; + + +~ (content end, content start, label start --) +: hexdump-row + 2 indent dup .hex32 dup 4 unroll + ~ (label start, content end, content start, label start) + 0 { dup 16 > } { + ~ (label start, content end, content start, label start, offset within row) + dup 7 & 0 = { space } if space + 2dup + dup 4 pick <= swap 5 pick > && + { 2dup + 8@ .hex8 } { space space } if-else + 1+ } while + drop + 2 indent s" |" emitstring + 0 { dup 16 > } { + ~ (label start, content end, content start, label start, offset within row) + 2dup + dup 4 pick <= swap 5 pick > && + { 2dup + 8@ + dup is-printable + { value@ emitstring } { s" ." emitstring } if-else + drop } + { space } if-else + 1+ } while + s" |" emitstring + newline 5 ndrop ; + + +~ (start, end --) +: hexdump-between + swap dup 16 1- invert & + { dup 3 pick > } + { 3dup hexdump-row 16 + } while 3 ndrop ; + + +~ (start, length --) +: hexdump-from swap dup 3unroll + hexdump-between ; + + +~ (start --) +: hexdump 64 hexdump-from ; + + +~ (entry pointer --) +: describe-hex + dup word-heading + dup guess-entry-end swap entry-to-execution-token + swap hexdump-between ; + + +~ (entry pointer --) +: describe-docol + dup word-heading + dup guess-entry-end swap entry-to-execution-token 8 + + { 2dup < } + { space dup @ dup is-codeword-pointer + { execution-token-to-entry entry-to-name emitstring } + { . } if-else + 8 + } while newline ; + + +~ (entry pointer --) +: describe + dup is-docol-interpreted-word + { describe-docol } { describe-hex } if-else ; + + +: describe-all + oldest-entry { dup } + { dup describe next-newer-entry } while drop ; + + +: describe-compilation + ~ It's always in progress ;) We just need a header like this so it doesn't + ~ get confused with other kinds of debug output. + ." compilation in progress" newline + latest @ hexdump + newline + ." here " here @ .hex64 newline + ." latest " latest @ .hex64 newline + ." name of latest: " latest @ entry-to-name emitstring newline + newline ; + + +: symbolize-pointer + dup is-in-log { + dup containing-entry dup is-in-log { + ~ Any format we're going to use here starts with the entry's name; by + ~ printing it now we don't have to keep track of it later. + dup entry-to-name emitstring + + dup entry-to-execution-token + ~ (scrutinee, entry pointer, codeword pointer) + dup 3 pick >= { + ~ The pointer is somewhere in the word's body, so we compute the + ~ offset from the codeword. + swap drop - + ~ (offset) + dup { + ." +" . + } { + ~ The pointer goes to the codeword. We don't print anything here, + ~ so the output is just the word's name. This will look "right" in + ~ a code listing styled like the ones produced by "describe". + drop + } if-else + } { + ~ The pointer is in the header, so we compute the offset from the + ~ entry address. + drop - + ~ (offset) + + ~ We always print the offset, even if it's zero; this visually + ~ emphasizes the difference between entry addresses and content + ~ addresses... or that's the hope. + ." :" . + } if-else + + ~ All of the above paths printed SOMETHING, so we're done. + exit + } { drop } if-else + } if + + ~ If we fall through, just print it as a number. + ." 0x" .hex64 ; + + +: list-callers + control@ r0 @ < + control@ log @ > || + { ." control stack pointer out of range: " control@ .hex64 newline } if + + control@ { dup r0 @ > } + { dup @ symbolize-pointer newline 8 + } while + drop ; + + + +: bye 0 sys-exit ; + + + +~ Log manipulation +~ ~~~~~~~~~~~~~~~~ + +~ In general, we're going to want to be able to go on little excursions +~ where we define utility words that are only useful for one task, then +~ deallocate that stuff after we're done with it. We implement "forget", +~ which removes both dictionary entries and log allocations for the entry +~ pointer it's given and everything that came after. +~ +~ The implementation strategy is the same as Jonesforth's version, but +~ Jonesforth runs in immediate mode and reads a word to operate on, whereas +~ ours takes an entry pointer and runs in either compiled or immediate +~ modes. +~ +~ (entry pointer --) +: forget dup @ latest ! here ! ; + +~ (value --) +: , here @ swap pack64 here ! ; + +~ We'll be defining a lot of immediate words, so we should set up a terse +~ way to do that. +: make-immediate latest @ dup entry-flags@ 0x01 | swap entry-flags! ; +: make-hidden latest @ dup entry-flags@ 0x80 | swap entry-flags! ; +: make-visible latest @ dup entry-flags@ 0x80 invert & swap entry-flags! ; +: make-metadata latest @ dup entry-flags@ 0x40 | swap entry-flags! ; + +~ Sooner or later we'll want to define recursive words; this one lets us +~ do that. It compiles into a call to the word that's currently being +~ defined (strictly speaking, the one whose definition was most recently +~ begun). +~ +~ TODO it seems like maybe the log-load transform breaks this? hm +: recurse latest @ entry-to-execution-token , ; make-immediate + + +~ The implementation of "find-in" is in language/static/core.e, since it's +~ used by the label and transformation facilities. Once we have full log +~ access, we get the nicety of using "find" instead. +~ +~ (string pointer -- entry pointer or 0) +: find latest swap find-in ; + + +~ Allocates bytes on the log by incrementing the global "here" pointer. The +~ "here" pointer is kept aligned to an 8-byte boundary, regardless of the size +~ requested. +~ +~ This does not create dictionary entries, it's just a raw memory interface. +~ It's suitable for allocating data or scratch space. +~ +~ (size -- pointer) +: allocate + here @ dup + ~ (size, here value, here value) + 3roll + 8 packalign here ! ; + + +~ Takes a string pointer which must be equal to the current value of "here", +~ indicating it is in the temporary allocation space, and allocates it +~ permanently by advancing "here" to the next aligned address after it. +~ +~ (string pointer -- string pointer) +: allocate-string + dup dup stringlen 1+ + 8 packalign here ! ; + + +~ Allocate space by incrementing "here", and output a word entry header in +~ it. Also add it to the "latest" linked list. Use zero as the flag values; +~ accept a string pointer on the stack and use its contents as the name. +~ +~ This is the first step of creating a new word. Its responsibility includes +~ everything up to the codeword, not including the codeword; it leaves things +~ all set up to start appending contents to the new word by calling ",". +~ +~ There's a handy diagram of the entry header format under "quick +~ reference", in the description of the execution model in +~ compilation/execution.e. Create is responsible for everything up to the +~ codeword, not including it. +~ +~ When a word is created in interpret mode using s" to provide a string +~ literal, the temporary space that s" uses is in the same place as the +~ entry header we're going to write out. It really is very useful to have +~ that work. Fortunately, it does! We're able to avoid needing a special case +~ by doing things in a very careful way, as described below. +~ +~ (string pointer --) +: create + ~ We add one to the string length in order to include the trailing null + ~ terminator. This will be the length of our name field; we save an extra + ~ copy of it to help with packing later. + dup stringlen 1 + dup 3unroll + ~ (name field length, string pointer, name field length) + + ~ We use memmove to put the string in its final position, because it works + ~ correctly when the destination overlaps with the source. Notice that we + ~ do this before writing anything else in the entry header, to avoid + ~ stepping on it. The name string always starts ten bytes into the header, + ~ so we can use a fixed offset. + here @ 10 + swap memmove + ~ (name field length) + + ~ Now we can get back to the fields that belong at the start of the entry + ~ header. We take the value of "here" and keep a working copy of it on the + ~ stack, which we'll advance every time we write more bytes. + here @ + ~ (name field length, updated "here" pointer) + + ~ Pack the old value of "latest" as the first field of the header, linking + ~ from the newly-defined word to the next-newest word. + ~ + ~ All the entries form a linked list, from newest to oldest. Since the + ~ link is the first field in the entry header, you can get from each entry + ~ to the one before it just by dereferencing the entry pointer. + latest @ pack64 + + ~ This is the flags byte. It starts at zero; our caller can change it if + ~ desired. + 0 pack8 + + ~ This is the "other" null terminator, used when traversing the name + ~ string backwards for execution-token-to-entry. Yes, the name is + ~ null-terminated at both ends. + 0 pack8 + + + ~ The name field is already populated, so just skip past it. + ~ (updated "here" pointer) + + ~ The codeword is aligned to a machine-word boundary, and the padding for + ~ it is create's responsibility. + ~ + ~ By adding the null terminator before adding alignment padding, we've + ~ made sure there's always at least one null byte. Otherwise we'd be missing + ~ the terminator if by chance the name were exactly the wrong length. + 8 packalign + ~ (updated "here" pointer) + + ~ Retrieve the value of "here", which still doesn't reflect our additions, + ~ and store it at the adddress of "latest". It's the start of our + ~ newly-defined word, which makes it the latest word. + here @ latest ! + + ~ Finally, we write our updated value of "here" back into the variable. + here ! ; + + +~ Notionally, it might make sense to define "create" in terms of +~ "create-in". Any change like that is being postponed to after the removal +~ of flatassembler, when refactorings will be easier. +~ +~ The dictionary handle points to a pointer to the first item. +~ +~ (string pointer, dictionary handle --) +: create-in + dup @ here @ swap pack64 +~ (name string pointer, dictionary handle, output point) + 0 pack8 0 pack8 + 3roll packstring + 8 packalign +~ (dictionary handle, output point) + swap here @ swap ! +~ (output point) + here ! + ; + + +: self-codeword here @ 8 + , ; + + +~ A variable is simply a word that returns a specific address, always the +~ same one, at which a value can be stored. This word "variable" takes and +~ address and a word name, and defines the word. Allocating space is its +~ caller's responsibility. +~ +~ TODO the address is constant but the contents vary, confusing, write it up +~ +~ (address for new variable word to point to, string pointer --) +: variable + create + self-codeword + here @ + swap :rax mov-reg64-imm64 + :rax push-reg64 + pack-next + 8 packalign + here ! ; + + +~ A keyword is a word that evaluates to its own address, which makes it +~ suitable for use as a constant. By convention, all our keywords have names +~ starting with a colon, which imitates the way they work in Common Lisp. +~ +~ Specifically, it returns its own execution token. Thus, executing its +~ result repeatedly will keep giving the same value. We aren't in the habit of +~ doing quote-exec kinds of things in Evocation, but it seems as good as any +~ other unique value, so we might as well. +~ +~ Unlike CL, we don't currently have the lexer automatically create keywords +~ for us; we create them explicitly. That's likely to be added at some point, +~ but at the moment the feature is lying fallow to see whether it winds up +~ seeing a lot of use. +~ +~ (string pointer --) +: keyword + create + + ~ Before outputting our codeword, save a copy of the address where it's + ~ going to be. That will be the execution token we return. + here @ dup + ~ (self execution token, output point) + + ~ Now add a codeword. This is an assembly word, so it's a self-codeword, + ~ meaning it points to the word right after itself. + dup 8 + pack64 + ~ (self execution token, output point) + + ~ Now we consume the execution token, using it as part of this instruction. + swap :rax mov-reg64-imm64 + ~ (output point) + + ~ To return it, we push it to the stack. + :rax push-reg64 + + ~ Now just the normal stuff every assembly word ends with. + pack-next + 8 packalign + + here ! ; + + +~ Although we will eventually define the word "'" to give us the symbol of +~ a word, it will rely on being able to compile a literal. Rather than do lots +~ of string processing later, we choose to define this word now to avoid +~ having to look up the word "lit" as part of that. +~ +~ It may be slightly surprising that the construction "lit lit" works as +~ expected, given that ie. "lit 5" will break, as will "lit [", so it's worth +~ explaining why it does. +~ +~ In most respects "lit" is just an ordinary word, which compilation turns +~ into a pointer to its codeword. That's what happens to most words, if +~ they're not a special syntax nor flagged as immediate. It just happens to be +~ a word that it rarely makes sense to use directly, since its purpose is to +~ be generated as part of the output when compiling number literals. The +~ special behavior around number literals is that when "interpret" sees ie. +~ "5", it first compiles "lit", then appends the numeric value 5 as the +~ following item in the compiled word body. +~ +~ The job of "lit" when it's later executed is to push the appropriate value +~ onto the stack and ensure that it doesn't get executed as code. So, whatever +~ you put immediately after it gets treated as a value, even if it's a +~ pointer. +~ +~ The reason that writing "lit 5" in Evocation syntax crashes is that it +~ gets turned into "lit lit 5" when compiled, which treats the second "lit" as +~ a value then tries to use "5" as a codeword pointer. So you can use "lit" +~ to quote whatever you want, it's just if it's already a special syntax you +~ might need to go behind "interpret"'s back to get it into the compiled +~ output. In practice, this is likely the only place that needs to happen, but +~ the mechanism is documented for the sake of whatever comes up in the future. +~ +~ (value -- ) +: literal lit lit , , ; + diff --git a/language/dynamic/files.e b/language/dynamic/files.e new file mode 100644 index 0000000..2a8c7c3 --- /dev/null +++ b/language/dynamic/files.e @@ -0,0 +1,161 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ File manipulation ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ This file has high-level features for working with files and the +~ filesystem. There's a tension as to what belongs here vs. what belongs in +~ language/dynamic/input.e or language/static/output.e, and it's likely there +~ will be some refactoring as the boundaries become clear. + + +~ (output point, filename -- output point) +: pack-file-contents + dup 0 0 sys-open + ~ (output point, filename, open result code or file descriptor) + dup 0 > { + ." Couldn't open " swap emitstring space + ." because " space . ." ." newline + 2 ndrop exit + } if + + ~ (output point, filename, file descriptor) + { + dup 3 pick 1024 sys-read + ~ (output point, filename, file descriptor, read result code or length) + + dup 0 > { + over sys-close drop + ~ Ignore a failed close. + + ." Error while reading from " 3roll emitstring + ." because " space . ." ." newline + drop exit + } if + + dup 0 = { + over sys-close drop + ~ Ignore a failed close. + + 3 ndrop exit + } if + + 4 roll + 3unroll + } forever ; + + +~ TODO probably make this more similar to pack-file-contents +~ (delimiter pointer, buffer size -- buffer address) +: read-to-buffer + dup allocate dup dup + ~ (buffer size, buffer address, word start, output point) + { key + ~ Exit if it's a zero byte. + dup not { + ~ Make sure to pack the zero to serve as a null terminator. + pack8 + drop drop swap drop swap drop exit } if + + ~ If it's a space character, we need to check if we just consumed the + ~ magic word, and do some handling to reset the word tracking. + dup is-space + { ~ (buffer size, buffer address, word start, output point, key) + ~ Tuck the key out of the way until we've done some stuff. + 3unroll + + ~ Add a null terminator so we can use stringcmp + dup 0 swap 8! + + ~ Check for the magic word. + over 6 pick stringcmp 0 = + { ~ It's magic, so exit. + ~ Make sure to pack a zero to serve as a null terminator. + 0 pack8 + drop drop drop swap drop swap drop exit } + { ~ It's not magic, so reset the word start. Of course whitespace is + ~ not a word but this will help us keep track of things. + 3roll pack8 + swap drop dup } if-else } + { ~ (buffer size, buffer address, word start, output point, key) + ~ Tuck the key out of the way again. + 3unroll + ~ Check if the word just started and the previous character is space. + 2dup = dup { drop dup @ is-space } if + { ~ If so, this is the actual first character of the word. + drop swap pack8 dup } + { ~ If not, leave the word start alone. + 3roll pack8 } if-else } if-else } forever ; + + +~ In logical terms, this modifies an input buffer metadata structure +~ in-place to push a new, zeroed one into the start of the linked list formed +~ through the next-source field. +~ +~ In physical terms, it works by allocating a new structure, copying the +~ fields of the existing one into it, and zeroing the existing one. That's +~ necessary because otherwise we'd need a mutable handle (a pointer to a +~ pointer) to update the start of the list, and there's no way to do that with +~ the main-input-buffer variable working the way it presently does. +~ +~ (input buffer metadata pointer --) +: push-input-buffer + allocate-input-buffer-metadata + ~ (original metadata pointer, new metadata pointer) + 2dup 7 8 * memcopy + ~ (original metadata pointer, new metadata pointer) + swap dup zero-input-buffer-metadata + input-buffer-next-source ! ; + + +~ This does the inverse of push-input-buffer. In the event that the +~ next-source field is null, it zeroes the buffer. +~ +~ Note, however, that it doesn't deallocate the memory, because that's not +~ how memory allocation on the log works. If necessary, it can be deallocated +~ with "forget", though as usual that requires careful planning. +~ +~ (input buffer metadata pointer --) +: pop-input-buffer + dup input-buffer-next-source @ + ~ (original metadata pointer, next source metadata pointer) + dup { swap 7 8 * memcopy } + { drop zero-input-buffer-metadata } if-else ; + + +: default-buffer-size 1024 ; + +~ (input buffer metadata pointer, file descriptor --) +: attach-input-buffer-to-file-descriptor + over buffer-file-descriptor ! + ~ (metadata pointer) + default-buffer-size allocate dup 2 pick buffer-physical-start ! + ~ (metadata pointer, buffer pointer) + over buffer-logical-start ! + ~ (metadata pointer) + default-buffer-size over buffer-physical-length ! + 0 over buffer-logical-length ! + ' refill-input-buffer-from-stream entry-to-execution-token + swap input-buffer-refill ! ; + + +~ Zero indicates success, nonzero indicates failure. +~ +~ (filename -- *, success) +: include + dup 0 0 sys-open + dup 0 > { + ." Couldn't open " swap emitstring space + ." because " space . ." ." newline + drop 1 exit + } if + ~ (file descriptor) + + main-input-buffer dup push-input-buffer + swap attach-input-buffer-to-file-descriptor + + { peek -1 != } { interpret } while + + main-input-buffer buffer-file-descriptor @ sys-close drop + ~ Ignore a failed close. + + main-input-buffer pop-input-buffer 0 ; + diff --git a/language/dynamic/flow-control.e b/language/dynamic/flow-control.e new file mode 100644 index 0000000..d4a9dd3 --- /dev/null +++ b/language/dynamic/flow-control.e @@ -0,0 +1,151 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ High-level flow-control ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ We use a novel suffix-based approach to flow control. We define words +~ { and } which describe the boundaries of blocks of code, leaving a +~ description on the value stack, while still compiling the contents +~ normally. +~ +~ Then follow-up words such as "if" can use that information to slide +~ the blocks around and insert any needed branches and other logic. +~ +~ Both the label transform and the log-load transform go out of their way +~ to make sure these words work. Because of that, we actually get to use these +~ before defining them... just keep in mind nothing under the transform is +~ calling THESE versions. + + +~ (-- start pointer) +: { here @ ; make-immediate + +~ (start pointer -- start pointer, length) +: } dup here @ swap - ; make-immediate + + +~ (start pointer, length --) +: if + 2dup swap dup 5 8 * + 3roll + ~ (start pointer, length, start pointer, adjusted start pointer, length) + memmove + ~ (start pointer, length) + + swap here @ swap here ! swap + ~ (old here, length) + + ' lit entry-to-execution-token , 0 , + ' != entry-to-execution-token , + + ~ 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. + ' 0branch entry-to-execution-token , dup 8 + , + ~ (old here, length) + + drop 5 8 * + here ! + ; make-immediate + + +~ (start pointer, length --) +: unless + 2dup swap dup 5 8 * + 3roll + ~ (start pointer, length, start pointer, adjusted start pointer, length) + memmove + ~ (start pointer, length) + swap here @ swap here ! swap + ~ (old here, length) + ' lit entry-to-execution-token , 0 , + ' = entry-to-execution-token , + ~ 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. + ' 0branch entry-to-execution-token , dup 8 + , + ~ (old here, length) + drop 5 8 * + here ! ; make-immediate + + +~ (true start, true length, false start, false length --) +: if-else + + ~ 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 + ~ (true start, true length, false start, false length) + 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) + ' lit entry-to-execution-token , 0 , + ' != entry-to-execution-token , + ~ Branch past the length field, the true-block, and the unconditional + ~ branch in the middle. + ' 0branch entry-to-execution-token , + 3roll dup 4 unroll 3 8 * + , + + ~ Next, write out the unconditional branch in the middle. + swap dup 3unroll 5 8 * + here ! + ' branch entry-to-execution-token , + ~ Branch past the length field and the false-block. + dup 8 + , + + ~ Set "here" to point to the true end. + drop drop drop drop 7 8 * + here ! + ; make-immediate + + +~ (start, length --) +: forever + ' branch entry-to-execution-token , 8 + -1 * , drop + ; make-immediate + + +~ This slides the body forward, leaving the test where it is. It puts a +~ conditional branch in-between them, then appends an unconditional branch +~ at the end. +~ +~ (test start, test length, body start, body length --) +: while + ~ 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) + ' lit entry-to-execution-token , 0 , + ' != entry-to-execution-token , + ~ Branch past the length field, the body, and the unconditional branch. + ' 0branch entry-to-execution-token , + dup 3 8 * + , + ~ Set "here" to the new end. + 5 8 * 6 roll + here ! + ~ (test start, test length, body start, body length) + ~ Unconditionally branch backwards past the branch word, the body, the + ~ conditional branch, and the test. + ' branch entry-to-execution-token , + 6 8 * + swap drop + swap drop -1 * , + ; make-immediate + + +~ This is a helper which does non-local exit by directly overwriting the +~ control stack, then calling regular "exit" (implicitly as part of its own +~ semicolon). The name "nexit" is short for n-exit, meaning that it takes a +~ parameter which tells it how many times to exit. +~ +~ 1 nexit is equivalent to regular "exit". 2 nexit is equivalent to asking +~ your own caller to exit. 0 nexit does nothing. +~ +~ This style of programming isn't encouraged, but may be useful when doing +~ code that transforms other code. +~ +~ This is much lower-level than the other flow-control stuff, but it isn't +~ compatible with the label transform due to relying on r0, so it needs to go +~ somewhere other than language/static/core.e, and this was the closest fit. +~ +~ Anecdotally, this feature is traditionally called "shunt", and sometimes +~ "rdrop". +~ +~ (count --) +: nexit 8 * control@ + r0 @ min control! ; + diff --git a/language/dynamic/input.e b/language/dynamic/input.e new file mode 100644 index 0000000..9d73c16 --- /dev/null +++ b/language/dynamic/input.e @@ -0,0 +1,289 @@ +~ ~~~~~~~~~~~~~~~~~~~ +~ ~~ Input streams ~~ +~ ~~~~~~~~~~~~~~~~~~~ + +~ (pointer to buffer metadata -- pointer to buffer "physical-start" field) +: buffer-physical-start ; + ~ The physical-start field happens to be the first thing in the metadata, so + ~ this is an nop, but it still exists as a word because having it reduces + ~ confusion. +~ (pointer to buffer metadata -- pointer to buffer "physical-length" field) +: buffer-physical-length 8 + ; +~ (pointer to buffer metadata -- pointer to buffer "logical-start" field) +: buffer-logical-start 2 8 * + ; +~ (pointer to buffer metadata -- pointer to buffer "logical-length" field) +: buffer-logical-length 3 8 * + ; +~ (pointer to buffer metadata -- pointer to buffer "file-descriptor" field) +: buffer-file-descriptor 4 8 * + ; +~ (pointer to input buffer metadata -- pointer to input buffer "refill" field) +: input-buffer-refill 5 8 * + ; +~ (pointer to input buffer metadata +~ -- pointer to input buffer "next-source" field) +: input-buffer-next-source 6 8 * + ; + + +~ Given an initialized buffer (input or otherwise), sets its logical-start +~ and logical-length fields to indicate the buffer is empty. This relies on +~ the buffer having a backing store attached, but does not alter the backing +~ store or its contents. +~ +~ (pointer to buffer metadata --) +: clear-buffer + dup buffer-physical-start @ swap + ~ (address of backing store, metadata pointer) + dup 3unroll + ~ (metadata pointer, address of backing store, metadata pointer) + buffer-logical-start ! + buffer-logical-length 0 swap ! ; + + +~ Sets all fields in an input buffer metadata structure to their default +~ values, mostly zero, effectively detaching and leaking any backing store +~ that had been attached to it. Suitable for use during initialization. +~ +~ (pointer to input buffer metadata --) +: zero-input-buffer-metadata + dup buffer-physical-start 0 swap ! + dup buffer-physical-length 0 swap ! + dup buffer-logical-start 0 swap ! + dup buffer-logical-length 0 swap ! + dup buffer-file-descriptor -1 swap ! + dup input-buffer-refill 0 swap ! + ~ Notice the absence of a dup this time. + input-buffer-next-source 0 swap ! ; + + +~ Allocates input-buffer metadata, with no backing store attached. +~ Initializes the metadata to all zeroes. +~ +~ (-- pointer to input buffer metadata) +: allocate-input-buffer-metadata + 7 8 * allocate + dup zero-input-buffer-metadata ; + + +~ Allocates input buffer metadata and a backing store, in one operation. +~ Points the metadata to the backing store. +~ +~ (buffer capacity in bytes -- pointer to input buffer metadata) +: allocate-input-buffer + dup 7 8 * + allocate + dup zero-input-buffer-metadata + ~ (capacity in bytes, metadata pointer) + dup dup 7 8 * + + ~ (capacity in bytes, metadata pointer, metadata pointer, physical start) + swap buffer-physical-start ! + ~ (capacity in bytes, metadata pointer) + dup 3unroll buffer-physical-length ! + ~ (metadata pointer) + dup clear-buffer ; + + +~ Sets the backing store of an input buffer to point at a null-teriminated +~ string and read from it. +~ +~ (buffer metadata pointer, string pointer --) +: attach-string-to-input-buffer + swap + ~ (string pointer, metadata pointer) + 2dup buffer-physical-start ! + ~ (string pointer, metadata pointer) + 2dup buffer-logical-start ! + ~ (string pointer, metadata pointer) + swap stringlen swap + ~ (string length, metadata pointer) + 2dup buffer-physical-length ! + ~ (string length, metadata pointer) + dup 3unroll buffer-logical-length ! + ~ (metadata pointer) + -1 swap buffer-file-descriptor ! ; + + +~ (metadata pointer --) +: consume-from + ~ If the length is zero, exit without doing anything. + dup buffer-logical-length @ 0 = { drop exit } if + + ~ Decrement the logical length. We do this now to get it over with, since + ~ adjusting the start pointer is more complex. + dup buffer-logical-length dup @ 1 - swap ! + ~ (metadata pointer) + + ~ We compute the physical end. We'll need it in adjusting the logical start, + ~ and doing it now means less stack juggling later. + dup dup buffer-physical-start @ swap buffer-physical-length @ + swap + ~ (physical end, metadata pointer) + + ~ Compute the incremented logical start. + dup buffer-logical-start @ 1 + + ~ (physical end, metadata pointer, updated start pointer) + + ~ Check whether the updated start is equal to the physical end. + dup 4 roll = + ~ (metadata pointer, updated start, updated start, physical end) + { + ~ If the logical start pointer is now equal to the physical end pointer, + ~ we want to wrap to the physical start. That's what makes it a circular + ~ buffer. + ~ (metadata pointer, updated start) + drop dup buffer-physical-start @ + } if + + ~ However we got here, save the updated logical start pointer. + ~ (metadata pointer, updated start) + swap buffer-logical-start ! ; + + +~ We use -1 as a return value to indicate end-of-file. This can be +~ distinguished from valid data, because it's a full 64 bits, whereas a byte +~ of 0xFF wouldn't be. +~ +~ (metadata pointer -- byte or -1) +: peek-from + dup buffer-logical-length @ { + ~ If the length is zero, there is no input, but we can still try calling + ~ the "refill" word. + ~ (metadata pointer) + dup input-buffer-refill @ dup { + ~ If the refill word is zero, we can't help, just return EOF. + ~ (metadata pointer, refill word) + drop drop -1 exit + } unless + + ~ If the refill word is nonzero, call it. It expects a copy of the metadata + ~ pointer as its parameter, so set that up. + ~ (metadata pointer, refill word) + swap dup 3roll execute + ~ (metadata pointer) + ~ Now we check if the length is still zero. + dup buffer-logical-length @ { + ~ The length is zero even after calling the refill word, so return EOF. + ~ (metadata pointer) + drop -1 exit + } unless + } unless + + ~ The buffer is non-empty, so read a byte from it. We might have reached + ~ this point either from the original check, or from the second check after + ~ calling the refill word. + ~ + ~ While it might be more extensible to call an "unpack" word here, such as + ~ unpack8, we actually just want to get the value, and delegate the pointer + ~ adjustments to "consume". + ~ + ~ (metadata pointer) + buffer-logical-start @ 8@ ; + + +~ Just as with peek-from, we use -1 for EOF. +~ +~ (metadata pointer -- byte or -1) +: key-from + dup peek-from + ~ (metadata pointer, result byte) + ~ We unconditionally consume, because we have no way to distinguish between + ~ reading a zero byte and having nothing left to read. + swap consume-from ; + + +~ If the buffer is empty, make sure its logical position is at the +~ physical start. Otherwise, leave it alone. +~ +~ (metadata pointer --) +: normalize-buffer + dup buffer-logical-length @ 0 = + { dup buffer-physical-start @ swap + buffer-logical-start ! } { drop } if-else + ; + + +~ Find the next contiguous area of a buffer to write incoming data to. +~ This will begin at the logical end. Depending on the order things are in, +~ the available space might run from there to the physical end, or to the +~ logical start. Those are the only two possibilities. +~ +~ If the buffer is full, this will return as normal but the length will +~ be zero. The caller should make sure to respect that. +~ +~ (metadata pointer -- destination start, destination length) +: compute-next-buffer-free-block + dup buffer-physical-start @ swap dup buffer-physical-length @ + swap 3unroll + swap + ~ (physical end, metadata pointer) + dup buffer-logical-start @ swap dup buffer-logical-length @ + swap 3unroll + swap 3unroll + ~ (metadata pointer, physical end, logical end not yet wrapped) + + 2dup >= { + ~ If the logical end is greater than or equal to the physical end, find + ~ where it wraps to and start from there. + swap - swap dup buffer-physical-start @ swap 3unroll + + ~ (metadata pointer, destination start) + ~ In this scenario, the logical start is the end of the free space, so + ~ compute how far away it is. + dup 3roll + ~ (destination start, destination start, metadata pointer) + buffer-logical-start @ swap - + } { + 3roll drop + dup 3roll swap - + ~ If the logical end is less than the physical end, it is the destination; + ~ the physical end is also the end of the free space, so compute how far + ~ away it is. + } if-else ; + + +~ (metadata pointer --) +: refill-input-buffer-from-stream + dup normalize-buffer + dup compute-next-buffer-free-block + ~ (metadata pointer, destination start, destination length) + ~ Check whether the buffer is full. If not, do a read. If so, that's not + ~ an error, just clean up and take no action. + dup { swap + ~ (metadata pointer, destination length, destination start) + { 3 ndup 3roll buffer-file-descriptor @ 3unroll swap sys-read + ~ (metadata pointer, destination length, destination start, + ~ read result) + dup 0 > { + dup -4 = + { + ~ This is the EINTR case, so we're supposed to try the same + ~ read again. To that end, this whole thing is running in a + ~ loop, and all the other paths exit. + drop + ~ (metadata pointer, destination length, destination start) + } + { drop drop drop drop + ." Read error." 0 sys-exit } if-else } + { 3unroll drop drop + ~ (metadata pointer, read result) + swap dup buffer-logical-length @ 3roll + + ~ (metadata pointer, adjusted logical length) + swap buffer-logical-length ! exit } if-else } forever } + { drop drop drop } if-else ; + + + +~ Here we have some imperative code that runs immediately, to initialize +~ some runtime data structures. +~ +~ First, we insert a metadata word header to delimit the space. Otherwise +~ "describe" would crash when attempting to describe +~ "attach-string-to-input-buffer". + +s" main-input-buffer-metadata" create +s" main-input-buffer-metadata" find 0x01 swap entry-flags! + +~ Having done that, now we do the runtime allocation. Then we also define +~ the variable "main-input-buffer" so we can find it again. +allocate-input-buffer-metadata +s" main-input-buffer" variable + +~ We'll leave it to warm-start, in compilation/execution.e, to attach the +~ buffer. It's easier that way. + +: peek main-input-buffer peek-from ; +: consume main-input-buffer consume-from ; +: key main-input-buffer key-from ; + diff --git a/language/dynamic/interpret.e b/language/dynamic/interpret.e new file mode 100644 index 0000000..0af0dab --- /dev/null +++ b/language/dynamic/interpret.e @@ -0,0 +1,599 @@ +~ ~~~~~~~~~~~~~~~~~ +~ ~~ Interpreter ~~ +~ ~~~~~~~~~~~~~~~~~ +~ +~ The code in this file defines the basic syntax and semantics of Forth as +~ a text-based language. It's written in terms of the underlying executor, +~ which is implemented and explained in compilation/execution.e and +~ language/static/execution-support.e. The execution model gives us the +~ concept of "words"; the control and value stacks; and the ability to call +~ things. It has nothing to say about text, only about the binary form of the +~ language. +~ +~ It's traditional in Forth to refer to an act of "compiling" code, which +~ in this context means turning it from text into its binary representation. +~ That binary representation most commonly takes the form of a word entry +~ header followed by an array of codeword pointers. +~ +~ It would be legitimate to critique the terminology by saying that codeword +~ pointers are still, in some sense, interpreted: They are not machine code to +~ be directly executed by the CPU; they rely on "docol" and "next" at runtime. +~ However, in language design circles, the term "compilation" takes on a +~ broader meaning, referring to any process which requires some or all of the +~ types of infrastructure we regard as being compiler internals: A successive +~ translation of code from one form into another, discarding some types of +~ information while computing others, in a careful order that results in +~ logically consistent output which in some sense has the same meaning as the +~ input. Sometimes this output may be machine code, but often it is another +~ language meant for human consumption, or an intermediate layer meant to be +~ fed into another process. +~ +~ Forth compilation is compilation in this sense, so there is no conflict +~ and we run with the established terminology. In addition, it must be noted +~ that Evocation, like many Forths, makes extensive use of words which are +~ implemented directly in machine code; the Forth execution model allows these +~ words to co-exist with words that are interpreted by "docol". +~ +~ At any rate, the code in this file is responsible for that compilation. +~ +~ It is primarily concerned with managing the contents of an area of memory +~ we call the "log"; see language/static/log-load.e for more detail on +~ terminology. + +~ As a convenience for "word", we have some facilities for working with +~ stack-allocated strings. Yeah, trippy concept. Also, it would be a +~ buffer overrun hazard if we were worried about that, which is why this +~ is no longer common practice in C. +~ +~ The most important of these is accumulate-string, but we need some +~ smaller pieces first. + +~ (stack string..., items to be left alone..., item to be unrolled, +~ number of items above string that participate in the unroll +~ -- item that was unrolled, stack string..., items left alone) +: unroll-past-string + 8 * + ~ (string, other items, top item, byte offset to string start) + dup value@ + + ~ We have two copies of the offset present, in addition to the stuff we want + ~ to rotate. So, the actual string starts two words on... We could have + ~ adjusted the offset instead, but we'll want the unmodified offset again + ~ later. + 16 + + ~ (string, other items, top item, offset to start, string pointer) + stringlen + ~ Same reasoning as in accumulate-string (see below). + 1 + 8 align-size + ~ (string, other items, top item, offset to start, string length w/ padding) + + 8 /% swap drop + ~ (string, other items, top item, number of words to unroll) + unroll ; + + + +~ (stack string..., item to be swapped +~ -- item that was swapped, stack string...) +: swap-past-string 1 unroll-past-string ; + + +~ (stack string... --) +: dropstring + value@ stringlen + ~ Same reasoning as in accumulate-string (see below). + 1 + 8 align-size value@ + + ~ At the time we fetched the stack pointer, there was an extra value atop + ~ it, so we have to add one more word. + 8 + value! ; + + +~ (stack string..., item to be kept +~ -- item that was kept) +: dropstring-with-result swap-past-string dropstring ; + + +~ (stack string-so-far..., new character byte +~ -- updated string-so-far) +: accumulate-string + ~ Compute the address of the final word of the string. + ~ + ~ It's a little bit difficult to get the start pointer right, since all + ~ our intermediate products affect what we get from value@, so we compute + ~ that just once, here at the beginning. + value@ 8 + + ~ (string so far, new character byte, pointer to start of string) + dup stringlen + ~ There are two concerns here that overlap: First, we always want at least + ~ one word. Recall that a length of zero bytes won't receive any alignment + ~ padding because it's already divisible by 8. Second, the result of + ~ stringlen doesn't include the null byte, which might be in a word by + ~ itself that needs to be counted. We can address both of them by + ~ unconditionally adding 1 to the length before applying alignment. + 1 + + ~ Pad the length for alignment. + 8 align-size + ~ We want an offset from the first word of the string to the last word of + ~ the string, so we subtract one word from the length. + 8 - + + ~ (string so far, new character byte, address of final word) + + ~ Examine the final word of the string, leaving other stuff undisturbed. + ~ Work low-to-high to figure out where to store the new byte, taking the + ~ first one that's available. + ~ (string so far, new character byte, address of final word) + dup @ dup 0x00000000000000FF & { 3roll | swap ! exit } unless + ~ (string so far, new character byte, address of final word, old value) + + ~ This next part is repeated several times, changing only the offsets, for + ~ bytes 1 through 6; bytes 0 (above) and 7 (way below) are different. + ~ (string so far, new character byte, address of final word, old value) + dup 0x000000000000FF00 & { 3roll 0x0000000000000100 * | swap ! exit } unless + dup 0x0000000000FF0000 & { 3roll 0x0000000000010000 * | swap ! exit } unless + dup 0x00000000FF000000 & { 3roll 0x0000000001000000 * | swap ! exit } unless + dup 0x000000FF00000000 & { 3roll 0x0000000100000000 * | swap ! exit } unless + dup 0x0000FF0000000000 & { 3roll 0x0000010000000000 * | swap ! exit } unless + dup 0x00FF000000000000 & { 3roll 0x0001000000000000 * | swap ! exit } unless + + ~ The top byte of the final word is always zero (or else stringlen + ~ wouldn't have called it the final word), so we don't need to check it, we + ~ can just use it. + ~ + ~ We need to put the new value in the top byte, which will mean we have no + ~ null terminator, so we also need to start a new word. + ~ + ~ There is a fiddly order-dependency here: unroll-past-string relies on + ~ being able to find the null terminator, which won't work if we've gotten + ~ rid of it. Also, calling it will move all the earlier words, including + ~ the one we intend to write to, which will invalidate any pointer we're + ~ keeping at that point. There's a few ways to resolve this; what we do is + ~ put the new terminator in place first, manually nudge the pointer, and + ~ then write the new value. + ~ (string so far, new character byte, address of final word, old value) + 3roll 0x0100000000000000 * | swap + ~ (string so far, new value, address of final word) + 0 3 unroll-past-string + ~ (new null terminator, string so far, new value, invalid address) + 8 - + ~ (new null terminator, string so far, new value, updated address) + ! ; + + +~ (byte -- boolean) +: is-space + dup 0x20 = { drop 1 exit } if + dup 0x09 = { drop 1 exit } if + dup 0x0a = { drop 1 exit } if + dup 0x0b = { drop 1 exit } if + dup 0x0c = { drop 1 exit } if + dup 0x0d = { drop 1 exit } if + drop 0 ; + + +~ (character -- 1 for true or 0 for false) +: is-alphanumeric + ~ We don't have a character-literal syntax; the hex constants here are + ~ ASCII codes. + dup 0x30 > { drop 0 exit } if ~ Less than "0". + dup 0x39 >= { drop 1 exit } if ~ Less than or equal to "9". + dup 0x41 > { drop 0 exit } if ~ Less than "A". + dup 0x5a >= { drop 1 exit } if ~ Less than or equal to "Z". + dup 0x61 > { drop 0 exit } if ~ Less than "a". + dup 0x7a >= { drop 1 exit } if ~ Less than or equal to "z". + drop 0 ; ~ Greater than "z". + + +~ Okay, this is the big one, the lexer! Wow. +~ +~ The only way this can ever return a zero-length string is if it hit EOF, +~ and callers can rely on that. +~ +~ (-- stack string occupying multiple words) +: word + ~ We allocate an empty string first, so that the result of "key" will + ~ conveniently be on the easy-to-find end of it. + 0 + + ~ Skip whitespace. + { key dup is-space } { drop } while + + ~ Early exit if it's an EOF. We leave the accumulated string on the stack; + ~ since we're not in the loop yet, it will be empty and this will function + ~ as the caller's indication we're at EOF. + dup -1 = { drop exit } if + + accumulate-string + + { + peek dup is-space { drop exit } if + + ~ If it's an EOF, exit, leaving the accumulated string on the stack. + ~ It's nonempty, since we're in the loop already, and from the caller's + ~ perspective it's valid input. + dup -1 = { drop exit } if + + consume accumulate-string + } forever ; + + + +~ (character -- value) +: generalized-digit-value + ~ We don't have a character-literal syntax; the hex constants here are + ~ ASCII codes. + dup 0x61 <= { 0x61 - 10 + exit } if ~ lowercase "a" + dup 0x41 <= { 0x41 - 10 + exit } if ~ uppercase "a" + 0x30 - ; ~ digit "0" + + +~ (character, base +~ -- value (if successful), +~ error indicator (zero equals success)) +: decode-generalized-digit + swap dup is-alphanumeric { + ~ It's alphanumeric. + ~ (base, character) + generalized-digit-value + ~ (base, value) + dup 3roll + ~ (value, value, base) + > { + ~ It's in range. + ~ (value) + 0 exit } if + ~ It's out of range. + ~ (value) + drop 1 exit } if + ~ It's not alphanumeric. + drop drop 1 ; + + +~ (string pointer, base +~ -- result (if successful), +~ error indicator (zero equals success)) +: read-base-unsigned + swap + + ~ If the first byte is null, this is an error + unpack8 + ~ (numeric base, current point in string, character) + dup 0 = { drop drop drop 1 exit } if + + ~ Decode the first byte as a generalized digit in the base. + ~ (numeric base, current point in string, character) + ~ If the first byte is less than "0", this is an error. + 3roll dup 4 unroll + ~ (numeric base, current point in string, character, numeric base) + decode-generalized-digit { + ~ (numeric base, current point in string) + drop drop 1 exit } if + + ~ The first byte is a valid generalized digit in the appropriate base, so + ~ let's get started. + ~ (numeric base, current point in string, initial value) + swap + + { + ~ (numeric base, result so far, current point in string) + unpack8 dup 0 = { + ~ A null after the first character is valid, and indicates we're done. + drop drop swap drop 0 exit } if + + ~ Decode the latest byte as a generalized digit in the base. + ~ (numeric base, result so far, current point in string, latest byte) + 4 roll dup 5 unroll + ~ (numeric base, result so far, current point in string, character + ~ numeric base) + decode-generalized-digit { + ~ If the latest character is not a valid digit, that's an error. + ~ (numeric base, result so far, current point in string) + drop drop drop 1 exit } if + + ~ The latest character is valid, so incorporate it and loop. + ~ (numeric base, result so far, current point in string, latest value) + 3roll 4 roll dup 5 unroll * + swap + } forever ; + + +~ (string pointer +~ -- result (if successful), +~ error indicator (zero equals success)) +: read-integer-unsigned + ~ We don't have a character-literal syntax; the hex constants here are + ~ ASCII codes. + dup unpack8 0x30 != { ~ digit "0" + ~ This is the case where the leading digit is not a zero. + ~ (original string pointer, advanced string pointer) + drop 10 read-base-unsigned exit } if + + ~ This is the case where the leading digit is a zero. + ~ (original string pointer, advanced string pointer) + unpack8 dup 0x78 = { ~ lowercase "x" + ~ (original string pointer, doubly advanced string pointer, character) + drop swap drop 16 read-base-unsigned exit } if + + dup 0x6f = { ~ lowercase "o" + ~ (original string pointer, doubly advanced string pointer, character) + drop swap drop 8 read-base-unsigned exit } if + + dup 0x62 = { ~ lowercase "b" + ~ (original string pointer, doubly advanced string pointer, character) + swap drop swap 2 read-base-unsigned exit } if + + ~ This is the case where the second character is something else. + ~ (original string pointer, doubly advanced string pointer, character) + drop drop 10 read-base-unsigned ; + + +~ (string pointer +~ -- result (if successful), +~ error indicator (zero equals success)) +: read-integer + ~ We don't have a character-literal syntax; this is ASCII for a hyphen. + dup unpack8 0x2d != { + ~ This is the case where it's non-negative. + ~ (original string pointer, advanced string pointer) + drop read-integer-unsigned exit + } if + + ~ This is the case where it's negative. + ~ (original string pointer, advanced string pointer) + swap drop read-integer-unsigned + ~ (result maybe, exit code) + dup { + ~ Failure + ~ (non-zero exit code) + exit + } if + + ~ Success + ~ (result, zero exit code) + swap -1 * swap ; + + +~ (string pointer +~ -- result (if successful), +~ error indicator (zero equals success)) +: read-decimal + ~ We don't have a character-literal syntax; this is ASCII for a hyphen. + dup unpack8 0x2d != { + ~ This is the case where it's non-negative. + ~ (original string pointer, advanced string pointer) + drop 10 read-base-unsigned exit + } if + + ~ This is the case where it's negative. + ~ (original string pointer, advanced string pointer) + swap drop 10 read-base-unsigned + ~ (result maybe, exit code) + dup { + ~ Failure + ~ (non-zero exit code) + exit + } if + + ~ Success + ~ (result, zero exit code) + swap -1 * swap ; + +~ Here, we allocate a single machine word's worth of space to use as the +~ backing store of a mutable variable, initialized to zero. Then we define the +~ variable which points to that address. +~ +~ We don't actually need a word header for interpreter-flags-storage, we +~ could just append a zero and point to it directly, but that would make life +~ harder for words that attempt to work with the contents of other words. So +~ we give it a name. + +s" interpreter-flags-storage" create make-hidden +here @ 0 , s" interpreter-flags" variable + + +~ There's an important bootstrapping concern: If you're loading this +~ interpreter into a running Evocation, it's important to not use the wrong +~ interpreter state value. The way we actually load this is under the log-load +~ transform, which will be running its alternate versions of these words and +~ therefore won't have trouble, but for the sake of making it easy to +~ experiment with modified versions of this file, we do the whole hide-show +~ dance. + +: [ interpreter-flags @ 0x01 invert & interpreter-flags ! + ; make-immediate make-hidden +latest @ +~ (pointer to [ entry) + +: ] interpreter-flags @ 0x01 | interpreter-flags ! + ; make-hidden +latest @ +~ (pointer to [ entry, pointer to ] entry) + +~ It may seem nonsensical to use : to define :, but the log-load transform +~ provides an alternate for it, so it works. The same, of course, goes for all +~ these other word-defining words. The syntax-centric ones such as : are here +~ in interpret.e because they need to interact with interpreter-flags, which +~ isn't defined before this point. +~ +~ If the ] at the end feels backwards, imagine to yourself that everything +~ that ISN'T defining a word body is part of an implicit [ ... ] sequence. +~ Doing so doesn't really change anything, but may make you happier. +: : word value@ create dropstring docol , make-hidden + [ dup entry-to-execution-token , ] ; + +~ The counterpart of : is ;. +: ; + ~ See commentary on "literal", in language/dynamic/dynamic.e, regarding + ~ "lit exit". + ~ + ~ In regard to the magic comment, this is in the same category as strings + ~ and high-level flow control, where it's implemented in the base code here + ~ because that could be relevant to end-user code that compiles things + ~ without using the transforms, but in the regular compiler it's not used + ~ because the transforms override this whole implementation. + lit exit , ~ : -8 exit #-- (codeword pointer) + make-visible + ~ See above regarding [. Since it's an immediate word, we have to go to + ~ extra trouble to compile it as part of ;. Since it's also hidden, we have + ~ to go behind the interpreter's back to even get its entry pointer. + ~ + ~ Adding insult to injury, the log transform breaks , for unclear reasons, + ~ so we do that by hand as well. + [ over entry-to-execution-token , ] + ; make-immediate make-hidden +latest @ +~ (pointer to [ entry, pointer to ] entry, pointer to ; entry) + + +: ;asm + here @ pack-next 8 packalign here ! + make-visible + latest @ entry-to-execution-token dup 8 + swap ! + ~ See above. + [ 2 pick entry-to-execution-token , ] + ; make-immediate make-hidden +latest @ +~ (pointer to [ entry, pointer to ], pointer to ;, pointer to ;asm) + + +~ The word "'", often pronounced "tick", quotes the following word, looking +~ it up and treating it as a constant. In immediate mode, the constant winds +~ up on the stack; in compile mode it gets compiled. +~ +~ There are a few possible implementation strategies here. Running as an +~ immediate word means there's a clear and unambiguous concept of "the +~ following word", so that's what we do; otherwise we'd have to get clever +~ about somehow finding out where we were called from. That means we take on +~ what would otherwise be the interpreter's responsibility, of checking what +~ mode we're in. Happily, that's easy to do. +~ +~ There's a cyclic dependency where "if" relies on "'", and "'" relies on +~ "if". Fortunately flow-control is done with alternates by the log-load +~ transform, so we don't have to worry about it. +: ' word value@ find dropstring-with-result + interpreter-flags @ 0x01 & { literal } if + ; make-immediate + + +~ Let's have strings now. +: s" + consume + interpreter-flags @ 0x01 & { + [ s" litstring" find literal ] + ~ The magic comment isn't active in the compiler as-written, since the + ~ transformations do this bit themselves, but should still be here for + ~ completeness; it could affect other things people compile. + entry-to-execution-token , ~ : -8 litstring #-- (codeword pointer) + } if + here @ key { dup dup 0x22 != && } { pack8 key } while + drop 0 pack8 + interpreter-flags @ 0x01 & + { 8 packalign here ! } + { drop here @ } if-else + ; make-immediate + + +~ Finicky semantics, but also important. +: ." + ' s" entry-to-execution-token execute + interpreter-flags @ 1 & + { [ s" emitstring" find literal ] + ~ As with s", the magic comment is for completeness only. + entry-to-execution-token , ~ : -8 emitstring #-- (codeword pointer) + } { emitstring } if-else + ; make-immediate + + +~ While we're thinking about input, let's also have comments. +: ~ + key { dup dup 10 != && } { drop key } while drop + ; make-immediate + + +~ Now the single most important word... +: interpret + word + + ~ If no word was returned, exit. + dup 0 = { drop 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@ find + + ~ Check whether the word was found in the dictionary. + dup { + ~ If the word is in the dictionary, check what mode we're in, then... + dropstring-with-result + ~ (entry pointer) + interpreter-flags @ 0x01 & { + ~ ... if we're in compile mode, there's still a chance it's an immediate + ~ word, in which case we fall through to interpret mode... + dup entry-flags@ 1 & 0 = + + ~ ... but it's a regular word, so append it to the heap. + { entry-to-execution-token , exit } if + } if + + ~ ... if we're in interpret mode, or the word is immediate, run it. + entry-to-execution-token execute exit + } if + + ~ If it's not in the dictionary, check whether it's an integer literal. + drop + ~ As before, we get the stack address and use it as a string pointer. + ~ (string) + value@ read-integer 0 = { + ~ It's a number. + interpreter-flags @ 0x01 & { + ~ We're in compile mode; append first "lit", then the number, to the + ~ heap. The version of "lit" we use is the one that's current when we + ~ ourselves are compiled, hardcoded; doing a dynamic lookup would + ~ require dealing with what happens if it's not found. + dropstring-with-result + ' lit entry-to-execution-token + , , + 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 exit + } if + + ~ If it's neither in the dictionary nor a number, just print an error. + ." No such word: " value@ emitstring newline dropstring ; + +: quit r0 @ control! { interpret } forever ; + +~ Now we enable the three words we'd been keeping hidden. It would be a +~ good idea to call "quit" as soon as possible after this, but we leave it to +~ the user. +dup entry-flags@ 0x80 invert & swap entry-flags! +dup entry-flags@ 0x80 invert & swap entry-flags! +dup entry-flags@ 0x80 invert & swap entry-flags! +dup entry-flags@ 0x80 invert & swap entry-flags! + +~ Though we only do it once, this is a bit involved so we provide it as a +~ word. Notionally there are situations in which it could come up again, so +~ it seems worth having around. +~ +~ It actually needs to run as a compiled word no matter what; if it were +~ run in interpret mode it would cut itself off from the rest of itself. +~ However, if we didn't want to keep it around we could have it forget +~ itself... +~ +~ It depends on ', so it's here in interpret.e. +: relink-main-input-buffer-to-stdin + 1024 allocate dup main-input-buffer buffer-physical-start ! + main-input-buffer buffer-logical-start ! + 1024 main-input-buffer buffer-physical-length ! + 0 main-input-buffer buffer-logical-length ! + 0 main-input-buffer buffer-file-descriptor ! + [ s" refill-input-buffer-from-stream" + find entry-to-execution-token literal ] + main-input-buffer input-buffer-refill ! + ; + +~ Of course it is perfectly reasonable to change this, but for now it's +~ hardcoded. +relink-main-input-buffer-to-stdin + diff --git a/language/dynamic/linux.e b/language/dynamic/linux.e new file mode 100644 index 0000000..680bdb4 --- /dev/null +++ b/language/dynamic/linux.e @@ -0,0 +1,359 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ More system calls for Linux ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Here's some more system calls for the Linux kernel, augmenting the ones in +~ language/static/linux.e. We needed the basic I/O stuff early, to use in +~ building the interpreter, but there's less-basic stuff that benefits from +~ dynamic definition. That stuff is here. +~ +~ In particular, everything that takes a struct is here, because that lets +~ us define the system call next to the allocation stuff, for ease of +~ reference. There are also higher-level facilities, later in the file. + + +~ Since the only way to know the struct layout is by reading the kernel +~ source, we put that definition here, as well. +~ (-- struct pointer) +: allocate-timespec 2 8 * allocate ; +~ (struct pointer -- field pointer) +: timespec-seconds ; +: timespec-nanoseconds 8 + ; + + +~ (nanoseconds -- result code) +: nanosleep + 1000000000 /% + ~ (nanoseconds, seconds) + allocate-timespec + dup timespec-seconds 3roll swap ! + dup timespec-nanoseconds 3roll swap ! + allocate-timespec + dup timespec-seconds 0 swap ! + dup timespec-nanoseconds 0 swap ! + dup 3unroll + 35 ~ syscall number + syscall-2 + drop drop ; + + +~ The old name was sigaction(), but per the glibc manpages, that was +~ replaced by rt_sigaction() quite some time ago, to allow larger signal set +~ bitmaps for the benefit of realtime signals. Both are still present; we use +~ rt_sigaction(). There are also two versions of rt_sigaction; grep +~ ODD_RT_SIGACTION in the kernel source for more details. Neither x86 +~ architecture has the "odd" version of rt_sigaction(), so we use the regular +~ one, not to be confused with the "compat" one. Its definition is in +~ kernel/signal.c, in case you need to check the struct sizes and layouts. +~ +~ The parameters are: An integer signal identifier; an optional pointer to a +~ struct describing the new action to bind (or unbind if NULL); an optional +~ pointer to another of the same struct to hold a copy of the old action; and +~ a 64-bit word which must describe the correct size of sigset_t, which is a +~ C type used for the mask field of that struct. Any other value for the size +~ field is an error. +~ +~ Mandatory size fields start to make sense when you have a compatibility +~ situation this convoluted... Think of it as the caller promising they know +~ which version of the API they're calling. The unmarked version of +~ rt_sigaction() takes a 64-bit sigset_t, and the parameter wants the size in +~ bytes, so we use a value of 8. +~ +~ Anyway, we aren't C and don't have POSIX naming obligations, so we just +~ call it sigaction. +~ +~ (signal number, new action pointer, old action pointer -- result code) +: sys-sigaction + 8 ~ size of sigset_t in bytes + 13 ~ syscall number + syscall-4 ; + + +~ (new stack pointer, old stack pointer -- result code) +: sys-sigaltstack + 131 ~ syscall number + syscall-2 ; + + +~ Since the only way to know the struct layout is by reading the kernel +~ source, we put that definition here, as well. +~ +~ There are MANY versions of this struct; this is the appropriate one for +~ amd64. +~ +~ (-- struct pointer) +: allocate-sigaction here @ 128 packalign here ! 4 8 * allocate ; +~ (struct pointer -- field pointer) +: sigaction-action ; +: sigaction-flags 8 + ; +: sigaction-restorer 2 8 * + ; +: sigaction-mask 3 8 * + ; + + +: allocate-sigaltstack here @ 128 packalign here ! 3 8 * allocate ; +: sigaltstack-pointer ; +: sigaltstack-flags 8 + ; +: sigaltstack-size 2 8 * + ; + + +~ High-level facilities +~ ~~~~~~~~~~~~~~~~~~~~~ + +~ It's possible to set up an alternate stack for signal handlers. We don't, +~ though, so it's possible this code has bitrotted. At the very least, it +~ should be more configurable than this. +: prepare-signal-stack + here @ 2048 packalign here ! + 1024 1024 * 4 * allocate + ~ (stack address) + allocate-sigaltstack + ~ (stack address, struct pointer) + 2dup sigaltstack-pointer ! + dup sigaltstack-flags 0 swap ! + dup sigaltstack-size 1024 1024 * 32 * swap ! + ~ (stack address, struct pointer) + allocate-sigaltstack + sys-sigaltstack + drop ; + + +~ On amd64, and on no other architecture, the Linux kernel requires that +~ the language runtime use a "restorer" when binding signal handlers. This +~ is that restorer. The kernel wants a raw pointer that it can use as a +~ C-style return address on the C stack, which is our value stack. So, this +~ has to be an assembly word, it can't use docol. When the data structure is +~ populated by bind-signal, we'll dereference the codeword and pass that +~ value, but there's no chance to give it the usual callee address in rax, so +~ we can't use a Forth-style interpreter codeword, it has to be a +~ self-codeword. +~ +~ The purpose of the trampoline is to be invoked by our signal handler. The +~ manner of that invocation MUST be returning into it with the "ret" +~ instruction; otherwise the C stack won't be right for cleanup to work +~ properly. +~ +~ When invoked, the trampoline invokes the syscall "sigreturn", whose sole +~ purpose is to be called from this trampoline. That syscall won't return in +~ a conventional way, so we don't bother handling the scenario where it does. +~ +~ According to commentary in the Go compiler's internals[1][2][3], gdb +~ recognizes the trampoline based on its exact byte values, since the intent +~ is only to be compatible with glibc. We intend to be our own debugger +~ anyway, so we don't worry about that. We're not seeking fame and we don't +~ have a corporate image to uphold, so that level of fragility and contortion +~ is just too much. The thing about compatibility constraints is knowing when +~ to work with them and when to walk away. +~ +~ Experimentally, it is also possible to avoid using this trampoline by +~ faking it: set the "restorer" bit in the action flags, but pass a null +~ pointer as the restorer, then have the handler pop 8 bytes from the stack +~ and invoke sigreturn directly. The actual requirement seems to be that rsp +~ points at the saved state, at the time of invoking sigreturn. We're not +~ doing that, because signal handling is not intended to be +~ performance-critical and it feels like asking for trouble, but the +~ possibility is noted here against future use. +~ +~ This doesn't have an interface definition comment, because it doesn't use +~ the Forth execution model. +~ +~ [1] https://go.googlesource.com/go/+/refs/heads/master/src/runtime/sys_linux_amd64.s#472 +~ [2] https://go.googlesource.com/go/+/refs/heads/master/src/runtime/os_linux.go#476 +~ [3] https://go.googlesource.com/go/+/refs/heads/master/src/runtime/defs_linux_amd64.go#118 +: signal-return-trampoline + [ here @ + 15 :rax mov-reg64-imm64 ~ sigreturn + syscall + here ! ] ;asm + +~ This accepts an execution token. It creates a hidden word on the log which +~ wraps that execution token with necessary setup and teardown to run as a +~ Unix signal handler, and returns the execution token of the wrapper. +~ +~ Specifically, on invocation, the wrapper ensures that rsi points to its +~ second half and rbp points to the top of the control stack; loads the target +~ execution token into rax; then indirectly calls it. This is the usual +~ interface of a normal call in the Forth execution model, so the wrapped word +~ can be based on docol, on a self-codeword, or on any other interpreter word +~ it wants. It can also freely call whatever Forth things it wants. +~ +~ We don't have to do anything about rsp because the invariants for our use +~ of it as the value stack are a subset of the invariants for C's use of it as +~ its only stack. It's already working the way we need it to. +~ +~ When the wrapped word returns, it uses the rsi the wrapper provided to do +~ so, which places control in the second half of the wrapper. This second half +~ simply executes a "ret" instruction, which is the necessary invocation of +~ the signal return trampoline (see above). This will transfer control back +~ to the kernel, and will ultimately result in Forth execution resuming where +~ it left off before the signal was delivered. +~ +~ Crucially, the wrapper relies on the kernel preserving the value of rbp +~ that existed at the moment before the control transfer began. Signal +~ delivery is an UNCONTROLLED control transfer, meaning that we as the +~ language runtime do not have an opportunity to execute any cleanup before it +~ happens. If it were a controlled transfer, we would be able to save rbp to +~ a global variable somewhere, and restore it in the wrapper. It's not, so we +~ don't have that chance. +~ +~ Notionally we could freshly allocate a new control stack somewhere else, +~ and set rbp to point to it, but it would be challenging to do that without +~ relying on the control stack, and inefficient to execute, and the call for +~ now is that that's not worth it. +~ +~ The only situation in which this limitation will become a practical +~ concern is if, at the time of signal delivery, something outside the Forth +~ execution model is happening. In that case, the wrapper will likely crash. +~ +~ As a long term strategy, the way to mitigate this would be to make sure +~ that all non-signal transfers from within the Forth execution model to +~ outside it are controlled, and that they save global state that can be +~ reconstructed here. For now, we leave this as future work. +~ +~ (execution token -- execution token) +: wrap-signal-handler + ~ We generate a word entry for the wrapper, and hide it. Since it's + ~ hidden, the name doesn't have to be unique. This keeps the log clean, so + ~ that all the space on it will always be attributable to some specific + ~ word. Remember kids, keeping the log clean is everyone's responsibility! + s" signal-handler-wrapper" create make-hidden + + ~ This self-codeword will be consumed by bind-signal. + self-codeword + + here @ dup + ~ (inner execution token, saved location, output point) + + ~ It's our responsibility as a caller to set rsi to point to the address + ~ of an execution token, which will pick up where we left off. That token + ~ will be our own second half, whose address we don't yet know, so we + ~ output a placeholder opcode here and overwrite it once we do. That's why + ~ we've saved the current location. + 0 :rsi mov-reg64-imm64 + + ~ We also need to make sure that rbp points to an area that can be treated + ~ as the top of the control stack (there's no need to ever unwind past it, + ~ so it doesn't have to be the "real" one). Fortunately, it comes to us + ~ already valid and we don't have to do anything about that. Plus it even + ~ does happen to be the real one, which will let stack tracing code run in + ~ a handler, and we do care about that. + + ~ We also need to set DF = 0, since that's also part of our ABI. + cld + + ~ Compare this snippet to "execute" in language/static/core.e. Instead of + ~ taking rax from the stack, we set a hardcoded value picked at the time we + ~ generate the wrapper. We then do the same indirect jump via the codeword + ~ it points to, which allows the codeword's implementation to take advantage + ~ of rax pointing to the callee; that's the property docol cares about. + 3roll :rax mov-reg64-imm64 + :rax jmp-abs-indirect-reg64 + ~ (saved location, output point) + + 8 packalign + here ! + ~ (saved location) + + ~ Now we have our second half, which has another codeword that rsi will + ~ point to for our callee's benefit. This half runs after the wrapped word, + ~ and has the responsibility of cleaning up and returning control to the + ~ kernel, which it does by returning to the restorer trampoline. Yes, this + ~ is a trampoline which passes control to another trampoline. + ~ + ~ Although we run under the log-load transform, we won't ever actually be + ~ invoked until at least log-load time, if not ultimate runtime. Both of + ~ those are in the target address space. So there's no address translation + ~ going on behind our back. Nonetheless, we avoid directly outputting any + ~ address except what we get via self-codeword, which would be recommended + ~ practice under the transforms. Yeah, it's a little convoluted, perhaps + ~ unnecessarily so. + here @ + self-codeword + @ 8 - + ~ (saved location, second half execution token) + + ~ Something subtle here: That above "codeword" was actually a word + ~ pointer. See, because we're pretending the wrapper is a Forth word, even + ~ though we're writing it in assembly, so "returning" to it means invoking + ~ the next word pointer in the word pointer array that is its compiled form. + ~ Instead of creating a separate memory area though, we just put the pointer + ~ target right here, as another codeword... + self-codeword + + ~ Now we treat the saved location as an output point, and re-output the + ~ mov instruction that we stubbed out above. Because our assembler words + ~ always output a specific, exact form of the instruction, we know it will + ~ take up the same number of bytes. + :rsi mov-reg64-imm64 + drop + + ~ Having done that, we can get on to the body of our second half. Happily, + ~ it's quite short. + here @ + + ret + + 8 packalign + here ! + + ~ Our caller wants an execution token that invokes all this. Since we + ~ used "create" above, that's easy to get. + latest @ entry-to-execution-token ; + + +~ This accepts an execution token and a Unix signal number, and binds the +~ token to be the handler for the signal. It also does other necessary setup, +~ including picking appropriate flags for the binding and attaching the +~ return trampoline (see above). +~ +~ Typically, you will want this execution token to be one returned by +~ wrap-signal-handler. Doing this will allow the handler to use the Forth +~ execution model in any way it wants, including calling both docol words and +~ assembly words, and working with both the control and value stacks at will. +~ +~ There is an important limitation of wrap-signal-handler, described in more +~ detail above: Its wrapper only functions correctly when Forth code was +~ running at the time of the control transfer. For example, if Forth had +~ called into C, and then that C were interrupted by a signal, the signal +~ handler would have no way of finding the top of the control stack. +~ +~ If your program involves many callbacks back-and-forth between C and +~ Forth, you may wish to forego the use of the wrapper and provide an +~ execution token meant to be invoked directly by the kernel. In this case, +~ bear in mind that its execution must not use the control stack - that is, +~ it must not rely on having been given sensible values of rsi or rbp. This +~ means it can't call other Forth words (unless it does something about that +~ on its own). +~ +~ Regardless of whether the execution token is a copy of the wrapper or not, +~ it must be an assembly word, not a docol word. The kernel wants a raw +~ pointer that it can simulate a C-style call to, so we dereference the +~ codeword and pass that value, just as we do with the return trampoline. Also +~ as with the return trampoline, there is no way to pass the callee in rax, +~ which is the usual interface docol and other interpreter words expect. So, +~ it needs to be a self-codeword. +~ +~ (execution token, signal number --) +: bind-signal + allocate-sigaction + dup sigaction-action 4 roll @ swap ! + dup sigaction-mask 0 swap ! + dup sigaction-flags 0x04000000 swap ! + dup sigaction-restorer + ' signal-return-trampoline entry-to-execution-token @ swap ! + ~ (signal number, struct pointer) + allocate-sigaction + sys-sigaction drop ; + + +: handle-crash ." CRASH" newline list-callers 1 sys-exit ; + +: install-crash-handler + ' handle-crash entry-to-execution-token wrap-signal-handler + 11 bind-signal ; + +~ There are scenarios where someone might want to disable this, for example +~ if calling back and forth between C and Evocation, but for now we always +~ enable it. +~ : blank-line +install-crash-handler + diff --git a/language/static/amd64.e b/language/static/amd64.e new file mode 100644 index 0000000..925abc0 --- /dev/null +++ b/language/static/amd64.e @@ -0,0 +1,1383 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Assembly language for the AMD64 architecture ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ This is also often called the x86-64 architecture, but Intel didn't +~ invent it (they had their chance) and there's no reason to name it after +~ their product line. We have a bunch of assembler words that, taken as a +~ whole, form a sort of assembly language inside of the Forth-style language. +~ +~ It's all backwards and stuff. +~ +~ Okay, but seriously, the convention is: target on the top of the stack, +~ source behind it. This is similar to how the Forth "!" and "@" words work. +~ +~ These routines use the binary packing routines such as pack64, defined in +~ language/static/core.e. They're called in the same way: an output address +~ which we call the "output point", followed by data items specific to what's +~ being output. They also chain together in the same way, returning the +~ updated output point. +~ +~ TODO cite the Intel reference manual here and explain the notation used +~ for the section citations below +~ +~ TODO define instructions, assembly code, machine code, opcodes. if we ever +~ also want to recommend a childrens' introduction to binary, this might be +~ the place to do it. +~ +~ +~ Hex-transformed output +~ ~~~~~~~~~~~~~~~~~~~~~~ +~ +~ In addition to the actual semantics of the assembly words, there's an +~ important layer of meaning atop them. The hex transform, described in detail +~ in compilation/transform.e, modifies a compilation process to produce a +~ commented hex dump instead of a binary. It includes a magic-comment feature +~ which allows words that have opinions on what their output's hex dump should +~ look like to express them. +~ +~ The code in this file makes extensive use of the magic-comment feature. +~ Any comment which starts with : as its first word is a magic comment meant +~ for the hex transform. When the hex transform is not in use, these are +~ ordinary comments and are ignored. When it is in use, they create and modify +~ metadata annotations in a complex way. +~ +~ The magic comments in this file follows two important conventions: First, +~ entries are created by whichever word directly corresponds to a top-level +~ assembly instruction from the perspective of someone programming with it, +~ at some point prior to calling any word which might pack output. Second, +~ output bytes are accounted for by whichever word directly calls a pack* word +~ for them. +~ +~ Thus, for example, the word "syscall" has a comment which creates an entry +~ describing its length as 2 bytes, which never varies. +~ +~ The word "mov-reg64-imm32", on the other hand, has a comment which +~ creates an entry describing is length as 5 bytes - the opcode and the +~ immediate value, which are output with calls to pack8 and pack32 in that +~ word. However, the actual length of the instruction is 5 bytes. When +~ mov-reg64-imm32 calls rex-w, a magic comment there modifies the most recent +~ entry in-place, marking it as being one byte longer. Subsequently, +~ mov-reg64-imm32 calls addressing-reg64, which calls modrm, which again +~ modifies the same entry. Notice that addressing-reg64 didn't need to do +~ anything, because it isn't directly responsible for any packing. +~ +~ Notice that when an entry is modified in place, it needs to have been +~ created first. Attempting to do it in the wrong order will have an +~ undesired effect, most likely editing the entry of an unrelated instruction. +~ The hex transform doesn't have detailed knowledge of assembly, and isn't in +~ a position to know that the edits that are happening are sensible. +~ +~ Hopefully these examples show why an accounting convention is needed. The +~ good news is that the convention is quite robust and needs essentially no +~ play-by-play commentary, just this explainer at the top. + + +~ Keywords +~ ~~~~~~~~ +~ +~ We define a bunch of keywords, which evaluate to their own codeword +~ addresses. We use these to refer to registers and condition codes by name. +~ +~ +~ On registers +~ ~~~~~~~~~~~~ +~ +~ The x86 architecture has been around a while, it has been through +~ several transitions from smaller word sizes to larger ones. Therefore it +~ has different names for the "same" registers, depending on how much of +~ them you're using. +~ +~ TODO there's more to write here + +~ The names of the 64-bit registers. The second half of these are considered +~ "extended" registers because they don't correspond to 32-bit registers in +~ the way the first eight do. +s" :rax" keyword +s" :rcx" keyword +s" :rdx" keyword +s" :rbx" keyword +s" :rsp" keyword +s" :rbp" keyword +s" :rsi" keyword +s" :rdi" keyword +s" :r8" keyword +s" :r9" keyword +s" :r10" keyword +s" :r11" keyword +s" :r12" keyword +s" :r13" keyword +s" :r14" keyword +s" :r15" keyword + +~ The names of the 32-bit registers. The processor treats these as being +~ alternate names for the low halves of the 64-bit registers. There is a +~ very finicky distinction about what that means in different settings: Some +~ instructions operate on a 32-bit source or target, while others merely +~ accept a 32-bit value that gets sign-extended to 64 bits. We've taken pains +~ to clarify these cases in the instruction-specific notes, as they come up. +s" :eax" keyword +s" :ecx" keyword +s" :edx" keyword +s" :ebx" keyword +s" :esp" keyword +s" :ebp" keyword +s" :esi" keyword +s" :edi" keyword + +~ The names of the 16-bit registers. Similarly, the processor treats these +~ as being alternate names for the low halves of the 32-bit registers. +s" :ax" keyword +s" :cx" keyword +s" :dx" keyword +s" :bx" keyword +s" :sp" keyword +s" :bp" keyword +s" :si" keyword +s" :di" keyword + +~ The names of the 8-bit registers. The pattern here is a little bit +~ different; these come in "low" and "high" pairs, where for example :al is +~ the low half of :ax and :ah is the high half. Yes, this architecture grows +~ like a tree, with all the old things being still present, surrounded in the +~ new ones. +s" :al" keyword +s" :cl" keyword +s" :dl" keyword +s" :bl" keyword +s" :ah" keyword +s" :ch" keyword +s" :dh" keyword +s" :bh" keyword + +~ The condition codes. Yes, there sure is a lot of duplication in these +~ names. The names are based on Intel's documented mnemonics... +~ +~ "Above" and "below" are for unsigned comparisons. "Greater" and "less" are +~ for signed comparisons. +~ +~ This is documented on the individual opcode pages, and also in B.1.4.7. +s" :cc-overflow" keyword +s" :cc-no-overflow" keyword +s" :cc-below" keyword +s" :cc-above-equal" keyword +s" :cc-equal" keyword +s" :cc-not-equal" keyword +s" :cc-below-equal" keyword +s" :cc-above" keyword +s" :cc-sign" keyword +s" :cc-not-sign" keyword +s" :cc-even" keyword +s" :cc-odd" keyword +s" :cc-less" keyword +s" :cc-greater-equal" keyword +s" :cc-less-equal" keyword +s" :cc-greater" keyword + + +~ Bits and pieces +~ ~~~~~~~~~~~~~~~ +~ +~ Here, we have a bunch of helpers which generate specific encoded +~ representations that are part of many instructions. We start with the +~ trivial ones that handle individual fields, then work up to combinations of +~ fields. +~ +~ When we say that a word accepts a register as a parameter, what we mean +~ is it accepts the name keyword for that register. When we say that a word +~ accepts a scale factor, what we mean is that it accepts a byte count for +~ that scale factor. In the cases where we mean the encoded form, we'll say +~ "encoded value" or "value". +~ +~ (register -- 3-bit encoded value for register) +: reg64 + ~ : provide-keyword + dup :rax = { drop 0 exit } if + dup :rcx = { drop 1 exit } if + dup :rdx = { drop 2 exit } if + dup :rbx = { drop 3 exit } if + dup :rsp = { drop 4 exit } if + dup :rbp = { drop 5 exit } if + dup :rsi = { drop 6 exit } if + dup :rdi = { drop 7 exit } if + ." Parameter to reg64 is not a reg64." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: extrareg64 + ~ : provide-keyword + dup :r8 = { drop 0 exit } if + dup :r9 = { drop 1 exit } if + dup :r10 = { drop 2 exit } if + dup :r11 = { drop 3 exit } if + dup :r12 = { drop 4 exit } if + dup :r13 = { drop 5 exit } if + dup :r14 = { drop 6 exit } if + dup :r15 = { drop 7 exit } if + ." Parameter to extrareg64 is not an extrareg64." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: reg32 + ~ : provide-keyword + dup :eax = { drop 0 exit } if + dup :ecx = { drop 1 exit } if + dup :edx = { drop 2 exit } if + dup :ebx = { drop 3 exit } if + dup :esp = { drop 4 exit } if + dup :ebp = { drop 5 exit } if + dup :esi = { drop 6 exit } if + dup :edi = { drop 7 exit } if + ." Parameter to reg32 is not a reg32." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: reg16 + ~ : provide-keyword + dup :ax = { drop 0 exit } if + dup :cx = { drop 1 exit } if + dup :dx = { drop 2 exit } if + dup :bx = { drop 3 exit } if + dup :sp = { drop 4 exit } if + dup :bp = { drop 5 exit } if + dup :si = { drop 6 exit } if + dup :di = { drop 7 exit } if + ." Parameter to reg16 is not a reg16." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: reg8 + ~ : provide-keyword + dup :al = { drop 0 exit } if + dup :cl = { drop 1 exit } if + dup :dl = { drop 2 exit } if + dup :bl = { drop 3 exit } if + dup :ah = { drop 4 exit } if + dup :ch = { drop 5 exit } if + dup :dh = { drop 6 exit } if + dup :bh = { drop 7 exit } if + ." Parameter to reg8 is not a reg8." 1 sys-exit ; + + +~ There's a packed format called the SIB byte, which we'll get to in a +~ second. One of its bitfields is called the scale field. This word produces +~ an encoded value for that field. +~ +~ The input value is a byte count; the output value is suitable for use in +~ the SIB byte. +~ +~ (scale factor -- 2-bit encoded value) +: scalefield + ~ : provide-decimal + dup 1 = { drop 0 exit } if + dup 2 = { drop 1 exit } if + dup 4 = { drop 2 exit } if + dup 8 = { drop 3 exit } if + ." Parameter to scalefield is not 1, 2, 4, or 8." 1 sys-exit ; + + +~ [Intel] volume 2D, appendix B, section B-1.4.7, table B-10. Also see the +~ individual opcode pages. +~ +~ Every instruction has an "opcode", a specific byte or sequence of bytes +~ which uniquely identifies the combination of operation, addressing mode, +~ and certain miscellaneous characteristics. This is not just another way of +~ referring to the entire sequence of bytes corresponding to the instruction; +~ the opcode is a specific part within that, as distinct from ie. the rex +~ byte, the SIB byte, the Mod/RM byte, and various immediate values and other +~ rare tidbits. +~ +~ Some of these opcodes have bitfields within them, to specify condition +~ codes. This word produces an encoded value for that condition-code field. +~ +~ (condition -- 4-bit encoded value) +: condition-code + ~ : provide-keyword + dup :cc-overflow = { drop 0 exit } if + dup :cc-no-overflow = { drop 1 exit } if + dup :cc-below = { drop 2 exit } if + dup :cc-above-equal = { drop 3 exit } if + dup :cc-equal = { drop 4 exit } if + dup :cc-not-equal = { drop 5 exit } if + dup :cc-below-equal = { drop 6 exit } if + dup :cc-above = { drop 7 exit } if + dup :cc-sign = { drop 8 exit } if + dup :cc-not-sign = { drop 9 exit } if + dup :cc-even = { drop 10 exit } if + dup :cc-odd = { drop 11 exit } if + dup :cc-less = { drop 12 exit } if + dup :cc-greater-equal = { drop 13 exit } if + dup :cc-less-equal = { drop 14 exit } if + dup :cc-greater = { drop 15 exit } if + ." Parameter to condition-code is not a condition code." 1 sys-exit ; + + +~ The "rex" byte appears before an opcode to modify its behavior in various +~ ways. It has four distinct bits within it, leading to sixteen variations, +~ as you can see. +~ +~ The way these are all spelled out like this is slightly ridiculous, there +~ must be a better way. We only ever use rex-w and rex-wb, so it's tempting to +~ get rid of the rest, but they're worth having so that our future selves +~ don't have to revisit this topic. +~ +~ (output point -- output point) +: rex-0 + ~ : 1 adjust-length + 0x40 pack8 ; +: rex-w + ~ : 1 adjust-length + 0x48 pack8 ; +: rex-r + ~ : 1 adjust-length + 0x44 pack8 ; +: rex-x + ~ : 1 adjust-length + 0x42 pack8 ; +: rex-b + ~ : 1 adjust-length + 0x41 pack8 ; +: rex-wr + ~ : 1 adjust-length + 0x4C pack8 ; +: rex-wx + ~ : 1 adjust-length + 0x4A pack8 ; +: rex-wb + ~ : 1 adjust-length + 0x49 pack8 ; +: rex-rx + ~ : 1 adjust-length + 0x46 pack8 ; +: rex-rb + ~ : 1 adjust-length + 0x45 pack8 ; +: rex-xb + ~ : 1 adjust-length + 0x43 pack8 ; +: rex-wrx + ~ : 1 adjust-length + 0x4E pack8 ; +: rex-wrb + ~ : 1 adjust-length + 0x4D pack8 ; +: rex-wxb + ~ : 1 adjust-length + 0x4B pack8 ; +: rex-rxb + ~ : 1 adjust-length + 0x47 pack8 ; +: rex-wrxb + ~ : 1 adjust-length + 0x4F pack8 ; + + +~ Some opcodes use their low three bits as a field to give a register name. +~ This is usually in addition to a register name given in a Mod/RM byte, +~ serving a different role for the instruction. +~ +~ This word accepts an opcode byte with those three bits clear, and combines +~ it with a register value, then outputs the resulting byte. Each opcode +~ accepts some specific kind of register; to allow different kinds, here we +~ expect the step of converting the register name to the encoded bits to have +~ already been done. +~ +~ (output point, 3-bit encoded value for register, opcode byte +~ -- output point) +: opcodereg + ~ : 1 adjust-length + | pack8 ; + + +~ Some opcodes use their low four bits as a field to give a condition code. +~ This word accepts an opcode byte with those four bits clear, and combines it +~ with a condition code value, then outputs the resulting byte. For +~ consistency with opcodereg, we expect the step of converting the condition +~ code name to the encoded bits to have already been done. +~ +~ (output point, 4-bit encoded value for condition code, opcode byte +~ -- output point) +: opcodecc + ~ : 1 adjust-length + | pack8 ; + + +~ A Mod/RM byte ("mode / register-or-memory") is part of the encoding of +~ many instructions. It's divided into three fields: "mod" (mode), +~ register/opcode, and register/memory ("RM"). +~ +~ This word outputs a Mod/RM byte given fully-processed, numeric values for +~ its fields. Most code will want to call one of the higher-level +~ addressing-* words, instead. +~ +~ (output point, mod field, register/opcode field, register/memory field +~ -- output point) +: modrm + ~ : 1 adjust-length + swap 8 * | swap 64 * | pack8 ; + +~ An SIB byte ("scale, index, base") is part of the encoding of many +~ instructions. It's divided into three fields, with the names you've already +~ guessed. +~ +~ This word outputs an SIB byte given fully-processed, numeric values for +~ its fields. +~ +~ (output point, scale field, index field, base field -- output point) +: sib + ~ : 1 adjust-length + swap 8 * | swap 64 * | pack8 ; + + +~ Addressing modes +~ ~~~~~~~~~~~~~~~~ +~ +~ These are higher-level words meant to be easier to use than the bits and +~ pieces above. Each corresponds to some specific addressing mode. When +~ applicable, they accept keywords rather than pre-encoded values. +~ +~ That's not all the time, because there are cases, such as the reg/op +~ field, where the meaning is up to the individual instruction. In those +~ cases, these words do accept fully-processed, numeric values. +~ +~ The general rule is that the responsibility of these addressing-mode words +~ is for the parts that are common to all instructions using that addressing +~ mode. + + +~ The simplest of the addressing modes: Direct register addressing. There +~ are no special cases to check. +~ +~ It's important to notice that the R/M field may describe either a source, +~ or a target, depending on what the instruction is. So, this helper doesn't +~ get to know that. It also doesn't get to know whether the value in the +~ reg/op field describes a register, or if instead it's an extension of the +~ opcode. The caller is responsible for figuring that all out. +~ +~ (output point, reg/op field value, reg/mem field register +~ -- output point) +: addressing-reg64 reg64 3 3unroll modrm ; +: addressing-reg8 reg8 3 3unroll modrm ; + + +~ This is a helper for assembly instructions that want to do a form of +~ addressing that requires a value of 1 in the modrm byte's mode field, and +~ do not want to do any indexing. That's the indirect mode, which takes a +~ 64-bit register, treats it as an address, and looks up the 64-bit value it +~ points to. +~ +~ The helper's main responsibility is to deal with the scenario that +~ requires an SIB byte, which happens when the R/M field has a value of 4, +~ which would otherwise refer to the register rsp. In that situation, it also +~ generates an SIB byte which indicates a scale of 1, no indexing, and rsp as +~ the base register. +~ +~ When the register is :rbp, the only modes available also have +~ displacement; we disallow that. For that case, use an instruction that +~ uses a disp8 mode, and set a displacement of 0. +~ +~ In understanding this, pay close attention to the Op/En column in the +~ opcode table. The "RM" variant means the ModRM byte's R/M field (the third +~ one) is the source, while its reg field (the middle one) is the target. This +~ is what we want, because the R/M field is the one that gets indirection +~ applied to it. Opcode 0x8B with an REX.W prefix is the all-64-bit RM +~ variant. [Intel] volume 2B, chapter 4, section 4-3, "MOV". +~ +~ For the indirection modes, don't be confused by the many similar tables. +~ 64-bit mode is encoded the same as 32-bit mode except for adding a REX.W +~ prefix, as per 2.2.1.1, so you want table 2-2 to understand the ModRM byte. +~ The presence or absence of an SIB byte is determined by where in that table +~ we fall, and we aren't using a mode that has one. [Intel] volume 2A, +~ chapter 2, section 2-1.5, table 2-2. +~ +~ (output point, reg/op field value, reg/mem field register +~ -- output point) +: addressing-indirect-reg64 + ~ Exit with an error if the R/M register is :rbp. + dup :rbp != { + ~ Check whether the R/M register is :rsp. Save the test result for later. + dup :rsp = 4 unroll + ~ (equality result, output point, reg/op value, reg/mem name) + reg64 0 3unroll modrm + ~ (equality result, output point) + ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. + swap { + 0 4 :rsp reg64 + ~ : drop-subitem + sib + } if + exit + } if + ." R/M parameter to addressing-indirect-reg64 is :rbp." 1 sys-exit ; + +~ (output point, reg/op field value, reg/mem field register, +~ displacement value -- output point) +: addressing-disp8-reg64 + ~ This mode can do :rbp fine, so no need to check for that. + ~ Check whether the R/M register is :rsp. Save the test result for later. + swap dup :rsp = 5 unroll swap + ~ Stash the displacement value out of the way, too. + 4 unroll + reg64 1 3unroll modrm + ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. + 3roll { + 0 4 :rsp reg64 + ~ : drop-subitem + sib + } if + + ~ The displacement byte. + ~ + ~ When addressing-disp8-reg64 references a source, as in + ~ lea-reg64-disp8-reg64, the first two parameters of the assembly word + ~ calling it are the source register and the source displacement value. When + ~ it references a target or destination, as in mov-disp8-reg64-reg64, the + ~ LAST two parameters are the target registera and target displacement + ~ value. + ~ + ~ In both cases, the register comes first and the displacement value + ~ comes second. When these are used in a comment template without any other + ~ rearranging going on, whichever is on the top of the stack will be popped + ~ off first. So, we swap them here, thus putting the register on the top. + swap + ~ : 1 adjust-length + ~ : provide-hex8 + ~ : swap-subitems + pack8 ; + +~ (output point, reg/op field value, reg/mem field register, +~ displacement value -- output point) +: addressing-disp32-reg64 + ~ This mode can do :rbp fine, so no need to check for that. + ~ Check whether the R/M register is :rsp. Save the test result for later. + swap dup :rsp = 5 unroll swap + ~ Stash the displacement value out of the way, too. + 4 unroll + reg64 2 3unroll modrm + ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. + 3roll { + 0 4 :rsp reg64 + ~ : drop-subitem + sib + } if + + ~ The displacement value. This is subject to the same considerations as in + ~ addressing-disp8-reg64. + swap + ~ : 4 adjust-length + ~ : provide-hex32 + ~ : swap-subitems + pack32 ; + +~ (output point, reg/op field value, +~ scale factor, index register, base field register +~ -- output point) +: addressing-indexed-reg64 + ~ Exit with an error if the base register is :rbp. + dup :rbp != { + ~ Reg/mem value 4 means to use an SIB byte (at least, with this mode). + 5 roll 0 6 roll 4 modrm 4 unroll + reg64 3unroll reg64 3unroll scalefield 3unroll + ~ We want the scale factor to show after the registers, so we put it + ~ last on the stack. We also want the base register to show before the + ~ index register, so the base comes first. + ~ + ~ Importantly, we have to do this before the sib so it'll count as being + ~ inside the span the assembly word's description attaches to. + ~ + ~ : -3 roll-subitems + ~ : swap-subitems + sib + exit + } if + ." Base parameter to addressing-indexed-reg64 is :rbp." 1 sys-exit ; + +~ (output point, reg/op field value, +~ scale factor, index register, base field register, +~ displacement value -- output point) +: addressing-disp8-indexed-reg64 + ~ This mode can do :rbp fine, so no need to check for that. + ~ Reg/mem value 4 means to use an SIB byte (at least, with this mode). + 6 roll 1 7 roll 4 modrm 5 unroll + 5 unroll reg64 3unroll reg64 3unroll scalefield 3unroll sib + swap + ~ : 1 adjust-length + ~ : provide-hex8 + ~ + ~ We want the parameters to be shown in the order: + ~ + ~ base register, index register, index scale factor, displacement + ~ + ~ So, we put them on the stack in the opposite of that order. + ~ + ~ Importantly, we have to do this before the pack8 so it'll count as being + ~ inside the span the assembly word's description attaches to. + ~ + ~ : -4 roll-subitems + ~ : -3 roll-subitems + ~ : swap-subitems + pack8 + ; + + +~ Easy instructions +~ ~~~~~~~~~~~~~~~~~ +~ +~ It's not worth pretending there's a coherent category behind this +~ grouping. These are the ones that were easy to deal with. + +~ (output point -- output point) +: cld + ~ : 1 cld + 0xFC pack8 ; +: std + ~ : 1 std + 0xFD pack8 ; +: syscall + ~ : 2 syscall + 0x0F pack8 0x05 pack8 ; +: hlt + ~ : 1 hlt + 0xF4 pack8 ; + +~ (output point, source register -- output point) +: push-reg64 + ~ : 0 # push-reg64 + reg64 0x50 opcodereg ; +: push-extrareg64 + ~ : 0 # push-extrareg64 + swap rex-b swap extrareg64 0x50 opcodereg ; + ~ Note the use of the B rex bit here; this instruction puts the register + ~ number in the opcode field, so it uses Table 3-1. + +~ (output point, target register -- output point) +: pop-reg64 + ~ : 0 # pop-reg64 + reg64 0x58 opcodereg ; +: pop-extrareg64 + ~ : 0 # pop-extrareg64 + swap rex-b swap extrareg64 0x58 opcodereg ; + ~ Note the use of the B rex bit here; this instruction puts the register + ~ number in the opcode field, so it uses Table 3-1. + +~ (output point, immediate value -- output point) +: push-imm32-extended64 + ~ : 5 # push-imm32-extended64 + swap 0x68 pack8 swap + ~ : provide-hex + pack32 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: lea-reg64-disp8-reg64 + ~ : 1 # # # lea-reg64-disp8-reg64 + 4 roll rex-w 0x8D pack8 4 unroll + reg64 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: lea-reg64-disp32-reg64 + ~ : 1 # # # lea-reg64-disp32-reg64 + 4 roll rex-w 0x8D pack8 4 unroll + reg64 3unroll addressing-disp32-reg64 ; + +~ (output point, +~ source base register, source index register, source index scale factor, +~ target register -- output point) +: lea-reg64-indexed-reg64 + ~ : 1 # # # # lea-reg64-indexed-reg64 + 5 roll rex-w 0x8D pack8 5 unroll + reg64 4 unroll 3unroll swap addressing-indexed-reg64 ; + +~ (output point, +~ source base register, source index register, source index scale factor, +~ source displacement value, +~ target register -- output point) +: lea-reg64-disp8-indexed-reg64 + ~ : 1 # # # # # lea-reg64-disp8-indexed-reg64 + 6 roll rex-w 0x8D pack8 6 unroll + reg64 5 unroll 3 roll 4 roll 3 roll addressing-disp8-indexed-reg64 ; + + +~ Move instructions +~ ~~~~~~~~~~~~~~~~~ +~ +~ These are, like, MOST of what we care about, so they get their own +~ section. Although it's very much the case that almost every two-operand +~ instruction offers this many distinct modes, we don't care about most of +~ those and don't yet implement them. We do care about all the modes for move +~ instructions. +~ +~ Someday perhaps we'll have extra-high-level features which generate all +~ the distinct versions of each instruction in a concise way, but that is not +~ this day. + +~ (output point, immediate value, register -- output point) +: mov-reg64-imm32 + ~ : 5 # # mov-reg64-imm32 + 3roll + rex-w 0xC7 pack8 swap + 0 swap addressing-reg64 + swap + ~ : provide-hex + pack32 ; +: mov-reg64-imm64 + ~ : 8 # # mov-reg64-imm64 + 3roll rex-w swap reg64 0xB8 opcodereg swap + ~ : provide-hex + pack64 ; +: mov-extrareg64-imm64 + ~ : 8 # # mov-extrareg64-imm64 + ~ Note the use of the B rex bit here; this instruction puts the register + ~ number in the opcode field, so it uses Table 3-1. + 3roll rex-wb swap extrareg64 0xB8 opcodereg swap + ~ : provide-hex + pack64 ; + +~ (output point, source register, target register -- output point) +: mov-reg64-reg64 + ~ : 1 # # mov-reg64-reg64 + 3roll rex-w 0x89 pack8 3unroll + swap reg64 swap addressing-reg64 + ~ : swap-subitems + ; +: mov-indirect-reg64-reg64 + ~ : 1 # # mov-indirect-reg64-reg64 + 3roll rex-w 0x89 pack8 3unroll + swap reg64 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg64 + ~ : 1 # # # mov-disp8-reg64-reg64 + 4 roll rex-w 0x89 pack8 4 unroll + 3roll reg64 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg64-indirect-reg64 + ~ : 1 # # mov-reg64-indirect-reg64 + 3roll rex-w 0x8B pack8 3unroll + reg64 swap addressing-indirect-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: mov-reg64-disp8-reg64 + ~ : 1 # # # mov-reg64-disp8-reg64 + 4 roll rex-w 0x8B pack8 4 unroll + reg64 3unroll addressing-disp8-reg64 ; +: mov-reg64-disp32-reg64 + ~ : 1 # # # mov-reg64-disp32-reg64 + 4 roll rex-w 0x89 pack8 4 unroll + 3roll reg64 swap 3roll addressing-disp32-reg64 + ~ : swap-subitems + ~ : 3 roll-subitems + ; + +~ (output point, +~ source base register, source index register, source index scale factor, +~ target register -- output point) +: mov-reg64-indexed-reg64 + ~ : 1 # # # # mov-reg64-indexed-reg64 + 5 roll rex-w 0x8B pack8 5 unroll + reg64 4 unroll 3unroll swap addressing-indexed-reg64 ; + +~ (output point, source register, +~ target base register, target index register, target index scale factor +~ -- output point) +: mov-indexed-reg64-reg64 + ~ : 1 # # # # mov-indexed-reg64-reg64 + 5 roll rex-w 0x89 pack8 5 unroll + 4 roll reg64 4 unroll + 3unroll swap addressing-indexed-reg64 + ~ : 4 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-indirect-reg64-reg32 + ~ : 1 # # mov-indirect-reg64-reg32 + 3roll 0x89 pack8 3unroll + swap reg32 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg32 + ~ : 1 # # # mov-disp8-reg64-reg32 + 4 roll 0x89 pack8 4 unroll + 3roll reg32 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg32-indirect-reg64 + ~ : 1 # # mov-reg32-indirect-reg64 + 3roll 0x8B pack8 3unroll + reg32 swap addressing-indirect-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: mov-reg32-disp8-reg64 + ~ : 1 # # # mov-reg32-disp8-reg64 + 4 roll 0x8B pack8 4 unroll + reg32 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, target register -- output point) +: mov-indirect-reg64-reg16 + ~ : 2 # # mov-indirect-reg64-reg16 + 3roll 0x66 pack8 0x89 pack8 3unroll + swap reg16 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg16 + ~ : 2 # # # mov-disp8-reg64-reg16 + 4 roll 0x66 pack8 0x89 pack8 4 unroll + 3roll reg16 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg16-indirect-reg64 + ~ : 2 # # mov-reg16-indirect-reg64 + 3roll 0x66 pack8 0x8B pack8 3unroll + reg16 swap addressing-indirect-reg64 ; + +~ (output point, source register, target displacement value, target register +~ -- output point) +: mov-reg16-disp8-reg64 + ~ : 2 # # # mov-reg16-disp8-reg64 + 4 roll 0x66 pack8 0x8B pack8 4 unroll + reg16 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, target register -- output point) +: mov-indirect-reg64-reg8 + ~ : 1 # # mov-indirect-reg64-reg8 + 3roll 0x88 pack8 3unroll + swap reg8 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg8 + ~ : 1 # # # mov-disp8-reg64-reg8 + 4 roll 0x88 pack8 4 unroll + 3roll reg8 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg8-indirect-reg64 + ~ : 1 # # mov-reg8-indirect-reg64 + 3roll 0x8A pack8 3unroll + reg8 swap addressing-indirect-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: mov-reg8-disp8-reg64 + ~ : 2 # # # mov-reg8-disp8-reg64 + 4 roll 0x8A pack8 4 unroll + reg8 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, target register -- output point) +: mov-reg8-reg8 + ~ : 1 # # mov-reg8-reg8 + 3roll 0x88 pack8 3unroll + swap reg8 swap addressing-reg8 + ~ : swap-subitems + ; + + +~ String instructions +~ ~~~~~~~~~~~~~~~~~~~ +~ +~ These are in their own section because there's an awful lot of +~ combinations, and fortunately they are very uniform in structure. +~ +~ What makes these useful is that they take their parameters from certain +~ fixed registers, which are chosen such that the operations chain into each +~ other well. Thus you can use them to build various block-memory and string +~ operations, and even if you need unusual forms of loop unrolling or +~ alignment tweaking, the code will end up uniform in structure. On modern +~ processors, this is even the high-performance approach, due to highly +~ optimized microcode, though these operations were inefficient when they +~ were first invented. +~ +~ We break with the Intel mnemonics, which follow the pattern +~ movsb/movsw/movsd/movsq, because this would otherwise be the only place we +~ use the b/w/d/q thing instead of 8/16/32/64. Tradition and pronounceability +~ are both nice things, but approachability to newcomers is important, too. +~ +~ Some of these are repeatable; whether you view the repeatable variants +~ as different instructions is up to you. At any rate the machine code +~ representation of the repeatable variants is the same as for the regular +~ variants with an extra prefix, so we define them together. +~ +~ This is a proper superset of the flatassembler implementations of string +~ instructions. The wisdom of that is questionable, but at least it's noted +~ here... + +~ (output point -- output point) +: movs8 + ~ : 1 movs8 + 0xA4 pack8 ; +: movs16 + ~ : 2 movs16 + 0x66 pack8 0xA5 pack8 ; +: movs32 + ~ : 1 movs32 + 0xA5 pack8 ; +: movs64 + ~ : 1 movs64 + rex-w 0xA5 pack8 ; +: rep-movs8 + ~ : 2 rep-movs8 + 0xF3 pack8 0xA4 pack8 ; +: rep-movs16 + ~ : 3 rep-movs16 + 0xF3 pack8 0x66 pack8 0xA5 pack8 ; +: rep-movs32 + ~ : 2 rep-movs32 + 0xF3 pack8 0xA5 pack8 ; +: rep-movs64 + ~ : 2 rep-movs64 + 0xF3 pack8 rex-w 0xA5 pack8 ; + +~ (output point -- output point) +: lods8 + ~ : 1 lods8 + 0xAC pack8 ; +: lods16 + ~ : 2 lods16 + 0x66 pack8 0xAd pack8 ; +: lods32 + ~ : 1 lods32 + 0xAD pack8 ; +: lods64 + ~ : 1 lods64 + rex-w 0xAD pack8 ; +: rep-lods8 + ~ : 2 rep-lods8 + 0xF3 pack8 0xAC pack8 ; +: rep-lods16 + ~ : 3 rep-lods16 + 0xF3 pack8 0x66 pack8 0xAD pack8 ; +: rep-lods32 + ~ : 2 rep-lods32 + 0xF3 pack8 0xAD pack8 ; +: rep-lods64 + ~ : 2 rep-lods64 + 0xF3 pack8 rex-w 0xAD pack8 ; + +~ (output point -- output point) +: stos8 + ~ : 1 stos8 + 0xAA pack8 ; +: stos16 + ~ : 2 stos16 + 0x66 pack8 0xAB pack8 ; +: stos32 + ~ : 1 stos32 + 0xAB pack8 ; +: stos64 + ~ : 1 stos64 + rex-w 0xAB pack8 ; +: rep-stos8 + ~ : 2 rep-stos8 + 0xF3 pack8 0xAA pack8 ; +: rep-stos16 + ~ : 3 rep-stos16 + 0xF3 pack8 0x66 pack8 0xAB pack8 ; +: rep-stos32 + ~ : 2 rep-stos32 + 0xF3 pack8 0xAB pack8 ; +: rep-stos64 + ~ : 2 rep-stos64 + 0xF3 pack8 rex-w 0xAB pack8 ; + +~ (output point -- output point) +: cmps8 + ~ : 1 cmps8 + 0xA6 pack8 ; +: cmps16 + ~ : 2 cmps16 + 0x66 pack8 0xA7 pack8 ; +: cmps32 + ~ : 1 cmps32 + 0xA7 pack8 ; +: cmps64 + ~ : 1 cmps64 + rex-w 0xA7 pack8 ; +: repz-cmps8 + ~ : 2 repz-cmps8 + 0xF3 pack8 0xA6 pack8 ; +: repz-cmps16 + ~ : 3 repz-cmps16 + 0xF3 pack8 0x66 pack8 0xA7 pack8 ; +: repz-cmps32 + ~ : 2 repz-cmps32 + 0xF3 pack8 0xA7 pack8 ; +: repz-cmps64 + ~ : 2 repz-cmps64 + 0xF3 pack8 rex-w 0xA7 pack8 ; +: repnz-cmps8 + ~ : 2 repnz-cmps8 + 0xF2 pack8 0xA6 pack8 ; +: repnz-cmps16 + ~ : 3 repnz-cmps16 + 0xF2 pack8 0x66 pack8 0xA7 pack8 ; +: repnz-cmps32 + ~ : 2 repnz-cmps32 + 0xF2 pack8 0xA7 pack8 ; +: repnz-cmps64 + ~ : 2 repnz-cmps64 + 0xF2 pack8 rex-w 0xA7 pack8 ; + +~ (output point -- output point) +: scas8 + ~ : 1 scas8 + 0xA8 pack8 ; +: scas16 + ~ : 2 scas16 + 0x66 pack8 0xAF pack8 ; +: scas32 + ~ : 1 scas32 + 0xAF pack8 ; +: scas64 + ~ : 1 scas64 + rex-w 0xAF pack8 ; +: repz-scas8 + ~ : 2 repz-scas8 + 0xF3 pack8 0xAE pack8 ; +: repz-scas16 + ~ : 3 repz-scas16 + 0xF3 pack8 0x66 pack8 0xAF pack8 ; +: repz-scas32 + ~ : 2 repz-scas32 + 0xF3 pack8 0xAF pack8 ; +: repz-scas64 + ~ : 2 repz-scas64 + 0xF3 pack8 rex-w 0xAF pack8 ; +: repnz-scas8 + ~ : 2 repnz-scas8 + 0xF2 pack8 0xAE pack8 ; +: repnz-scas16 + ~ : 3 repnz-scas16 + 0xF2 pack8 0x66 pack8 0xAF pack8 ; +: repnz-scas32 + ~ : 2 repnz-scas32 + 0xF2 pack8 0xAF pack8 ; +: repnz-scas64 + ~ : 2 repnz-scas64 + 0xF2 pack8 rex-w 0xAF pack8 ; + + +~ Arithmetic instructions +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Operations between two registers always have the target register as the +~ last parameter. Operations between a register and an immediate ALSO have the +~ target register as the last parameter, which is obvious for add-reg64-imm8 +~ but can be confusing for sub-reg64-imm8 or cmp-reg64-imm8. Also note what +~ this means for sub-reg64-reg64 and cmp-reg64-reg64. +~ +~ Every possible convention here leads to counterintuitive behavior in some +~ cases. This one has proven to be more memorable than the other obvious +~ choices, and that'll have to be enough. + +~ (output point, source register, target register -- output point) +: add-reg64-reg64 + ~ : 1 # # add-reg64-reg64 + 3roll rex-w 0x01 pack8 3unroll + swap reg64 swap addressing-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register -- output point) +: add-indirect-reg64-reg64 + ~ : 1 # # add-indirect-reg64-reg64 + 3roll rex-w 0x01 pack8 3unroll + swap reg64 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register -- output point) +: add-reg64-indirect-reg64 + ~ : 1 # # add-reg64-indirect-reg64 + 3roll rex-w 0x03 pack8 3unroll + reg64 swap addressing-indirect-reg64 ; + +~ (output point, immediate value, target register -- output point) +: add-reg64-imm8 + ~ : 2 # # add-reg64-imm8 + 3roll rex-w 0x83 pack8 swap 0 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ See above re: parameter order. +~ +~ (output point, source register, target register -- output point) +: sub-reg64-reg64 + ~ : 1 # # sub-reg64-reg64 + 3roll rex-w 0x2B pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, source register, target register -- output point) +: sub-indirect-reg64-reg64 + ~ : 1 # # sub-indirect-reg64-reg64 + 3roll rex-w 0x2B pack8 3unroll + swap reg64 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ See above re: parameter order. +~ +~ (output point, immediate value, target register -- output point) +: sub-reg64-imm8 + ~ : 2 # # sub-reg64-imm8 + 3roll rex-w 0x83 pack8 swap 5 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ See above re: parameter order. +~ +~ (output point, source register, target register -- output point) +: sbb-reg64-imm8 + ~ : 2 # # sbb-reg64-imm8 + 3roll rex-w 0x83 pack8 swap 3 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ The target register is always rax. +~ +~ (output point, source register -- output point) +: mul-reg64 + ~ : 1 # mul-reg64 + swap rex-w 0xF7 pack8 swap + 4 swap addressing-reg64 ; + +~ The dividend is 128 bits, and is formed from rdx as the high half and rax +~ as the low half. The divisor is a specified register. The quotient is +~ returned in rax, truncated towards zero. The remainder is in rdx. This +~ entire process is unsigned. +~ +~ The official mnemonic for this is "div", but divmod is what it does. +~ +~ (output point, divisor register -- output point) +: divmod-reg64 + ~ : 1 # divmod-reg64 + swap rex-w 0xF7 pack8 swap + 6 swap addressing-reg64 ; + +~ Same as divmod, but signed. +~ +~ (output point, divisor register -- output point) +: idivmod-reg64 + ~ : 1 # idivmod-reg64 + swap rex-w 0xF7 pack8 swap + 7 swap addressing-reg64 ; + +~ (output point, target register -- output point) +: inc-reg64 + ~ : 1 # inc-reg64 + swap rex-w 0xFF pack8 swap 0 swap addressing-reg64 ; + +~ (output point, target register -- output point) +: dec-reg64 + ~ : 1 # dec-reg64 + swap rex-w 0xFF pack8 swap 1 swap addressing-reg64 ; + +~ (output point, source register, target register -- output point) +: and-reg64-reg64 + ~ : 1 # # and-reg64-reg64 + 3roll rex-w 0x23 pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, source value, target register -- output point) +: and-reg64-imm8 + ~ : 2 # # and-reg64-imm8 + 3roll rex-w 0x83 pack8 swap + 4 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, source register, target register -- output point) +: or-reg64-reg64 + ~ : 1 # # or-reg64-reg64 + 3roll rex-w 0x0B pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, source value, target register -- output point) +: or-reg64-imm8 + ~ : 2 # # or-reg64-imm8 + 3roll rex-w 0x83 pack8 swap + 1 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, source register, target register -- output point) +: xor-reg64-reg64 + ~ : 1 # # xor-reg64-reg64 + 3roll rex-w 0x33 pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, target register -- output point) +: not-reg64 + ~ : 1 # not-reg64 + swap rex-w 0xF7 pack8 + swap 2 swap addressing-reg64 ; + +~ (output point, bit count, target register -- output point) +: rol-reg64-imm8 + ~ : 2 # # rol-reg64-imm8 + 3roll rex-w 0xC1 pack8 swap + 0 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, bit count, target register -- output point) +: rol-reg8-imm8 + ~ : 2 # # rol-reg8-imm8 + 3roll 0xC0 pack8 swap + 0 swap addressing-reg8 + swap + ~ : provide-hex + pack8 ; + +~ (output point, bit count, target register -- output point) +: ror-reg64-imm8 + ~ : 1 # # ror-reg64-imm8 + 3roll rex-w 0xC1 pack8 swap + 1 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, bit count, target register -- output point) +: ror-reg8-imm8 + ~ : 2 # # ror-reg8-imm8 + 3roll 0xC0 pack8 swap + 1 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + + +~ Control flow instructions +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The comparator instructions cmp and test follow the same argument-order +~ conventions as the arithmetic instructions: The target register always comes +~ last. See the arithmetic section for more discussion. + +~ Pretend to subtract right from left, and set the flags the same way as if +~ we actually had. +~ +~ (output point, left register, right register -- output point) +: cmp-reg64-reg64 + ~ : 1 # # cmp-reg64-reg64 + 3roll rex-w 0x3B pack8 3unroll + reg64 swap addressing-reg64 ; + +~ See above re: parameter order. +~ +~ (output point, immediate value, target register -- output point) +: cmp-reg64-imm8 + ~ : 2 # # cmp-reg64-imm8 + 3roll rex-w 0x83 pack8 + ~ (immediate value, register, output point) + swap 7 swap addressing-reg64 + ~ ( output point, immediate value) + swap + ~ : provide-hex + pack8 ; + +~ Pretend to bitwise-and left with right, and set the flags the same way as +~ if we actually had. +~ +~ The names of the condition codes can be a little confusing when using them +~ after "test", because they're really premised on the idea that you did +~ "cmp". +~ +~ (output point, left register, right register -- output point) +: test-reg64-reg64 + ~ : 1 # # test-reg64-reg64 + 3roll rex-w 0x85 pack8 3unroll + swap reg64 swap addressing-reg64 + ~ : swap-subitems + ; + +~ (output point, condition code, target register -- output point) +: set-reg8-cc + ~ : 1 # # set-reg8-cc + 3roll 0x0F pack8 + 3roll condition-code 0x90 opcodecc + swap reg8 3 0 3roll modrm + ~ : swap-subitems + ; + +~ (output point, address offset value, condition code -- output point) +: jmp-cc-rel-imm8 + ~ : 1 # # jmp-cc-rel-imm8 + 3roll swap condition-code 0x70 opcodecc + swap + ~ : provide-hex + pack8 ; + +~ (output point, address offset value, condition code -- output point) +: jmp-cc-rel-imm32 + ~ : 5 # # jmp-cc-rel-imm32 + 3roll 0x0F pack8 + swap condition-code 0x70 opcodecc + swap + ~ : provide-hex + pack32 ; + +~ (output point, register -- output point) +: jmp-abs-indirect-reg64 + ~ : 1 # jmp-abs-indirect-reg64 + swap 0xFF pack8 swap + 4 swap addressing-indirect-reg64 ; + +~ (output point, address offset value -- output point) +: jmp-rel-imm8 + ~ : 2 # jmp-rel-imm8 + swap 0xEB pack8 + swap + ~ : provide-hex + pack8 ; + +~ (output point, address offset value -- output point) +: jmp-rel-imm32 + ~ : 5 # jmp-rel-imm32 + swap 0xE9 pack8 + swap + ~ : provide-hex + pack32 ; + +~ This is technically a "near" call. The name intentionally doesn't say so. +~ +~ (output point, address offset value -- output point) +: call-rel-imm32 + ~ : 5 # call-rel-imm32 + swap 0xE8 pack8 + swap + ~ : provide-hex + pack32 ; + +~ Similarly, this is a "near" return. +~ +~ (output point) +: ret + ~ : 1 ret + 0xC3 pack8 ; + diff --git a/language/static/core.e b/language/static/core.e new file mode 100644 index 0000000..10d5d61 --- /dev/null +++ b/language/static/core.e @@ -0,0 +1,1371 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Core Forth features ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ This file provides extremely fundamental functionality which is a +~ necessary component of any Forth dialect, including Evocation. It is +~ included statically as part of any generated executable, and a second copy +~ of it is later copied into the log when that executable runs. Therefore, it +~ is written to obey the constraints of both the label transform, and the +~ log-load transform; see compilation/transform.e for more details on that. + + +~ Execution support +~ ~~~~~~~~~~~~~~~~~ +~ +~ There's two words, docol and exit, which are essential parts of the +~ indirect-threaded execution model. It would be tempting to put them in +~ compilation/execution.e, so they'd be closer to the explanation of what they +~ do, but we need two copies of them (just like we do of every other word in +~ this file), one statically compiled and one in the log. So, they're here, +~ because that's significantly simpler, even though it creates a little bit of +~ extra work for the label transform. + + +~ Docol is the "interpreter" that is responsible for the semantics of words +~ written as Forth high-level code. The name is said to be short for +~ "do colon", because word definitions begin with a colon. +~ +~ Concretely, when interpreting, it saves rsi (the "instruction pointer") to +~ the control stack, takes the address of the codeword from rax and increments +~ it in-place to form the new instruction pointer, and copies that to rsi. +~ +~ Having then done this, we're now in the state that normal execution +~ expects, so docol ends by it using "next" to begin the callee's execution, +~ kicking off a nested call. +~ +~ At runtime, invoke docol directly and it will return the value that should +~ be used as a codeword. When compiling to a binary executable, the +~ transformation facility needs to reference it directly, and for that +~ purpose, the label "docol-codeword-value" points to the correct place. +~ +~ Registers in: +~ +~ * rsi is the caller's instruction pointer +~ * rbp is the control stack pointer +~ * rax is the address of the callee's codeword +~ +~ Registers out: +~ +~ * rsi is the callee's instruction pointer +~ * rbp is the control stack pointer + +~ We need this one snippet of assembly code that's just on the log raw, +~ without a word header, because of its role in making words work. We define +~ a label pointing to it. +~ +~ This is the only use of labels in core.e. There's no easy way to +~ remove it. We can't use immediate computation based on "here" because +~ the label transform uses the host address space, not the target address +~ space. The transformation facility's support for labels in transformed +~ code was added just for this. +~ +~ It may seem as if we could have used some extra space in the middle of +~ the proper docol word, which is defined just below. That would work fine +~ with the label transform, which can do forward references, but the log-load +~ transform's label support is special-cased to ONLY do this, and it will only +~ work with a backward reference. +~ +~ We begin by outputting the actual docol routine, the one that codewords +~ should point to. Note that this is before we've done any word header. +~ +~ : This is the actual docol routine, the interpreter which is pointed to by +~ : the codeword of every interpreted word. It does not itself have an entry +~ : in the dictionary; the word "docol" will return a pointer to this routine. +~ : The word's entry follows immediately after the routine. +~ : indent +here @ +dup L!' docol-codeword-value +:rsi pack-pushcontrol +8 :rax add-reg64-imm8 +:rax :rsi mov-reg64-reg64 +pack-next +8 packalign +here ! +~ : deindent + +~ We can't use colon to create docol, not even the part that's a word, +~ because colon tries to dynamically invoke docol to fill in the codeword. +~ : blank-line +~ : This is the dictionary entry for docol. +~ : indent +s" docol" create +self-codeword +here @ +L@' docol-codeword-value :rax mov-reg64-imm64 +:rax push-reg64 +pack-next +8 packalign +here ! +~ : deindent +~ Now that we have docol, colon will work and we can define words the normal +~ way. + +~ This is the mechanism to "return" from a word interpreted by docol. +~ We pop the control stack, and then, since this is threaded execution, we +~ do the next thing the caller wants to do, by inlining "next". +: exit + [ here @ + :rsi pack-popcontrol + here ! ] ;asm + +~ Now that we have exit, semicolon will also work and we can define +~ non-assembly words. However, it will be hard to make them do much until we +~ have lit as well. There's no special hurry; most of the words in core.e are +~ assembly words. We'll get to it further down. + + +~ Stack manipulation routines +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ We start with the three traditional stack operations, swap drop and +~ roll. Sorry to fans of the name "ROT"; we were an HP calculator kid. It'll +~ always be roll to us. Anyway, we do a couple other operations too. Since +~ our goal right now is just to bootstrap the heap, we keep this short and +~ sweet. +~ +~ This code has been written to satisfy the assumptions needed by the label +~ transform, described in-depth in compilation/transform.e. This means that it +~ is, in effect, written in a restricted dialect of Evocation rather than in +~ the full language. +~ +~ There is definitely plenty of optimization that could be done. + +: swap + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rax push-reg64 + :rbx push-reg64 + here ! ] ;asm + +: drop + [ here @ + :rax pop-reg64 + here ! ] ;asm + +: 2drop + [ here @ + :rax pop-reg64 + :rax pop-reg64 + here ! ] ;asm + +~ Rotates "up" (pops its parameter, n; nth item then becomes current item). +~ +~ We implement this the high-performance way, with rep movsq, aka the +~ instruction that exists to optimize C's memcpy(). The details of setting +~ that up are complex; see below. +: roll + [ here @ + + ~ Pop our parameter. The rep instruction takes rcx as its count, so we + ~ reduce copying by using it to hold our count, as well. + :rcx pop-reg64 + + ~ We have n - 1 items to slide, so decrement rcx. For the purpose of + ~ counting how many repetitions will happen, it's one-based. This is because + ~ the rep instruction performs a single movsq, then decrements rcx, then + ~ stops if rcx is zero. + :rcx dec-reg64 + + ~ Retrieve the nth item, for later. For this purpose we're thinking in + ~ zero-based terms, so we do this after already having decremented rcx. + :rsp :rcx 8 :rbx mov-reg64-indexed-reg64 + + ~ The source address for movsq is rsi and the destination is rdi; we can + ~ use rdi as we wish, but rsi is our Forth "instruction pointer", so we must + ~ save and restore it. Doing so alters rsp, so we have to adjust the address + ~ calculations by eight bytes as compared to the expressions above, but + ~ happily we can use the disp8 field to do that. We'd be using disp8 anyway + ~ because it's helpful. + :rsi push-reg64 + + ~ Now we set up parameters for the memory-sliding operation. We have + ~ n - 1 items to copy, moving the range rsp through rsp + (n-2)*8 onto the + ~ range rsp + 8 through rsp + (n-1)*8. That's with the value of rsp as it + ~ exists at this moment (it's going to change soon). + ~ + ~ We're sliding them upwards in memory, so we start at the high end so + ~ that we're always moving into a location that doesn't have anything + ~ precious. We use lea as a convenient way to do the stack math. + ~ + ~ When rcx is 1, we want rsp + 8. + :rsp :rcx 8 :rsi lea-reg64-indexed-reg64 + ~ When rcx is 1, we want rsp + 16. + :rsp :rcx 8 8 :rdi lea-reg64-disp8-indexed-reg64 + ~ + ~ Using rcx = 1 is the most convenient example to use for figuring out the + ~ arithmetic. It's a linear relationship, so as long as we get the 8-byte + ~ stride correct, we just need to pick a single point and verify that our + ~ math is right for that point, and it'll be right for any value of rcx. + + ~ Another of our Forth conventions is that the DF flag should be kept at + ~ zero, which directs string instruction to increment rsi. Here, however, + ~ because our source and destination ranges overlap, we need to start at the + ~ high end, which means we need it to decrement. So we set DF to one, and + ~ we'll clear it after. + std + rep-movs64 + + ~ Set everything back. + cld + :rsi pop-reg64 + + ~ There is now an extra item at the low end of the stack (the top) that + ~ needs to go away, and coincidentally we have a value in rbx that needs to + ~ be in that spot. Rather than doing a drop and push, we overwrite it, to + ~ save a little work. + :rbx :rsp mov-indirect-reg64-reg64 + + ~ All done, wow! What a mouthful. + here ! ] ;asm + +~ Rotates "down" (pops its parameter, n; current item then becomes nth +~ item). +~ +~ Jonesforth calls this "-roll" and we could do that, but honestly the name +~ unroll sounds nicer and it's only a single character longer. You might say +~ it rolls off the tongue better. +~ +~ We implement this the high-performance way, with rep movsq, aka the +~ instruction that exists to optimize C's memcpy(). The details of setting +~ that up are complex; see below. +: unroll + [ here @ + + ~ Pop our parameter. The rep instruction takes rcx as its count, so we + ~ reduce copying by using it to hold our count, as well. + :rcx pop-reg64 + + ~ We have n - 1 items to slide, so decrement rcx. Also, save a copy of it in + ~ rdx after doing that, for later. + :rcx dec-reg64 + :rcx :rdx mov-reg64-reg64 + + ~ Retrieve the 0th item, for later. + :rsp :rbx mov-reg64-indirect-reg64 + + ~ Now we set up parameters for the memory-sliding operation. We have + ~ n - 1 items to copy, moving the range rsp + 8 through rsp + (n-1)*8 onto + ~ the range rsp through rsp + (n-2)*8. That's with the value of rsp as it + ~ exists at this moment (it's going to change soon). + ~ + ~ We're sliding them downwards in memory, so we start at the low end so + ~ that we're always moving into a location that doesn't have anything + ~ precious. We use lea as a convenient way to do the stack math. + ~ + ~ As with roll, we need to save rsi and adjust those rsp calculations + ~ accordingly. + :rsi push-reg64 + + ~ Regardless of rcx, we want rsp + 16. + :rsp 16 :rsi lea-reg64-disp8-reg64 + ~ Regardless of rcx, we want rsp + 8. + :rsp 8 :rdi lea-reg64-disp8-reg64 + + ~ With roll, we were starting at the high end. Here, we start at the low + ~ end, which means we need rsi to increment after each repetition. That's + ~ what it does when the DF flag is clear, and another of our Forth + ~ conventions is to keep it clear normally. So, we don't have to touch DF! + ~ Yay! + rep-movs64 + + ~ Restore our original rsi. + :rsi pop-reg64 + + ~ There is now an extra item in the middle of the stack, at the high end of + ~ the sliding we did, that needs to be overwritten with our value in rbx. + ~ Since we destructively updated our count in rcx, we saved a copy of the + ~ count in rdx, and we use that to find the right address. + ~ + ~ When the original count was n, we want rsp + (n-1)*8, so we saved rdx + ~ after decrementing rcx, above. + :rbx :rsp :rdx 8 mov-indexed-reg64-reg64 + + ~ All done, wow! What a mouthful. + here ! ] ;asm + +~ Rotates "up" (third item becomes current item) +: 3roll + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rcx pop-reg64 + :rbx push-reg64 + :rax push-reg64 + :rcx push-reg64 + here ! ] ;asm + +~ Rotates "down" (current item becomes third item) +: 3unroll + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rcx pop-reg64 + :rax push-reg64 + :rcx push-reg64 + :rbx push-reg64 + here ! ] ;asm + +: dup + [ here @ + :rax pop-reg64 + :rax push-reg64 + :rax push-reg64 + here ! ] ;asm + +: 2dup + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx push-reg64 + :rax push-reg64 + :rbx push-reg64 + :rax push-reg64 + here ! ] ;asm + + +~ Arithmetic routines +~ ~~~~~~~~~~~~~~~~~~~ +~ +~ No surprises here. Again, since our goal is to bootstrap the heap, we +~ keep it short. Also again, this is nowhere near optimal. + +: + + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax add-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: - + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax sub-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: * + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx mul-reg64 + :rax push-reg64 + here ! ] ;asm + +~ Jonesforth calls this "/mod" but % is widely recognized and has no special +~ Forth significance. +: /% + [ here @ + :rdx :rdx xor-reg64-reg64 ~ rdx is the high bits of the input; zero it + :rbx pop-reg64 + :rax pop-reg64 + :rbx divmod-reg64 + :rdx push-reg64 ~ remainder + :rax push-reg64 ~ quotient + here ! ] ;asm + +~ We define a pair of words that increment and decrement a single item. +~ These were inspired by Common Lisp, where they're constantly useful. +: 1+ + [ here @ + :rax pop-reg64 + :rax inc-reg64 + :rax push-reg64 + here ! ] ;asm + +: 1- + [ here @ + :rax pop-reg64 + :rax dec-reg64 + :rax push-reg64 + here ! ] ;asm + + +~ Comparison routines +~ ~~~~~~~~~~~~~~~~~~~ +~ +~ So. This is subtle. These comparison routines all have the same structure. +~ Notice that = and != are commutative, whereas the others are not, so +~ consider > as the archetypical one when reasoning about correctness. To +~ test if A > B, we do cmp A, B, which sets the flags the same way as +~ subtracting B from A does. The mnemonic names of the condition codes are +~ based on the assumption you do it in this order. +~ +~ We want to treat the top of the stack as the first operand, so we +~ carefully pop in the appropriate order. +~ +~ There are both signed and unsigned variants of the condition codes. We +~ provide both; the unmarked comparisons such as > and <= are signed, while +~ the marked ones such as >unsigned and <=unsigned are of course unsigned. + +~ Jonesforth calls this "="; most languages would call it "==". +: = + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Jonesforth calls this "<>", but even most modern SQL dialects recognize +~ C's legacy and allow "!=" these days. As someone who learned C in childhood, +~ this is not actually a hard call for us. +: != + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-not-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than the second item in the stack, when +~ both are treated as signed? +: > + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-greater :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than the second item in the stack, when both +~ are treated as signed? +: < + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-less :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than or equal to the second item in the +~ stack, when both are treated as signed? +: >= + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-greater-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than or equal to the second item in the +~ stack, when both are treated as signed? +: <= + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-less-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than the second item in the stack, when +~ both are treated as unsigned? +: >unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-above :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than the second item in the stack, when +~ both are treated as unsigned? +: =unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-above-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than or equal to the second item in the +~ stack, when both are treated as unsigned? +: <=unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-below-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + + +~ Bitwise routines +~ ~~~~~~~~~~~~~~~~ +~ + +: & + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax and-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: | + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax or-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: xor + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax xor-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +~ The HP overloads the name "not", so we follow the Forth convention. +: invert + [ here @ + :rax pop-reg64 + :rax not-reg64 + :rax push-reg64 + here ! ] ;asm + + +~ Literal routines +~ ~~~~~~~~~~~~~~~~ +~ +~ These words are rarely used directly from user code, but are emitted by +~ the interpreter, in compile mode. They allow literal values of various kinds +~ to exist inline as part of compiled code, which would otherwise be only an +~ array of codeword pointers. They do this, in their various ways, by pushing +~ any appropriate value on the stack and making sure execution skips over the +~ bytes used to represent it. + +: lit + [ here @ + lods64 + :rax push-reg64 + here ! ] ;asm + +: litstring + [ here @ + ~ The string immediately follows the codeword in memory, so rsi is + ~ already pointing to it. That address will be our returned result, so we + ~ push it to the stack. + :rsi push-reg64 + + ~ Now we need to skip over the string, so that rsi will be valid for the + ~ next Forth word. To do that, we're going to do a string operation with + ~ scas8, which takes rdi as the address to look at. This means scas8 is + ~ treating its operand as analogous to the destination operand of movs*. + :rsi :rdi mov-reg64-reg64 + ~ We want to compare for equality with zero; scas8 looks in al for the + ~ other half of the comparison, so we clear rax. + :rax :rax xor-reg64-reg64 + ~ Counterintuitively, we do need to pass a count. We pass -1, which will + ~ always work. + :rcx :rcx xor-reg64-reg64 + :rcx not-reg64 + ~ The DF flag is zero per our Forth execution-model convention, which + ~ means scas8 increments rdi after each iteration. This is what we want, + ~ so there's no need to mess with it. + ~ + ~ We also need to worry about ZF, but fortunately that "not" will make + ~ sure it's clear. + ~ + ~ So, we're ready; do it! + repnz-scas8 + ~ The scas8 completes, incrementing rdi, before the repnz checks its + ~ condition. So, rdi is now pointing immediately after the terminating + ~ null byte. Of course, we want this in rsi for Forth's purposes. + :rdi :rsi mov-reg64-reg64 + + ~ Finally, we need to align rsi to the next word boundary. + 7 :rsi add-reg64-imm8 + 7 invert :rsi and-reg64-imm8 + + here ! ] ;asm + + +~ Memory access routines +~ ~~~~~~~~~~~~~~~~~~~~~~ +~ +~ We go with Forth names for this stuff. The HP's names for memory and +~ storage operations heavily leverage the fact they have an object system +~ with type tags and so on; we want to stay close to the bytes. + +~ (value, address --) +: ! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rax :rbx mov-indirect-reg64-reg64 + here ! ] ;asm + +~ (address -- value) +: @ + [ here @ + :rax pop-reg64 + :rax :rax mov-reg64-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +~ This follows the general convention that words that set things take the +~ destination as the final parameter. +~ +~ (value, address --) +: +! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rax :rbx add-indirect-reg64-reg64 + here ! ] ;asm + +~ (value, address --) +: -! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rax :rbx sub-indirect-reg64-reg64 + here ! ] ;asm + +~ Jonesforth calls this "c!" but we categorically reject the use of letters +~ that are meant to indicate byte sizes. It's unfriendly to newcomers. There's +~ some risk that this name will be confused for meaning "store a value of 8", +~ but that would not be a useful task, so hopefully it'll be okay. +: 8! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :al :rbx mov-indirect-reg64-reg8 + here ! ] ;asm + +: 8@ + [ here @ + :rbx pop-reg64 + :rax :rax xor-reg64-reg64 + :rbx :al mov-reg8-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +: 16! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :ax :rbx mov-indirect-reg64-reg16 + here ! ] ;asm + +: 16@ + [ here @ + :rbx pop-reg64 + :rax :rax xor-reg64-reg64 + :rbx :ax mov-reg16-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +: 32! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :eax :rbx mov-indirect-reg64-reg32 + here ! ] ;asm + +: 32@ + [ here @ + :rbx pop-reg64 + :rax :rax xor-reg64-reg64 + :rbx :eax mov-reg32-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +~ Before we get too deep into it, we also define a few reflection routines +~ that retrieve, or set, the address of either of the two stacks. +~ +~ The result, or the new value, is on the top of the data stack. That's the +~ same as how it works for any other word, but given the metacircular nature +~ of these ones it's easy to get confused about that... +~ +~ Jonesforth calls this RSP!, which looks as if it's meant to be an Intel +~ register name but is actually short for return stack pointer. There is no +~ register by that name, it's a Forth-provided abstraction. That's super +~ confusing, plus as discussed above we call it the control stack not the +~ return stack, so we call the words... +~ +~ (stack pointer --) +: control! + [ here @ + :rbp pop-reg64 + here ! ] ;asm + +~ (-- stack pointer) +: control@ + [ here @ + :rbp push-reg64 + here ! ] ;asm + +~ Jonesforth calls this DSP!, for data stack pointer. Again, there's no +~ Intel register by that name, and we call it the value stack, so... +~ +~ (stack pointer --) +: value! + [ here @ + ~ Per Intel's description of POP this reads from the old location, and + ~ there is no increment applied to the resulting value. See, the + ~ description says it increments the register then overwrites it, in that + ~ order. + :rsp pop-reg64 + here ! ] ;asm + +~ (-- stack pointer) +: value@ + [ here @ + ~ Per Intel's description of PUSH this pushes the old value. + :rsp push-reg64 + here ! ] ;asm + +~ Copy one non-overlapping block of memory over another. For the overlapping +~ logic, see roll and unroll. This always copies at byte granularity, for ease +~ of implementation. +~ +~ Jonesforth calls this CMOVE and has a CCOPY which is a single byte. POSIX, +~ however, has memcpy() for non-overlapping blocks and memmove() for +~ overlapping blocks. We follow the latter convention, because it feels like +~ the more important distinction. +~ +~ Also, the "c" was meant to indicate that it works at one-byte granularity, +~ but that isn't, uh... actually an important property here, and as a blanket +~ call we're not using letters to denote data sizes. So we call it "memcopy". +~ Apologies to the C programming tradition but vowels are good, actually. +~ +~ Jonesforth also offers C@C! as another name for its CCOPY, but neither +~ "@!" nor "mem@mem!" seems particularly nice. +~ +~ (source, destination, length --) +: memcopy + [ here @ + ~ We need to save and restore rsi; the other registers we can trample. + :rsi :rdx mov-reg64-reg64 + :rcx pop-reg64 + :rdi pop-reg64 + :rsi pop-reg64 + ~ We start from the low end, since that's easier arithmetic. So, we get + ~ to leave the DF flag alone. + rep-movs8 + :rdx :rsi mov-reg64-reg64 + here ! ] ;asm + +~ This does the same thing as memcopy, but correctly handles situations +~ where the destination overlaps with the source. It achieves this by being +~ careful about which end the transfer starts from. This "move" vs. "copy" +~ distinction mirrors C terminology. +~ +~ (source, destination, length --) +: memmove + [ here @ + ~ We need to save and restore rsi; the other registers we can trample. + :rsi :rdx mov-reg64-reg64 + :rcx pop-reg64 + :rdi pop-reg64 + :rsi pop-reg64 + + ~ We need to check source < destination to decide which end to start from. + :rsi :rax mov-reg64-reg64 + :rdi :rax cmp-reg64-reg64 + ~ Relative offsets are from the start of the instruction after the jmp. + 4 :cc-below jmp-cc-rel-imm8 + + ~ If source is greater, we are sliding downwards so we start from the low + ~ end. So, we get to leave the DF flag alone. + rep-movs8 ~ 2 bytes + 16 jmp-rel-imm8 ~ 2 bytes + + ~ If destination is greater, we are sliding upwards so we start from the + ~ high end. So, we have to save and restore DF. Also, we have to adjust the + ~ pointers. + :rcx :rsi add-reg64-reg64 ~ 3 bytes + :rsi dec-reg64 ~ 3 bytes + :rcx :rdi add-reg64-reg64 ~ 3 bytes + :rdi dec-reg64 ~ 3 bytes + std ~ 1 byte + rep-movs8 ~ 2 bytes + cld ~ 1 byte + + :rdx :rsi mov-reg64-reg64 + here ! ] ;asm + + +~ (string pointer -- string length not including null byte) +: stringlen + [ here @ + :rdi pop-reg64 + :rdi :rbx mov-reg64-reg64 + :rax :rax xor-reg64-reg64 + :rcx :rcx xor-reg64-reg64 + :rcx not-reg64 + repnz-scas8 + :rbx :rdi sub-reg64-reg64 + 1 :rdi sub-reg64-imm8 + :rdi push-reg64 + here ! ] ;asm + +~ This word is for working with strings that are null-terminated at both +~ ends. It counts backwards from the end to find the string length. It accepts +~ an input pointer to the final non-null byte at the end of the string, and +~ returns the length not including either null byte. +~ +~ (string end pointer -- string length not including null) +: reverse-stringlen + [ here @ + :rdi pop-reg64 + + :rdi :rbx mov-reg64-reg64 + :rax :rax xor-reg64-reg64 + :rcx :rcx xor-reg64-reg64 + :rcx not-reg64 + + std + repnz-scas8 + cld + + :rdi :rbx sub-reg64-reg64 + 1 :rbx sub-reg64-imm8 + + :rbx push-reg64 + here ! ] ;asm + + +~ If you have a variable-length string followed by alignment padding, and +~ you want to traverse it in reverse, you also need to skip the alignment +~ padding... +~ +~ The alignment padding can have a total length of no more than 8 bytes. The +~ returned value counts from the end, backwards, to the nearest non-null byte, +~ or at most a distance of eight. +~ +~ (address of final null byte in padding -- count of null bytes in padding) +: reverse-padding-len + [ here @ + :rdi pop-reg64 + + :rdi :rbx mov-reg64-reg64 + :rax :rax xor-reg64-reg64 + 9 :rcx mov-reg64-imm32 + + std + repz-scas8 + cld + + :rdi :rbx sub-reg64-reg64 + 1 :rbx sub-reg64-imm8 + + :rbx push-reg64 + here ! ] ;asm + + +~ We make this work using exactly two jump instructions, which is likely the +~ minimum possible. To avoid relying on labels, we hand-compute the byte +~ offsets, so every instruction within their ranges is annotated with its +~ length in bytes. Good fun. +~ +~ The returned comparsion value is 0 for equal, 1 to indicate the left +~ string (lower on the stack) is greater, and -1 to indicate the right string +~ (top of the stack) is greater. +~ +~ (left string pointer, right string pointer -- comparison value) +: stringcmp + [ here @ + ~ Save the rsi register. + ~ + ~ Happily, we don't need a lot of registers for this code, so we can + ~ dedicate rdx to this and not have to deal with stack juggling.. + :rsi :rdx mov-reg64-reg64 + + ~ Get the parameters off the stack. + ~ + ~ For reasons that will be explained below, the left and right strings + ~ from our caller's perspective are swapped from the perspective of the + ~ comparisons we'll be doing. The rdi register points to the right-hand + ~ operand of the "cmps" instruction, while rsi points to the left-hand + ~ operand; [Intel] volume 2A, chapter 3, section 4-3.3, "CMPS"; note that + ~ the PDF mis-numbers the sections in the second half of chapter 3. + :rsi pop-reg64 + :rdi pop-reg64 + + ~ For the comparison-unequal loop-exit code, we'll need rbx set to zero. + ~ The easy way to do that is by xor'ing it with itself, but doing it at + ~ the end of the loop would overwrite the comparison flags, which we need. + ~ So we do it in advance, and carefully don't touch it anywhere else. + ~ + ~ See the list of which instructions affect the flags in [Intel] + ~ volume 1, appendix A, section A-1, table A-2. + :rbx :rbx xor-reg64-reg64 + + ~ We also clear rax; we'll be using al later, and it will be convenient + ~ to know the upper bits are always zero. + :rax :rax xor-reg64-reg64 + + ~ Now we've initialized everything we need; everything after this point is + ~ part of the loop. + + ~ At the start of each iteration, save a copy of the byte we're at now. + ~ We need to do this before cmps because the pointers will increment; + ~ we'll eventually use it to test whether we've reached the end delimiter. + ~ + ~ We do a 64-bit load into rcx, which is otherwise unused, then copy the + ~ low byte from cl to al. This avoids having to think about addressing + ~ modes that combine 64-bit addresses with smaller data sizes; those are + ~ very subtle. + :rsi :rcx mov-reg64-indirect-reg64 ~ 3 bytes + :cl :al mov-reg8-reg8 ~ 2 bytes + + ~ Now do the cmps, which is the heart of the loop. + ~ + ~ Note that, in addition to relying on this comparison to test content + ~ bytes against each other, in the event that one string is a prefix of + ~ the other, this will also test content bytes against null delimiters. + ~ The longer string will compare as "greater", because zero is less than + ~ all other possible byte values. This is what we want. + ~ + ~ Since strings of different lengths are necessarily unequal, letting + ~ this test do the work of detecting that also means we don't have to deal + ~ with scenarios where we're past the end of one string but not the other. + cmps8 ~ 1 byte + + ~ The flags are now set based on the simulated subtraction of the next + ~ bytes from the two strings. If they were unequal, the loop will end. If + ~ they were equal, we have another test to do before we're finished with + ~ this iteration. So we put the loop-end code next, and conditionally jump + ~ forward past it. + ~ + ~ Recall that relative offsets are from the start of the instruction after + ~ the jmp. + 15 :cc-equal jmp-cc-rel-imm8 ~ 2 bytes + + ~ If we got here, the strings are unequal, so we need to turn the flags + ~ into a comparison value. We cleared rbx earlier; now we set its low bit + ~ to the "above" flag, then use sbb to subtract the "carry" flag (which it + ~ thinks of as the "borrow" flag). + ~ + ~ Recall that "carry" is based on whether the comparison would cause a + ~ change to the next bit "outside" the bits being compared; [Intel] + ~ volume 1, chapter 3, section 3-4.3.1. Since the comparison is a + ~ subtraction, "carry" is true when the right-hand byte is strictly + ~ greater than the left-hand byte. + ~ + ~ Also recall that "zero", also called "equal", is based on whether the + ~ comparison's result produces output that's all zero bits. Since the + ~ comparison is a subtraction, "zero" is true when the two bytes are + ~ identical. + ~ + ~ The "above" condition is not a flag, but a composite of flags. It's + ~ true when both "carry" and "zero" are false; [Intel] volume 1, chapter + ~ 7, section 7-3.1.1, table 7-2. For us, this is equivalent to saying the + ~ left-hand byte is strictly greater than the right-hand. + ~ + ~ So, after the "set" instruction, rbx is 1 if left > right, and 0 if + ~ left = right or left < right. The "sbb" instruction with an immediate + ~ value of zero subtracts the value of the carry flag from rbx; the flag + ~ is true in the case where left < right, and false otherwise. So, after + ~ the "sbb", rbx is 1 if left > right, 0 if left = right, and -1 if + ~ left < right. + ~ + ~ This sounds like the opposite of what we want, but recall that we + ~ exchanged the operands, so these are the values our caller is expecting. + ~ While it might be tempting to look for a way to not need that + ~ transposition, and indeed there exists an approach using "not above", + ~ it's fiddly in a way that's even harder to explain. + ~ + ~ Note that it's important that the "jmp" and "set" instructions don't + ~ change the flags (see table A-2 again), so the "cmps" is the most recent + ~ thing that did. The "sbb" instruction does change them, but we don't + ~ need them again after that point so it doesn't matter. + ~ + ~ Finally, we need to restore rsi before we return to Forth. + ~ + ~ The two-instruction set-sbb sequence is one of those classic assembly + ~ programming tricks that often goes unexplained, because most of its + ~ appeal is its brevity and a proper explanation is quite lengthy. Please + ~ enjoy this gift of knowledge, and thanks to our friends who showed it to + ~ us. + :cc-above :bl set-reg8-cc ~ 3 bytes + 0 :rbx sbb-reg64-imm8 ~ 4 bytes + :rbx push-reg64 ~ 1 byte + :rdx :rsi mov-reg64-reg64 ~ 3 bytes + pack-next ~ 4 bytes + + ~ If we got here, the current bytes are equal to each other. We still + ~ need to test if they're null terminators; if so, we exit, and if not, we + ~ loop. + ~ + ~ At the beginning of this iteration, we saved a copy of the byte being + ~ inspected in rax. The "test" instruction simulates a xor and sets the + ~ flags accordingly. We check the "not equal" condition, also known as + ~ "not zero", and jump backwards to the start of the loop when that's the + ~ case. + ~ + ~ Recall that relative offsets are from the start of the instruction + ~ after the jmp. + :rax :rax test-reg64-reg64 ~ 3 bytes + -28 :cc-not-equal jmp-cc-rel-imm8 ~ 2 bytes + + ~ If we got here, we got all the way to the end of both strings and + ~ found a null byte, so we return 0 to indicate they're equal. + ~ + ~ We can use push-imm32-extended64 even though our stack holds 64-bit + ~ values, because it gets sign-extended. + ~ + ~ We need to restore rsi before we return to Forth. + 0 push-imm32-extended64 + :rdx :rsi mov-reg64-reg64 + here ! ] ;asm + + +~ Branching +~ ~~~~~~~~~ + +~ Okay, so there's a weird thing about how branch and 0branch are defined. +~ 0branch jumps into branch, so they need to be next to each other in the log. +~ To compute the offset to jump by, we pass an address on the stack. Notice +~ that assembly words are always defined in immediate mode; it's just they +~ usually only do trivial logic. + +~ This takes a number of bytes, not machine words. That allows it to be used +~ for putting weird things embedded in the code. +~ +~ The offset is relative to the start of the word the number of bytes is in, +~ so, make sure to have it skip itself. +: branch + [ here @ + dup swap ~ Save a copy of this address for later. + :rsi :rsi add-reg64-indirect-reg64 + here ! ] ;asm +~ (jump destination) + +: 0branch + [ here @ + ~ (jump destination, output point) + + :rax pop-reg64 + :rax :rax test-reg64-reg64 + + ~ Please notice the 8-bit branch to the nearby word. This is the offset + ~ from the end of the jmp instruction, to the start of the target + ~ instruction. To avoid needing the label system for this, we compute it + ~ based on the address before the jmp; the jmp itself is two bytes. + ~ + ~ Remember, with jump arithmetic, subtract the start from the + ~ destination. + ~ + ~ What we're testing with :cc-equal is that the input value is zero. + ~ The name is slightly counterintuitive; it's a result of the condition + ~ names favoring cmp over test. While cmp simulates subtraction, test + ~ simulates bitwise AND. + dup 2 + 3roll swap - :cc-equal jmp-cc-rel-imm8 + ~ (output point) + + ~ In the event we didn't jump, we still need to skip over the literal + ~ value. Using lods here is just a convenient way to skip rsi forward. + lods64 + + here ! ] ;asm +~ the stack is empty once more + + +~ This is like next, but instead of using rsi as the "instruction pointer", +~ it takes a codeword address from the value stack. +~ +~ In the event that the codeword is docol, docol will handle any +~ manipulation of the control stack that needs to happen. Yes, it really is +~ that simple. +~ +~ (execution token --) +: execute + [ here @ + :rax pop-reg64 + :rax jmp-abs-indirect-reg64 + here ! ] ;asm + + +~ Dictionary entries +~ ~~~~~~~~~~~~~~~~~~ +~ +~ Now, we have a bunch of words that are used for traversing the Forth +~ core data structures that describe words. First, we have a couple that +~ relate to individual words and their pieces... +~ +~ The log-load transform produces code that requires +~ entry-to-execution-token, which means it's needed statically. So this stuff +~ to deal with word entry headers might as well go in core, since it has no +~ dependencies to speak of. +~ +~ These are the first words in core that are implemented in Forth rather +~ than assembler. That's not as big a deal as it may seem; the Forth execution +~ model has been ready-to-go ever since we implemented docol and exit, and +~ at this point we have enough basics to do useful things with it. + +~ Jonesforth calls this "TFCA" and ">CFA"; its author speculates that the +~ original meaning is "code field address". +~ +~ (entry pointer -- execution token) +: entry-to-execution-token + ~ Skip next-entry pointer, flag byte, and start terminator. + 10 + + ~ Skip string contents. + dup stringlen + + ~ Skip one for the null terminator, seven more for alignment. + 8 + + ~ Zero the low bits and now it's aligned. + 7 invert & ; + +~ Jonesforth calls this "CFA>". Jonesforth's implementation searches the +~ entire dictionary, since its word header format isn't designed to be +~ traversed in reverse, but ours is, so it should be fast. +~ +~ (execution token -- entry pointer) +: execution-token-to-entry + 1 - + dup reverse-padding-len - + dup reverse-stringlen - + 9 - ; + +~ (entry pointer -- flags byte) +: entry-flags@ + 8 + @ 0xFF & ; + +~ (new flags byte, entry pointer --) +: entry-flags! + 8 + + dup @ 3roll + 0xFF & + swap 0xFFFFFFFFFFFFFF00 & | + swap ! + ; + +~ (entry pointer -- name string pointer) +: entry-to-name 10 + ; + + +~ Binary packing +~ ~~~~~~~~~~~~~~ +~ +~ These routines are for building up data structures in-memory. Sometimes +~ they're used for structures that are meant to stay in memory; other times +~ it's a buffer that will become output. +~ +~ The general pattern is that each routine takes an output address and +~ some specific datum, and returns the output address adjusted to point +~ after the new datum. That makes them easy to chain together. We call this +~ address the "output point", to capture the idea that it's a running total +~ which gets updated by each new datum as it's packed. + +~ (output point, value -- output point) +: pack64 swap dup 3unroll ! 8 + ; +: pack32 swap dup 3unroll 32! 4 + ; +: pack16 swap dup 3unroll 16! 2 + ; +: pack8 swap dup 3unroll 8! 1 + ; + +~ This works on C-style strings, which are characters followed by a null +~ terminator. The packed data includes the null terminator. +~ +~ (output point, string pointer -- output point) +: packstring + dup stringlen 1 + dup + ~ (output point, source, length, length) + 4 roll dup 4 unroll + + ~ (source, destination, length, length, output point) + + 4 unroll + ~ (output point, source, destination, length) + memcopy ; + +~ This also works on C-style strings, relying on the null terminator, but +~ the packed data does not include it. +~ +~ (output point, string pointer -- output point) +: pack-raw-string + dup stringlen dup + ~ (output point, source, length, length) + 4 roll dup 4 unroll + + ~ (source, destination, length, length, output point) + + 4 unroll + ~ (output point, source, destination, length) + memcopy ; + +~ (output point, alignment byte width -- output point) +: packalign + ~ It's possible the padding will be of length zero; keep that in mind + ~ while maintaining these magic comments, as it comes up in several ways. + ~ : fresh-line + ~ : 0 #-- (alignment padding) + { 2dup /% drop { drop exit } unless + swap 0 pack8 swap + ~ : 1 adjust-length + } forever ; + + +~ Binary unpacking +~ ~~~~~~~~~~~~~~~~ +~ +~ These routines are for examining data structures in-memory. +~ +~ Similarly to the output routines, each routine takes an input address, +~ which it updates to point after the data item being read. We call this the +~ "input point". Since this is input, the routines return data items rather +~ than accepting them. + +~ (input point -- input point, value) +: unpack64 dup @ swap 8 + swap ; +: unpack32 dup 32@ swap 4 + swap ; +: unpack16 dup 16@ swap 2 + swap ; +: unpack8 dup 8@ swap 1 + swap ; + +~ (proposed size, alignment byte width -- adjusted size) +: align-size + dup 3unroll dup 3unroll + ~ (alignment, alignment, proposed size, alignment) + 1 - + swap /% swap drop * ; + +~ You might think this would be identical to packalign, but packalign has +~ side effects. +~ +~ (input point, alignment byte width -- input point) +: unpackalign align-size ; + + +~ The first hint of a debugging tool +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +~ This peforms the "hlt" instruction (Intel's mnemomic, short for "halt"), +~ which will cause the program to exit with a segmentation fault. If you're +~ running under a debugger, this is a convenient way to get execution to stop +~ at a certain point. +~ +~ It's called "crash" rather than "hlt" to distinguish it from the word +~ which outputs the instruction as machine code. +~ +~ This is the main diagnostic tool available under the label transform. Yep. +~ That's all we get. Don't make those eyes. +: crash + [ here @ + hlt + here ! ] ;asm + + +~ Additional conveniences +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Please feel free to find an organizing principle for these and put them +~ where they go. It would be kind of nice to re-write these either in +~ assembly, or with high-level flow control, but it doesn't seem urgent... + +: max + 2dup >= { swap } if + drop ; + +: min + 2dup <= { swap } if + drop ; + +: over swap dup 3unroll ; + +~ 0 pick is equivalent to dup. 1 pick is equivlent to over. +: pick 2 + dup roll dup 3roll unroll ; + +~ Standard Forth doesn't have equivalents of our ndrop and ndup. The HP +~ calls them DROPN and DUPN but that doesn't go well with ie. 2dup or 3roll, +~ so we do it like this. +: ndrop { dup } { swap drop 1- } while drop ; + +: ndup + dup 1+ swap + { dup } { swap dup pick 3unroll swap 1- } while + 2drop ; + +: 3drop drop drop drop ; +: 3dup 2 pick 2 pick 2 pick ; + +: && 0 != swap 0 != * ; +: || | 0 != ; +: not 0 = ; +: negate -1 * ; + +: align-floor dup 3unroll /% swap drop * ; + + +~ Find-in is the main word that provides the capability to look up words by +~ name, though it's usually used via "find" rather than being called directly. +~ +~ Find-in traverses the linked list formed by a particular dictionary's +~ next-entry pointers, looking for an entry that matches a given name. The +~ dictionary pointer is the pointer (not handle) to the root of the list, +~ which runs from newest to oldest. For example, dereferencing the value of +~ "latest" gives the pointer to the main dictionary, which can be passed to +~ find-in. +~ +~ Having find-in separated out is convenient when working with alternate +~ dictionaries, but the main reason for having it is not convenience but +~ necessity: During Evocation's startup, there is a period before global +~ variables are easily accessible, so there would be no way to implement +~ "find". The warm-start routine (see compilation/execution.e and +~ compilation/transform.e) has the job of fixing that, and it makes extensive +~ use of find-in to do so. +~ +~ The definition of "find" is in language/dynamic/dynamic.e, with the other +~ stuff that needs to access the log. +~ +~ (dictionary pointer, string pointer -- entry pointer or 0) +: find-in + ~ It will be more convenient to have the entry pointer on top. + swap + + { + ~ If the entry pointer is null, exit. + ~ (name pointer to find, current entry pointer) + dup 0 = { swap drop exit } if + + ~ Check this entry's "hidden" flag. + ~ (name pointer to find, current entry pointer) + dup entry-flags@ 0x80 & 0x80 != { + ~ Test whether this entry is a match. + ~ (name pointer to find, current entry pointer) + 2dup 10 + stringcmp 0 = { + ~ If we're here, it's a match. Clean up our working state and exit. + ~ (name pointer to find, current entry pointer) + swap drop exit + } if + } if + + ~ If we're here, it's not a match; traverse the pointer and repeat. + ~ (name pointer to find, current entry pointer) + @ + } forever ; + diff --git a/language/static/execution-support.e b/language/static/execution-support.e new file mode 100644 index 0000000..1592643 --- /dev/null +++ b/language/static/execution-support.e @@ -0,0 +1,111 @@ +~ Execution support +~ ~~~~~~~~~~~~~~~~~ +~ +~ These macros are an important part of the execution model described in +~ compilation/execution.e. They're here, in this file, because they need to be +~ statically available via the label transform, so that the log-load transform +~ can rely on them. + + +~ Macro next +~ ~~~~~~~~~~ +~ +~ Include this inline at the end of a word implemented in machine-code. +~ Conceptually, it returns. What it actually does is do the next thing the +~ caller would do, which is call the next word from the caller's array of +~ word pointers. +~ +~ This is a widespread technique in Forth implementation, referred to as +~ indirect threaded code. It's "threaded" in the sense that each word takes +~ responsibility for finishing up by following the notional thread through the +~ metaphorical labyrinth to figure out the next word that its caller wants to +~ run after it. In other words, control never directly returns to the parent, +~ it proceeds directly to the sibling. +~ +~ Registers in: +~ +~ * rsi points to the address of the word to execute +~ +~ Registers out: +~ +~ * rax points to the codeword in the contents of the word that was executed +~ * rsi points to the next word-address after this one +~ +~ Flags +~ * DF = 0 is required +~ +~ (output point -- output point) +: pack-next + ~ : "next" macro + ~ Copy the next word's address from *rsi into rax. Increment rsi (as per + ~ the DF flag). + lods64 + + ~ Load the codeword from the word's contents, and jump to the interpreter + ~ it points to. + :rax jmp-abs-indirect-reg64 ; + + +~ Macro beforenext +~ ~~~~~~~~~~~~~~~~ +~ +~ Sometimes we want to transfer control from a word implemented in +~ machine-code to another word, without coming back after, as if we were +~ simply jumping to it. This is an innovation of ours; Jonesforth doesn't do +~ it. It is similar to the tail-call optimization that many Lisp dialects +~ have. +~ +~ This implementation will work regardless of how the receiving word is +~ implemented. It impersonates the "next" snippet, setting up rax to point +~ to the codeword then jumping to the interpreter. Since it doesn't change +~ the control stack or rsi, when the receiving word eventually invokes +~ "next"; it will pick up in the same place as if this sending word had done +~ it. +~ +~ Thus, notionally we are doing just this one transfer of control before +~ eventually getting around to inlining "next". Hence the name. +~ +~ (output point, target address -- output point) +: pack-beforenext + ~ : "beforenext" macro + ~ Do a permanent transfer of control by setting rax and invoking the + ~ codeword. Of course, we could jump to docol ourselves but this will work + ~ regardless of what the receiving codeword is. + :rax mov-reg64-imm64 + :rax jmp-abs-indirect-reg64 ; + + +~ Macros pushcontrol +~ popcontrol +~ ~~~~~~~~~~~~~~~~~~ +~ +~ Include these inline to push an address onto the control stack, or pop +~ one off of it. You will recall the control stack is kept in rbp. The +~ parameter is given in a user-specified register. +~ +~ Jonesforth's analogous macros are called PUSHRSP and POPRSP but I think +~ that's super confusing, since rsp is also the name of a register, but a +~ different one. I guess it was less confusing in 32-bit, since esp doesn't +~ start with an "r". Anyway, this has to be named something that +~ distinguishes it from Intel's PUSH and POP opcodes, so... +~ +~ "Load effective address" is just a cute way to do arithmetic on a +~ register, here. To push or pop we decrement or increment rbp by 8. To +~ actually interact with the space in the stack, we indirect through rbp. +~ +~ Registers in and out: +~ +~ * rbp points to the top of the control stack. +~ +~ (output point, source register -- output point) +: pack-pushcontrol + ~ : "pushcontrol" macro + swap :rbp -8 :rbp lea-reg64-disp8-reg64 + swap :rbp 0 mov-disp8-reg64-reg64 ; + +~ (output point, target register -- output point) +: pack-popcontrol + ~ : "popcontrol" macro + :rbp 0 3roll mov-reg64-disp8-reg64 + :rbp 8 :rbp lea-reg64-disp8-reg64 ; + diff --git a/language/static/linux.e b/language/static/linux.e new file mode 100644 index 0000000..fd15ae0 --- /dev/null +++ b/language/static/linux.e @@ -0,0 +1,153 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ System calls for the Linux kernel ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The kernel preserves every register except rax, rcx, and r11. The system +~ call number goes in rax, as does the return value. Parameters go in rdi, +~ rsi, rdx, r10, r8, and r9, in that order. [SysV] A.2.1. +~ +~ Notice that rsi is our control stack, so we have to save it (for +~ syscalls with at least two parameters). We can use the value stack to do +~ that, since rsp is preserved, or we can use one of the other registers. We +~ don't ourselves save other registers because our caller should do that, if +~ it cares. +~ +~ In the kernel source, you may find the following files useful to +~ reference: +~ +~ * arch/x86/entry/syscalls/syscall_64.tbl +~ * include/linux/syscalls.h +~ * include/linux/compat.h +~ +~ Don't be confused by tools/scripts/syscall.tbl, it's not for x86. +~ +~ This file loads early, before anything in language/dynamic/. So, although +~ it superficially appears to be able to do allocation and high-level flow +~ control, those come from the transforms, which means they're shallow +~ implementations. The stuff here can't be moved later, because +~ language/dynamic/input.e relies on it, and the other dynamic stuff relies on +~ that. So, there's additional Linux functionality in another file that loads +~ later, language/dynamic/linux.e. + + +~ (call number -- return value) +: syscall-0 + [ here @ + :rax pop-reg64 ~ syscall number + syscall + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, call number -- return value) +: syscall-1 + [ here @ + :rax pop-reg64 ~ syscall number + :rdi pop-reg64 ~ first param + syscall + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, second param, call number -- return value) +: syscall-2 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, second param, third param, call number -- return value) +: syscall-3 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, second param, third param, fourth param, call number +~ -- return value) +: syscall-4 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :r10 pop-extrareg64 ~ fourth param + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + + +~ (first param, second param, third param, fourth param, fifth param, +~ call number -- return value) +: syscall-5 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :r8 pop-extrareg64 ~ fifth param + :r10 pop-extrareg64 ~ fourth param + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + + +~ (first param, second param, third param, fourth param, fifth param, +~ sixth param, call number -- return value) +: syscall-6 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :r9 pop-extrareg64 ~ sixth param + :r8 pop-extrareg64 ~ fifth param + :r10 pop-extrareg64 ~ fourth param + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + + +~ Raw system calls +~ ~~~~~~~~~~~~~~~~ + +~ This does the Linux exit() system call, passing it an exit code taken +~ from the stack. It does not return. +~ +~ (exit code -- *) +: sys-exit 60 syscall-1 + ~ In the event we're still here, let's minimize confusion. + crash ; + +~ This does the Linux write() system call, passing it an address from the +~ top of the stack and a length from the second position on the stack. It +~ uses a Unix file descriptor, which is a non-negative integer, to tell it +~ where to write to. For stdout, use fd 1. +~ +~ (file descriptor, base address, length to write -- result code or length) +: sys-write 1 syscall-3 ; + +~ (file descriptor, base address, length to read -- result code or length) +: sys-read 0 syscall-3 ; + +~ (filename, flags, mode -- result code or file descriptor) +: sys-open 2 syscall-3 ; + +~ (file descriptor -- result code) +: sys-close 3 syscall-1 ; + diff --git a/language/static/log-load.e b/language/static/log-load.e new file mode 100644 index 0000000..54a9d42 --- /dev/null +++ b/language/static/log-load.e @@ -0,0 +1,547 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Bootstrapping the log ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The log is the main region of memory within which most dynamic allocation +~ happens. It's a single contiguous segment of virtual memory, which is +~ requested from the kernel when Evocation starts up. Almost all of +~ Evocation's dynamic data is kept in the log, including the main dictionary; +~ several important global variables which make it possible to find and +~ allocate other data structures; and the control stack. +~ +~ This file has the task of providing words which are useful for working +~ with the log, and more specifically which are useful for helping to bring +~ the log into existence. Once the log exists, it can be used to manage +~ itself, but there's a bootstrapping challenge in getting there. That +~ challenge is solved by the warm-start routine in compilation/execution.e, +~ which relies on the words in this file and should load after it. +~ +~ Some modern Forths, including Jonesforth, refer to the log as the heap. +~ This is a misnomer; a heap is a data structure that allows non-contiguous +~ allocation. Although there are Forths that have true heaps, Evocation is not +~ one of them. Space in the log is allocated by incrementing the "here" +~ variable (one of those important globals), which necessarily can only +~ allocate contiguous blocks; there is no way to compact allocations to +~ reclaim fragmented, unused space in between them. Evocation does allow +~ deallocation using "forget", but this is done by resetting "here" and +~ "latest" to older values, unwinding every allocation that's been done since +~ the point in time they return to. +~ +~ It would be a mistake to confuse this allocation strategy with the +~ more-general facilities for allocation, reallocation, and deallocation of +~ individual memory blocks that many other languages have. To avoid confusion, +~ we stay away from the name "heap", though it may still occasionally be used +~ colloquially because it's familiar from other Forths, and because most +~ programming languages have a heap as the main memory segment they request +~ from the kernel. +~ +~ In the strictest technical sense, the log is a stack: Things are added +~ to the end of it, and removed from that same end. However, Evocation already +~ has two other stacks, the control and value stacks. Adding to the potential +~ confusion, the control stack is actually stored inside the log (as a +~ fixed-size chunk at the bottom). However, the log isn't really that much +~ like a stack when you look at how it's actually used. Unlike Evocation's +~ control and value stacks, data structures on the log tend to be rich and +~ complex, interlinked in various ways through the use of pointers. They also +~ tend to be long-lived, with the log tending to grow over time, whereas the +~ control and value stacks tend to remain roughly the same size through cycles +~ of growth and shrinking. In order to be able to speak precisely about what +~ we're doing, we introduce the name "log" to refer to the entire memory +~ segment and everything stored within it. +~ +~ Another linguistic choice we make is to be clear about dictionaries. A +~ dictionary is a linked list of word entries. Each dictionary has a specific +~ handle, a pointer to a pointer, which is the root of the list. Each +~ word entry begins with a specific data structure, which among other things +~ includes a next-entry pointer, a flags byte, and a string that serves as +~ the entry's name. Older entries in a dictionary seldom change; newer entries +~ are added at the beginning of it, with their next-entry pointers leading to +~ the older entries. It is possible for several dictionaries to exist at once, +~ each with its own dictionary handle. +~ +~ Since dictionaries are managed using pointers to individual entries, there +~ is no specific requirement about the order in which those entries occur in +~ memory or where they are allocated, but usually a new entry is allocated at +~ the end of the log, by incrementing the variable "here", in the same manner +~ as any other allocation. There is one particular dictionary, the main +~ dictionary, whose handle is the variable "latest". The main dictionary holds +~ every executable word that can be used normally via Evocation's interpreter. +~ +~ Since the main dictionary is by far the most important thing in the log, +~ it can be tempting to conflate the log with the main dictionary. This is +~ accurate enough for some purposes, but note that other dictionaries are +~ often interleaved with it, their allocations entwining like grape vines even +~ while each remains separate, reachable only via its own root. See the +~ machine label facility, in compilation/labels.e, for an example of how a +~ secondary dictionary can be useful. +~ +~ This may feel tangential, but it's important background and there's no +~ better place to explain it: A handle is a pointer to a pointer. The variable +~ "latest" returns a handle, a fixed address which always holds the pointer to +~ the root entry of the main dictionary. Dereferencing that handle gives you +~ the dictionary pointer, the address of the root entry, which is suitable to +~ pass to find-in and similar words that read the dictionary's contents. When +~ you want to add a new entry to a dictionary, you need the dictionary's +~ handle, so that the root pointer can be changed. When you only want to write +~ it, you only need the regular single pointer. +~ +~ When reading the documentation of words that work with dictionaries, pay +~ close attention to whether their parameters include a dictionary handle, or +~ a dictionary pointer. +~ +~ The term "handle" was widely known in the early days of microcomputing, +~ when memory-safe languages without direct pointer access were less common. +~ Today it is usually considered specific to systems programming, the type of +~ programming which lies beneath other software and deals with topics such as +~ memory management and processes. Evocation is a systems-programming +~ language, in the sense that it takes pains to not introduce mandatory +~ abstractions which would make it difficult or inefficient to work directly +~ with these topics. So, in understanding Evocation, it's important to know +~ about handles. +~ +~ Some of these bootstrap words rely on being able to invoke assembler words +~ that output machine code. Therefore, those words must be available at +~ runtime. Since nothing can be dynamically available at runtime until after +~ we've already run the log-load routine, which relies on the stuff in this +~ file, the assembler words must be statically available via the label +~ transform. That means their definitions in arm64.e must be loaded before +~ this file. + + +~ This has the same value as the constant control-stack-size, which is +~ defined in compilation/execution.e. Everything will break if it doesn't. +~ +~ TODO: remove one of them. Probably the other one. +: log-offset 0x10000 ; ~ 64 KiB + +~ (log address -- log address, "log" pointer) +: log-load-log + dup log-offset + ; +~ (log address -- log address, "s0" pointer) +: log-load-s0 + dup log-offset + 8 + ; +~ (log address -- log address, "r0" pointer) +: log-load-r0 + dup log-offset + 2 8 * + ; +~ (log address -- log address, "latest" pointer) +: log-load-latest + dup log-offset + 3 8 * + ; +~ (log address -- log address, "here" pointer) +: log-load-here + dup log-offset + 4 8 * + ; + + +~ This is a helper used by warm-start, which invokes find-in using "latest". +~ It relies on being passed the root address of the log, which is used to find +~ the global variable "latest". It's inconvenient to keep a log pointer around +~ all the time, which is why we stop doing it as soon as possible, but during +~ Evocation's startup there's no alternative. This word is used extensively +~ by code that's been compiled via the log-load transform; see +~ compilation/transform.e for details. +~ +~ It would be possible to unload this word after the log is created, but +~ there are rare situations in which it's still useful, such as injecting +~ Evocation into another process's address space. Plus, it's small. So, we +~ keep it around. +~ +~ (log address, string pointer -- log address, entry pointer or 0) +: log-load-find + swap log-load-latest @ swap 3unroll swap find-in ; + +~ In the code generated by the log-load transform, it's convenient to have +~ only a single step needed to look up a word's execution token. This helper +~ does log-load-find, then gets the execution token if an entry is found. +~ +~ (log address, string pointer -- log address, execution token or 0) +: log-load-find-execution-token + dup 3unroll log-load-find dup + { + 3roll drop + entry-to-execution-token + } { + drop swap + ." No such word: " emitstring newline + 0 + } if-else ; + + +~ This is the same as "create", from language/dynamic/dynamic.e, except that +~ it takes the log's address as a parameter rather than hardcoding it, so that +~ it can be used in situations where the normal compilation process isn't yet +~ available. +~ +~ The requisite stack juggling is kind of finicky, sorry if it's hard to +~ read, but it's doing the same steps in the same order as the regular +~ "create". +~ +~ (log address, string pointer -- log address) +: log-load-create + dup stringlen 1 + dup 3unroll + ~ (log address, name field length, string pointer, name field length) + + 3 pick log-load-here swap drop @ 10 + swap memmove + ~ (log address, name field length) + + over log-load-here swap drop @ + ~ (log address, name field length, output point) + + 2 pick log-load-latest swap drop @ pack64 + ~ (log address, name field length, output point) + 0 pack8 + 0 pack8 + + + ~ (log address, output point) + 8 packalign + ~ (log address, output point) + + over log-load-here swap drop @ + ~ (log address, output point, old here value) + 2 pick log-load-latest swap drop ! + ~ (log address, output point) + over log-load-here swap drop ! ; + + +~ (log address -- log address) +: log-load-self-codeword + log-load-here dup @ + ~ (log address, here, output point) + + dup 8 + pack64 + ~ (log address, here, output point) + + swap ! ; + + + +~ This is the same as ",", from language/dynamic/dynamic.e, except that it +~ takes the log's address as a parameter rather than hardcoding it, so that it +~ can be used in situations where the normal compilation process isn't yet +~ available. +~ +~ Again, the stack juggling is kind of a lot, sorry about that. +~ +~ (log address, value -- log address) +: log-load-comma + swap log-load-here swap 3unroll + ~ (log address, value, here) + @ swap pack64 + ~ (log address, updated here value) + swap log-load-here swap 3unroll + ~ (log address, updated here value, here) + ! ; + + +~ This is the same as `;asm`, from language/dynamic/dynamic.e, except that +~ it takes the log's address as a parameter rather than hardcoding it, so that +~ it can be used in situations where the normal compilation process isn't yet +~ available. +~ +~ Its two main responsibilities are to call `pack-next`, from +~ language/static/execution-support.e, and to overwrite the codeword. It also +~ deals with alignment. +~ (log address) +: log-load-semicolon-assembly + log-load-here @ + ~ (log address, output point) + + pack-next + 8 packalign + ~ (log address, output point) + + swap log-load-here swap 3unroll ! + ~ (log address) + + log-load-latest @ + ~ (log address, entry pointer) + entry-to-execution-token + dup 8 + swap ! ; + + +~ This is the same as "variable", from language/dynamic/dynamic.e, except +~ that it takes the log's address as a parameter rather than hardcoding it, so +~ that it can be used in situations where the normal compilation process isn't +~ yet available. +~ +~ (log address, address for new variable word, string pointer -- log address) +: log-load-variable + 3roll swap log-load-create + ~ (address for new variable word, log address) + + log-load-here swap 3unroll + ~ (log address, address for new variable word, here) + + dup @ + ~ (log address, address for new variable word, here, output point) + dup 8 + pack64 + + 3roll :rax mov-reg64-imm64 + ~ (log address, here, output point) + + :rax push-reg64 + pack-next + 8 packalign + + swap ! ; + + +~ A keyword is a word that evaluates to its own address, which makes it +~ suitable for use as a constant. See more detail on that in +~ language/dynamic/dynamic.e, where "keyword" is defined. +~ +~ Unlike Common Lisp, the lexer doesn't create keywords for us, we have to +~ do it explicitly. If if that were to someday change, the log-load routine +~ would still need a way to do it, which is this. +~ +~ It's kind of a pain to look up the appropriate "docol" from here, so we +~ do it in assembler instead. +~ +~ (log address, string pointer -- log address) +: log-load-keyword + log-load-create + ~ (log address) + + log-load-here @ dup + ~ (log address, self execution token, output point) + + dup 8 + pack64 + ~ (log address, self execution token, output point) + + swap :rax mov-reg64-imm64 + ~ (log address, output point) + + :rax push-reg64 + pack-next + 8 packalign + ~ (log address, output point) + + swap log-load-here + ~ (output point, log address, here) + swap 3unroll + ~ (log address, output point, here) + ! ; + + +~ This is a helper used by log-load-string-alternate. It does the usual +~ string packing thing, but at one layer of indirection more than usual. Its +~ responsibility includes alignment, unlike packstring. +~ +~ (log address, string pointer -- log address) +: log-load-comma-string + swap log-load-here @ 3roll + ~ (log address, output point, string pointer) + + packstring + 8 packalign + ~ (log address, output point) + + swap log-load-here 3roll swap + ~ (log address, output point, here) + ! ; + + +~ Now we have a bunch of words that are the back-ends for the log-load +~ transform's high-level flow control alternates. These implementations +~ closely parallel the non-transformed versions in +~ language/dynamic/flow-control.e, which should be referenced in understanding +~ them. +~ +~ These variants are a bit unusual in their interfaces: They end with the +~ log address at the top of the stack, even when they have values to return. +~ That's because they're really just "talking" to each other; they don't need +~ to interact with anything else, and doing it this way saves the alternates +~ the work of swapping things around after. +~ +~ Notice also that, because these run entirely at log-load time, they are +~ always dealing with target pointers and don't have to convert address +~ spaces. +~ +~ (log address -- start pointer, log address) +: log-load-left-curly-brace + log-load-here @ swap ; + + +~ (start pointer, log address -- start pointer, length, log address) +: log-load-right-curly-brace + swap dup 3roll + ~ (start pointer, start pointer, log address) + log-load-here @ swap + ~ (start pointer, start pointer, end pointer, log address) + 3unroll swap - swap ; + + +~ (start, length, log address -- log address) +: log-load-if + 3unroll + ~ (log address, start, length) + 2dup swap dup + ~ (log address, start, length, length, start, start) + 5 8 * + + ~ (log address, start, length, length, start, adjusted start) + 3roll + ~ (log address, start, length, start, adjusted start, length) + memmove + ~ (log address, start, length) + swap 3roll log-load-here dup @ + ~ (length, start, log address, here pointer, old here) + swap 4 roll swap + ~ (length, log address, old here, start, here pointer) + ! + ~ (length, log address, old here) + 3unroll + ~ (old here, length, log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" !=" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + ~ (old here, length, log address) + swap dup 3unroll + ~ (old here, length, log address, length) + 8 + log-load-comma + ~ (old here, length, log-address) + 3unroll + ~ (log address, old here, length) + drop 5 8 * + + ~ (log address, new here) + swap log-load-here + ~ (new here, log address, here pointer) + 3roll swap ! ; + + +~ (start, length, log address -- log address) +: log-load-unless + 3unroll + ~ (log address, start, length) + 2dup swap dup + ~ (log address, start, length, length, start, start) + 5 8 * + + ~ (log address, start, length, length, start, adjusted start) + 3roll + ~ (log address, start, length, start, adjusted start, length) + memmove + ~ (log address, start, length) + swap 3roll log-load-here dup @ + ~ (length, start, log address, here pointer, old here) + swap 4 roll swap + ~ (length, log address, old here, start, here pointer) + ! + ~ (length, log address, old here) + 3unroll + ~ (old here, length, log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" =" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + ~ (old here, length, log address) + swap dup 3unroll + ~ (old here, length, log address, length) + 8 + log-load-comma + ~ (old here, length, log-address) + 3unroll + ~ (log address, old here, length) + drop 5 8 * + + ~ (log address, new here) + swap log-load-here + ~ (new here, log address, here pointer) + 3roll swap ! ; + + +~ (true start, true length, false start, false length, log address +~ -- log address) +: log-load-if-else + 5 unroll 2dup + ~ (log address, true start, true length, false start, false length, + ~ false start, false length) + swap dup 7 8 * + 3roll + ~ (log address, true start, true length, false start, false length, + ~ false start, adjusted false start, false length) + memmove + ~ (log address, true start, true length, false start, false length) + 3 pick dup 5 8 * + + ~ (log address, true start, true length, false start, false length, + ~ true start, adjusted true start) + 4 pick + ~ (log address, true start, true length, false start, false length, + ~ true start, adjusted true start, true length) + memmove + ~ (log address, true start, true length, false start, false length) + + 4 roll dup 5 unroll + ~ (log address, true start, true length, false start, false length, + ~ true start) + 6 roll log-load-here @ 7 unroll + ~ (old here, true start, true length, false start, false length, true start, + ~ log address) + log-load-here 3roll swap ! + ~ (old here, true start, true length, false start, false length, + ~ log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" !=" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + ~ (old here, true start, true length, false start, false length, + ~ log address) + 4 roll dup 5 unroll + ~ (old here, true start, true length, false start, false length, + ~ log address, true length) + 3 8 * + log-load-comma + ~ (old here, true start, true length, false start, false length, + ~ log address) + 3unroll + ~ (old here, true start, true length, log address, + ~ false start, false length) + swap dup 3unroll + ~ (old here, true start, true length, log address, + ~ false start, false length, false start) + 5 8 * + + ~ (old here, true start, true length, log address, + ~ false start, false length, adjusted false start) + 4 roll log-load-here 3roll swap ! + ~ (old here, true start, true length, + ~ false start, false length, log address) + s" branch" log-load-find entry-to-execution-token log-load-comma + swap 8 + log-load-comma + ~ (old here, true start, true length, false start, log address) + 4 unroll + ~ (old here, log address, true start, true length, false start) + drop drop drop + ~ (old here, log address) + log-load-here + 3roll 7 8 * + swap ! ; + + +~ (start, length, log address -- log address) +: log-load-forever + s" branch" log-load-find entry-to-execution-token log-load-comma + swap 8 + -1 * log-load-comma + swap drop ; + + +~ (test start, test length, body start, body length, log address +~ -- log address) +: log-load-while + 5 unroll 2dup + ~ (log address, test start, test length, body start, body length, + ~ body start, body length) + swap dup 5 8 * + 3roll + ~ (log address, test start, test length, body start, body length, + ~ body start, adjusted body start, body length) + memmove + + ~ (log address, test start, test length, body start, body length) + 5 roll log-load-here @ 6 unroll + ~ (old here, test start, test length, body start, body length, log address) + log-load-here 4 roll dup 5 unroll swap ! + ~ (old here, test start, test length, body start, body length, log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" !=" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + swap dup 3unroll 3 8 * + log-load-comma + ~ (old here, test start, test length, body start, body length, log address) + log-load-here 5 8 * 8 roll + swap ! + ~ (test start, test length, body start, body length, log address) + s" branch" log-load-find entry-to-execution-token log-load-comma + 5 unroll + ~ (log address, test start, test length, body start, body length) + 6 8 * + swap drop + swap drop -1 * log-load-comma ; + diff --git a/language/static/output.e b/language/static/output.e new file mode 100644 index 0000000..cadd5fb --- /dev/null +++ b/language/static/output.e @@ -0,0 +1,252 @@ +~ Output +~ ~~~~~~ +~ +~ It is convenient to be able to output text. This depends on the +~ OS-specific stuff in language/static/linux.e, so it's in its own file. +~ +~ The most interesting word we define here is ".", pronounced "dot"; the +~ math stuff is needed to implement it. +~ +~ Unlike Jonesforth, we do not have a global "base" variable, and this word +~ does not change its behavior depending on that value. It's always base ten. + + +~ Strings are comparatively easy. +~ +~ (string pointer --) +: emitstring dup stringlen 1 3unroll sys-write drop ; + +: space 32 value@ emitstring drop ; +: newline 10 value@ emitstring drop ; + + +~ (base, exponent -- base to the power of exponent) +: pow + 1 swap + + { + ~ If the count of remaining powers is equal to zero, exit. + dup { drop swap drop exit } unless + ~ (base, result so far, count of remaining powers) + + 1 - 3unroll + ~ (updated count of remaining powers, base, result so far) + + swap dup 4 unroll + ~ (base, updated count of remaining powers, result so far, base) + + * swap + ~ (base, updated result so far, updated count of remaining powers) + } forever ; + + +~ (base, value -- floor of logarithm of value in base base) +: logfloor + ~ Start with a product equal to the base, and a count of 0. + swap dup 3unroll 0 + + { + ~ This is the start of the loop body. + ~ (base, value, product so far, count of powers included so far) + 3unroll 2dup + ~ (base, count so far, value, product so far) + + ~ If we get here, we're done. + ~ (base, count so far, value, product so far) + >unsigned { drop drop swap drop exit } if + + ~ If we're here, we need to do another loop. + ~ (base, count so far, value, product so far) + 4 roll dup 5 unroll * 3roll 1 + + ~ (base, value, updated product so far, updated count so far) + + ~ If the product is less than the base, we overflowed. In that case, the + ~ product-so-far is the maximum, so just return it. + 4 roll dup 5 unroll 3roll dup 4 unroll + < { 4 unroll drop drop drop exit } if + + ~ Nothing else weird going on, so loop. + } forever ; + + +~ (base, value -- ceiling of logarithm of value in base base) +: logceil + ~ Start with a product of 1 and a count of 0. + 1 0 + + { + ~ This is the start of the loop body. + ~ (base, value, product so far, count of powers included so far) + 3unroll 2dup + ~ (base, count so far, value, product so far) + + ~ If we get here, we're done. + ~ (base, count so far, value, product so far) + >=unsigned { drop drop swap drop exit } if + + ~ If we're here, we need to do another loop. + ~ (base, count so far, value, product so far) + 4 roll dup 5 unroll * 3roll 1 + + ~ (base, value, updated product so far, updated count so far) + + ~ If the product is less than the base, we overflowed. In that case, the + ~ product-so-far is the maximum, so just return it. + 4 roll dup 5 unroll 3roll dup 4 unroll + < { 4 unroll drop drop drop exit } if + + ~ Nothing else weird going on, so loop. + } forever ; + + +~ This is an extremely inefficient implementation, but on the plus side, +~ doing that avoids having to think about any sort of memory management or +~ recursion, and lets us stick entirely with the trivial control-flow +~ constructs we already have. +~ +~ (integer to print, base to print in, width to zero-pad to --) +: .base-unsigned + ~ (input, base, width) + ~ Compute how many digits we need to display. Because we use logfloor, the + ~ logic of always printing at least one digit is already handled for us. + 3unroll swap 2dup logfloor 1 + + ~ (width, base, input, number of digits if no padding) + 4 roll 2dup > { + ~ (base, input, number of digits if no padding, width) + ~ If we're here, we should use the padded width + swap drop + } { + ~ (base, input, number of digits if no padding, width) + ~ If we're here, we should use the unpadded width + drop + } if-else + + { + ~ (base, input, number of digits remaining) + ~ This is the start of the loop. + 2dup 1 - + ~ (base, input, number of digits remaining, input, intermediate value) + 5 roll dup 6 unroll swap + ~ (base, input, number of digits remaining, input, base, intermediate value) + pow /% swap drop + ~ (base, input, number of digits remaining, + ~ input divided by base^x appropriately) + 4 roll dup 5 unroll + ~ (base, input, number of digits remaining, + ~ input divided by base^x appropriately, base) + /% drop + ~ (base, input, number of digits remaining, current digit) + + ~ We construct a one-character string on the stack, then use a pointer to + ~ it. It will always contain its own null-termination without us having to + ~ do anything special to that end. + dup 10 > { + 0x30 ~ ASCII "0" + } { + 10 - 0x61 ~ ASCII "a" + } if-else + + + value@ emitstring + + ~ We deallocate the string by dropping it. + ~ + ~ Saying it like that makes it sound obvious; contemplate it until it feels + ~ surprising. + drop + + 1 - + dup { drop drop drop exit } unless + } forever ; + + +~ (integer to print, base to print in --) +: .base + swap + ~ (base, input) + + ~ Deal with negative numbers. + dup 0 > { + -1 * + s" -" emitstring + } if + + swap 0 .base-unsigned ; + + +~ Although this could notionally be called emitinteger for symmetry, it's +~ well-known under the name dot and as a single period character, and that +~ name participates in conventions for names of other things. So, we go with +~ it. +~ +~ (integer to print --) +: . 10 .base ; +: .hex 16 0 .base-unsigned ; +: .hex8 16 2 .base-unsigned ; +: .hex16 16 4 .base-unsigned ; +: .hex32 16 8 .base-unsigned ; +: .hex64 16 16 .base-unsigned ; + +~ (integer to print, width --) +: .hexn 16 swap .base-unsigned ; + + + +~ The control structure here is the same as .base-unsigned, but it outputs +~ to a string. +~ +~ The use of the "pack" nomenclature here is a little odd in that most other +~ uses are for binary structures rather than text, but compare packstring. +~ +~ (output point, integer to print, base to print in, width to zero-pad to +~ -- output point) +: pack-base-unsigned + 3unroll swap 2dup logfloor 1 + + 4 roll 2dup > { + swap drop + } { + drop + } if-else + + { + ~ (output point, base, input, number of digits remaining) + 2dup 1 - + 5 roll dup 6 unroll swap + pow /% swap drop + 4 roll dup 5 unroll + /% drop + + dup 10 > { + 0x30 ~ ASCII "0" + } { + 10 - 0x61 ~ ASCII "a" + } if-else + + + ~ (output point, base, input, number of digits remaining, character) + 5 roll swap pack8 4 unroll + + 1 - + dup { drop drop drop exit } unless + } forever ; + + +~ (output point, integer to print, base to print in -- output point) +: pack-base + swap + + dup 0 > { + -1 * + 3roll s" -" packstring 3unroll + } if + + swap 0 .base-unsigned ; + + +~ (output point, integer to print -- output point) +: pack-decimal 10 pack-base ; +: pack-hex 16 0 pack-base-unsigned ; +: pack-hex8 16 2 pack-base-unsigned ; +: pack-hex16 16 4 pack-base-unsigned ; +: pack-hex32 16 8 pack-base-unsigned ; +: pack-hex64 16 16 pack-base-unsigned ; + +~ (output point, integer to print, width -- output point) +: pack-hexn 16 swap pack-base-unsigned ; diff --git a/linux-dynamic.e b/linux-dynamic.e deleted file mode 100644 index ec9e370..0000000 --- a/linux-dynamic.e +++ /dev/null @@ -1,359 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ More system calls for Linux ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ Here's some more system calls for the Linux kernel, augmenting the ones in -~ linux.e. We needed the basic I/O stuff early, to use in building the -~ interpreter, but there's less-basic stuff that benefits from dynamic -~ definition. That stuff is here. -~ -~ In particular, everything that takes a struct is here, because that lets -~ us define the system call next to the allocation stuff, for ease of -~ reference. There are also higher-level facilities, later in the file. - - -~ Since the only way to know the struct layout is by reading the kernel -~ source, we put that definition here, as well. -~ (-- struct pointer) -: allocate-timespec 2 8 * allocate ; -~ (struct pointer -- field pointer) -: timespec-seconds ; -: timespec-nanoseconds 8 + ; - - -~ (nanoseconds -- result code) -: nanosleep - 1000000000 /% - ~ (nanoseconds, seconds) - allocate-timespec - dup timespec-seconds 3roll swap ! - dup timespec-nanoseconds 3roll swap ! - allocate-timespec - dup timespec-seconds 0 swap ! - dup timespec-nanoseconds 0 swap ! - dup 3unroll - 35 ~ syscall number - syscall-2 - drop drop ; - - -~ The old name was sigaction(), but per the glibc manpages, that was -~ replaced by rt_sigaction() quite some time ago, to allow larger signal set -~ bitmaps for the benefit of realtime signals. Both are still present; we use -~ rt_sigaction(). There are also two versions of rt_sigaction; grep -~ ODD_RT_SIGACTION in the kernel source for more details. Neither x86 -~ architecture has the "odd" version of rt_sigaction(), so we use the regular -~ one, not to be confused with the "compat" one. Its definition is in -~ kernel/signal.c, in case you need to check the struct sizes and layouts. -~ -~ The parameters are: An integer signal identifier; an optional pointer to a -~ struct describing the new action to bind (or unbind if NULL); an optional -~ pointer to another of the same struct to hold a copy of the old action; and -~ a 64-bit word which must describe the correct size of sigset_t, which is a -~ C type used for the mask field of that struct. Any other value for the size -~ field is an error. -~ -~ Mandatory size fields start to make sense when you have a compatibility -~ situation this convoluted... Think of it as the caller promising they know -~ which version of the API they're calling. The unmarked version of -~ rt_sigaction() takes a 64-bit sigset_t, and the parameter wants the size in -~ bytes, so we use a value of 8. -~ -~ Anyway, we aren't C and don't have POSIX naming obligations, so we just -~ call it sigaction. -~ -~ (signal number, new action pointer, old action pointer -- result code) -: sys-sigaction - 8 ~ size of sigset_t in bytes - 13 ~ syscall number - syscall-4 ; - - -~ (new stack pointer, old stack pointer -- result code) -: sys-sigaltstack - 131 ~ syscall number - syscall-2 ; - - -~ Since the only way to know the struct layout is by reading the kernel -~ source, we put that definition here, as well. -~ -~ There are MANY versions of this struct; this is the appropriate one for -~ amd64. -~ -~ (-- struct pointer) -: allocate-sigaction here @ 128 packalign here ! 4 8 * allocate ; -~ (struct pointer -- field pointer) -: sigaction-action ; -: sigaction-flags 8 + ; -: sigaction-restorer 2 8 * + ; -: sigaction-mask 3 8 * + ; - - -: allocate-sigaltstack here @ 128 packalign here ! 3 8 * allocate ; -: sigaltstack-pointer ; -: sigaltstack-flags 8 + ; -: sigaltstack-size 2 8 * + ; - - -~ High-level facilities -~ ~~~~~~~~~~~~~~~~~~~~~ - -~ It's possible to set up an alternate stack for signal handlers. We don't, -~ though, so it's possible this code has bitrotted. At the very least, it -~ should be more configurable than this. -: prepare-signal-stack - here @ 2048 packalign here ! - 1024 1024 * 4 * allocate - ~ (stack address) - allocate-sigaltstack - ~ (stack address, struct pointer) - 2dup sigaltstack-pointer ! - dup sigaltstack-flags 0 swap ! - dup sigaltstack-size 1024 1024 * 32 * swap ! - ~ (stack address, struct pointer) - allocate-sigaltstack - sys-sigaltstack - drop ; - - -~ On amd64, and on no other architecture, the Linux kernel requires that -~ the language runtime use a "restorer" when binding signal handlers. This -~ is that restorer. The kernel wants a raw pointer that it can use as a -~ C-style return address on the C stack, which is our value stack. So, this -~ has to be an assembly word, it can't use docol. When the data structure is -~ populated by bind-signal, we'll dereference the codeword and pass that -~ value, but there's no chance to give it the usual callee address in rax, so -~ we can't use a Forth-style interpreter codeword, it has to be a -~ self-codeword. -~ -~ The purpose of the trampoline is to be invoked by our signal handler. The -~ manner of that invocation MUST be returning into it with the "ret" -~ instruction; otherwise the C stack won't be right for cleanup to work -~ properly. -~ -~ When invoked, the trampoline invokes the syscall "sigreturn", whose sole -~ purpose is to be called from this trampoline. That syscall won't return in -~ a conventional way, so we don't bother handling the scenario where it does. -~ -~ According to commentary in the Go compiler's internals[1][2][3], gdb -~ recognizes the trampoline based on its exact byte values, since the intent -~ is only to be compatible with glibc. We intend to be our own debugger -~ anyway, so we don't worry about that. We're not seeking fame and we don't -~ have a corporate image to uphold, so that level of fragility and contortion -~ is just too much. The thing about compatibility constraints is knowing when -~ to work with them and when to walk away. -~ -~ Experimentally, it is also possible to avoid using this trampoline by -~ faking it: set the "restorer" bit in the action flags, but pass a null -~ pointer as the restorer, then have the handler pop 8 bytes from the stack -~ and invoke sigreturn directly. The actual requirement seems to be that rsp -~ points at the saved state, at the time of invoking sigreturn. We're not -~ doing that, because signal handling is not intended to be -~ performance-critical and it feels like asking for trouble, but the -~ possibility is noted here against future use. -~ -~ This doesn't have an interface definition comment, because it doesn't use -~ the Forth execution model. -~ -~ [1] https://go.googlesource.com/go/+/refs/heads/master/src/runtime/sys_linux_amd64.s#472 -~ [2] https://go.googlesource.com/go/+/refs/heads/master/src/runtime/os_linux.go#476 -~ [3] https://go.googlesource.com/go/+/refs/heads/master/src/runtime/defs_linux_amd64.go#118 -: signal-return-trampoline - [ here @ - 15 :rax mov-reg64-imm64 ~ sigreturn - syscall - here ! ] ;asm - -~ This accepts an execution token. It creates a hidden word on the log which -~ wraps that execution token with necessary setup and teardown to run as a -~ Unix signal handler, and returns the execution token of the wrapper. -~ -~ Specifically, on invocation, the wrapper ensures that rsi points to its -~ second half and rbp points to the top of the control stack; loads the target -~ execution token into rax; then indirectly calls it. This is the usual -~ interface of a normal call in the Forth execution model, so the wrapped word -~ can be based on docol, on a self-codeword, or on any other interpreter word -~ it wants. It can also freely call whatever Forth things it wants. -~ -~ We don't have to do anything about rsp because the invariants for our use -~ of it as the value stack are a subset of the invariants for C's use of it as -~ its only stack. It's already working the way we need it to. -~ -~ When the wrapped word returns, it uses the rsi the wrapper provided to do -~ so, which places control in the second half of the wrapper. This second half -~ simply executes a "ret" instruction, which is the necessary invocation of -~ the signal return trampoline (see above). This will transfer control back -~ to the kernel, and will ultimately result in Forth execution resuming where -~ it left off before the signal was delivered. -~ -~ Crucially, the wrapper relies on the kernel preserving the value of rbp -~ that existed at the moment before the control transfer began. Signal -~ delivery is an UNCONTROLLED control transfer, meaning that we as the -~ language runtime do not have an opportunity to execute any cleanup before it -~ happens. If it were a controlled transfer, we would be able to save rbp to -~ a global variable somewhere, and restore it in the wrapper. It's not, so we -~ don't have that chance. -~ -~ Notionally we could freshly allocate a new control stack somewhere else, -~ and set rbp to point to it, but it would be challenging to do that without -~ relying on the control stack, and inefficient to execute, and the call for -~ now is that that's not worth it. -~ -~ The only situation in which this limitation will become a practical -~ concern is if, at the time of signal delivery, something outside the Forth -~ execution model is happening. In that case, the wrapper will likely crash. -~ -~ As a long term strategy, the way to mitigate this would be to make sure -~ that all non-signal transfers from within the Forth execution model to -~ outside it are controlled, and that they save global state that can be -~ reconstructed here. For now, we leave this as future work. -~ -~ (execution token -- execution token) -: wrap-signal-handler - ~ We generate a word entry for the wrapper, and hide it. Since it's - ~ hidden, the name doesn't have to be unique. This keeps the log clean, so - ~ that all the space on it will always be attributable to some specific - ~ word. Remember kids, keeping the log clean is everyone's responsibility! - s" signal-handler-wrapper" create make-hidden - - ~ This self-codeword will be consumed by bind-signal. - self-codeword - - here @ dup - ~ (inner execution token, saved location, output point) - - ~ It's our responsibility as a caller to set rsi to point to the address - ~ of an execution token, which will pick up where we left off. That token - ~ will be our own second half, whose address we don't yet know, so we - ~ output a placeholder opcode here and overwrite it once we do. That's why - ~ we've saved the current location. - 0 :rsi mov-reg64-imm64 - - ~ We also need to make sure that rbp points to an area that can be treated - ~ as the top of the control stack (there's no need to ever unwind past it, - ~ so it doesn't have to be the "real" one). Fortunately, it comes to us - ~ already valid and we don't have to do anything about that. Plus it even - ~ does happen to be the real one, which will let stack tracing code run in - ~ a handler, and we do care about that. - - ~ We also need to set DF = 0, since that's also part of our ABI. - cld - - ~ Compare this snippet to "execute" in core.e. Instead of taking rax from - ~ the stack, we set a hardcoded value picked at the time we generate the - ~ wrapper. We then do the same indirect jump via the codeword it points to, - ~ which allows the codeword's implementation to take advantage of rax - ~ pointing to the callee; that's the property docol cares about. - 3roll :rax mov-reg64-imm64 - :rax jmp-abs-indirect-reg64 - ~ (saved location, output point) - - 8 packalign - here ! - ~ (saved location) - - ~ Now we have our second half, which has another codeword that rsi will - ~ point to for our callee's benefit. This half runs after the wrapped word, - ~ and has the responsibility of cleaning up and returning control to the - ~ kernel, which it does by returning to the restorer trampoline. Yes, this - ~ is a trampoline which passes control to another trampoline. - ~ - ~ Although we run under the log-load transform, we won't ever actually be - ~ invoked until at least log-load time, if not ultimate runtime. Both of - ~ those are in the target address space. So there's no address translation - ~ going on behind our back. Nonetheless, we avoid directly outputting any - ~ address except what we get via self-codeword, which would be recommended - ~ practice under the transforms. Yeah, it's a little convoluted, perhaps - ~ unnecessarily so. - here @ - self-codeword - @ 8 - - ~ (saved location, second half execution token) - - ~ Something subtle here: That above "codeword" was actually a word - ~ pointer. See, because we're pretending the wrapper is a Forth word, even - ~ though we're writing it in assembly, so "returning" to it means invoking - ~ the next word pointer in the word pointer array that is its compiled form. - ~ Instead of creating a separate memory area though, we just put the pointer - ~ target right here, as another codeword... - self-codeword - - ~ Now we treat the saved location as an output point, and re-output the - ~ mov instruction that we stubbed out above. Because our assembler words - ~ always output a specific, exact form of the instruction, we know it will - ~ take up the same number of bytes. - :rsi mov-reg64-imm64 - drop - - ~ Having done that, we can get on to the body of our second half. Happily, - ~ it's quite short. - here @ - - ret - - 8 packalign - here ! - - ~ Our caller wants an execution token that invokes all this. Since we - ~ used "create" above, that's easy to get. - latest @ entry-to-execution-token ; - - -~ This accepts an execution token and a Unix signal number, and binds the -~ token to be the handler for the signal. It also does other necessary setup, -~ including picking appropriate flags for the binding and attaching the -~ return trampoline (see above). -~ -~ Typically, you will want this execution token to be one returned by -~ wrap-signal-handler. Doing this will allow the handler to use the Forth -~ execution model in any way it wants, including calling both docol words and -~ assembly words, and working with both the control and value stacks at will. -~ -~ There is an important limitation of wrap-signal-handler, described in more -~ detail above: Its wrapper only functions correctly when Forth code was -~ running at the time of the control transfer. For example, if Forth had -~ called into C, and then that C were interrupted by a signal, the signal -~ handler would have no way of finding the top of the control stack. -~ -~ If your program involves many callbacks back-and-forth between C and -~ Forth, you may wish to forego the use of the wrapper and provide an -~ execution token meant to be invoked directly by the kernel. In this case, -~ bear in mind that its execution must not use the control stack - that is, -~ it must not rely on having been given sensible values of rsi or rbp. This -~ means it can't call other Forth words (unless it does something about that -~ on its own). -~ -~ Regardless of whether the execution token is a copy of the wrapper or not, -~ it must be an assembly word, not a docol word. The kernel wants a raw -~ pointer that it can simulate a C-style call to, so we dereference the -~ codeword and pass that value, just as we do with the return trampoline. Also -~ as with the return trampoline, there is no way to pass the callee in rax, -~ which is the usual interface docol and other interpreter words expect. So, -~ it needs to be a self-codeword. -~ -~ (execution token, signal number --) -: bind-signal - allocate-sigaction - dup sigaction-action 4 roll @ swap ! - dup sigaction-mask 0 swap ! - dup sigaction-flags 0x04000000 swap ! - dup sigaction-restorer - ' signal-return-trampoline entry-to-execution-token @ swap ! - ~ (signal number, struct pointer) - allocate-sigaction - sys-sigaction drop ; - - -: handle-crash ." CRASH" newline list-callers 1 sys-exit ; - -: install-crash-handler - ' handle-crash entry-to-execution-token wrap-signal-handler - 11 bind-signal ; - -~ There are scenarios where someone might want to disable this, for example -~ if calling back and forth between C and Evocation, but for now we always -~ enable it. -~ : blank-line -install-crash-handler - diff --git a/linux.e b/linux.e deleted file mode 100644 index e757ee2..0000000 --- a/linux.e +++ /dev/null @@ -1,152 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ System calls for the Linux kernel ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ The kernel preserves every register except rax, rcx, and r11. The system -~ call number goes in rax, as does the return value. Parameters go in rdi, -~ rsi, rdx, r10, r8, and r9, in that order. [SysV] A.2.1. -~ -~ Notice that rsi is our control stack, so we have to save it (for -~ syscalls with at least two parameters). We can use the value stack to do -~ that, since rsp is preserved, or we can use one of the other registers. We -~ don't ourselves save other registers because our caller should do that, if -~ it cares. -~ -~ In the kernel source, you may find the following files useful to -~ reference: -~ -~ * arch/x86/entry/syscalls/syscall_64.tbl -~ * include/linux/syscalls.h -~ * include/linux/compat.h -~ -~ Don't be confused by tools/scripts/syscall.tbl, it's not for x86. -~ -~ This file loads early, before dynamic.e. So, although it superficially -~ appears to be able to do allocation and high-level flow control, those come -~ from the transforms, which means they're shallow implementations. The stuff -~ here can't be moved later, because input.e relies on it, and the dynamic -~ stuff relies on that. So, there's additional Linux functionality in another -~ file that loads later, linux-dynamic.e. - - -~ (call number -- return value) -: syscall-0 - [ here @ - :rax pop-reg64 ~ syscall number - syscall - :rax push-reg64 ~ return value - here ! ] ;asm - -~ (first param, call number -- return value) -: syscall-1 - [ here @ - :rax pop-reg64 ~ syscall number - :rdi pop-reg64 ~ first param - syscall - :rax push-reg64 ~ return value - here ! ] ;asm - -~ (first param, second param, call number -- return value) -: syscall-2 - [ here @ - :rsi :rbx mov-reg64-reg64 ~ save rsi - :rax pop-reg64 ~ syscall number - :rsi pop-reg64 ~ second param - :rdi pop-reg64 ~ first param - syscall - :rbx :rsi mov-reg64-reg64 ~ restore rsi - :rax push-reg64 ~ return value - here ! ] ;asm - -~ (first param, second param, third param, call number -- return value) -: syscall-3 - [ here @ - :rsi :rbx mov-reg64-reg64 ~ save rsi - :rax pop-reg64 ~ syscall number - :rdx pop-reg64 ~ third param - :rsi pop-reg64 ~ second param - :rdi pop-reg64 ~ first param - syscall - :rbx :rsi mov-reg64-reg64 ~ restore rsi - :rax push-reg64 ~ return value - here ! ] ;asm - -~ (first param, second param, third param, fourth param, call number -~ -- return value) -: syscall-4 - [ here @ - :rsi :rbx mov-reg64-reg64 ~ save rsi - :rax pop-reg64 ~ syscall number - :r10 pop-extrareg64 ~ fourth param - :rdx pop-reg64 ~ third param - :rsi pop-reg64 ~ second param - :rdi pop-reg64 ~ first param - syscall - :rbx :rsi mov-reg64-reg64 ~ restore rsi - :rax push-reg64 ~ return value - here ! ] ;asm - - -~ (first param, second param, third param, fourth param, fifth param, -~ call number -- return value) -: syscall-5 - [ here @ - :rsi :rbx mov-reg64-reg64 ~ save rsi - :rax pop-reg64 ~ syscall number - :r8 pop-extrareg64 ~ fifth param - :r10 pop-extrareg64 ~ fourth param - :rdx pop-reg64 ~ third param - :rsi pop-reg64 ~ second param - :rdi pop-reg64 ~ first param - syscall - :rbx :rsi mov-reg64-reg64 ~ restore rsi - :rax push-reg64 ~ return value - here ! ] ;asm - - -~ (first param, second param, third param, fourth param, fifth param, -~ sixth param, call number -- return value) -: syscall-6 - [ here @ - :rsi :rbx mov-reg64-reg64 ~ save rsi - :rax pop-reg64 ~ syscall number - :r9 pop-extrareg64 ~ sixth param - :r8 pop-extrareg64 ~ fifth param - :r10 pop-extrareg64 ~ fourth param - :rdx pop-reg64 ~ third param - :rsi pop-reg64 ~ second param - :rdi pop-reg64 ~ first param - syscall - :rbx :rsi mov-reg64-reg64 ~ restore rsi - :rax push-reg64 ~ return value - here ! ] ;asm - - -~ Raw system calls -~ ~~~~~~~~~~~~~~~~ - -~ This does the Linux exit() system call, passing it an exit code taken -~ from the stack. It does not return. -~ -~ (exit code -- *) -: sys-exit 60 syscall-1 - ~ In the event we're still here, let's minimize confusion. - crash ; - -~ This does the Linux write() system call, passing it an address from the -~ top of the stack and a length from the second position on the stack. It -~ uses a Unix file descriptor, which is a non-negative integer, to tell it -~ where to write to. For stdout, use fd 1. -~ -~ (file descriptor, base address, length to write -- result code or length) -: sys-write 1 syscall-3 ; - -~ (file descriptor, base address, length to read -- result code or length) -: sys-read 0 syscall-3 ; - -~ (filename, flags, mode -- result code or file descriptor) -: sys-open 2 syscall-3 ; - -~ (file descriptor -- result code) -: sys-close 3 syscall-1 ; - diff --git a/log-load.e b/log-load.e deleted file mode 100644 index a462c2e..0000000 --- a/log-load.e +++ /dev/null @@ -1,542 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ Bootstrapping the log ~~ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ -~ The log is the main region of memory within which most dynamic allocation -~ happens. It's a single contiguous segment of virtual memory, which is -~ requested from the kernel when Evocation starts up. Almost all of -~ Evocation's dynamic data is kept in the log, including the main dictionary; -~ several important global variables which make it possible to find and -~ allocate other data structures; and the control stack. -~ -~ This file has the task of providing words which are useful for working -~ with the log, and more specifically which are useful for helping to bring -~ the log into existence. Once the log exists, it can be used to manage -~ itself, but there's a bootstrapping challenge in getting there. That -~ challenge is solved by the warm-start routine in execution.e, which relies -~ on the words in this file and should load after it. -~ -~ Some modern Forths, including Jonesforth, refer to the log as the heap. -~ This is a misnomer; a heap is a data structure that allows non-contiguous -~ allocation. Although there are Forths that have true heaps, Evocation is not -~ one of them. Space in the log is allocated by incrementing the "here" -~ variable (one of those important globals), which necessarily can only -~ allocate contiguous blocks; there is no way to compact allocations to -~ reclaim fragmented, unused space in between them. Evocation does allow -~ deallocation using "forget", but this is done by resetting "here" and -~ "latest" to older values, unwinding every allocation that's been done since -~ the point in time they return to. -~ -~ It would be a mistake to confuse this allocation strategy with the -~ more-general facilities for allocation, reallocation, and deallocation of -~ individual memory blocks that many other languages have. To avoid confusion, -~ we stay away from the name "heap", though it may still occasionally be used -~ colloquially because it's familiar from other Forths, and because most -~ programming languages have a heap as the main memory segment they request -~ from the kernel. -~ -~ In the strictest technical sense, the log is a stack: Things are added -~ to the end of it, and removed from that same end. However, Evocation already -~ has two other stacks, the control and value stacks. Adding to the potential -~ confusion, the control stack is actually stored inside the log (as a -~ fixed-size chunk at the bottom). However, the log isn't really that much -~ like a stack when you look at how it's actually used. Unlike Evocation's -~ control and value stacks, data structures on the log tend to be rich and -~ complex, interlinked in various ways through the use of pointers. They also -~ tend to be long-lived, with the log tending to grow over time, whereas the -~ control and value stacks tend to remain roughly the same size through cycles -~ of growth and shrinking. In order to be able to speak precisely about what -~ we're doing, we introduce the name "log" to refer to the entire memory -~ segment and everything stored within it. -~ -~ Another linguistic choice we make is to be clear about dictionaries. A -~ dictionary is a linked list of word entries. Each dictionary has a specific -~ handle, a pointer to a pointer, which is the root of the list. Each -~ word entry begins with a specific data structure, which among other things -~ includes a next-entry pointer, a flags byte, and a string that serves as -~ the entry's name. Older entries in a dictionary seldom change; newer entries -~ are added at the beginning of it, with their next-entry pointers leading to -~ the older entries. It is possible for several dictionaries to exist at once, -~ each with its own dictionary handle. -~ -~ Since dictionaries are managed using pointers to individual entries, there -~ is no specific requirement about the order in which those entries occur in -~ memory or where they are allocated, but usually a new entry is allocated at -~ the end of the log, by incrementing the variable "here", in the same manner -~ as any other allocation. There is one particular dictionary, the main -~ dictionary, whose handle is the variable "latest". The main dictionary holds -~ every executable word that can be used normally via Evocation's interpreter. -~ -~ Since the main dictionary is by far the most important thing in the log, -~ it can be tempting to conflate the log with the main dictionary. This is -~ accurate enough for some purposes, but note that other dictionaries are -~ often interleaved with it, their allocations entwining like grape vines even -~ while each remains separate, reachable only via its own root. See the -~ machine label facility, in labels.e, for an example of how a secondary -~ dictionary can be useful. -~ -~ This may feel tangential, but it's important background and there's no -~ better place to explain it: A handle is a pointer to a pointer. The variable -~ "latest" returns a handle, a fixed address which always holds the pointer to -~ the root entry of the main dictionary. Dereferencing that handle gives you -~ the dictionary pointer, the address of the root entry, which is suitable to -~ pass to find-in and similar words that read the dictionary's contents. When -~ you want to add a new entry to a dictionary, you need the dictionary's -~ handle, so that the root pointer can be changed. When you only want to write -~ it, you only need the regular single pointer. -~ -~ When reading the documentation of words that work with dictionaries, pay -~ close attention to whether their parameters include a dictionary handle, or -~ a dictionary pointer. -~ -~ The term "handle" was widely known in the early days of microcomputing, -~ when memory-safe languages without direct pointer access were less common. -~ Today it is usually considered specific to systems programming, the type of -~ programming which lies beneath other software and deals with topics such as -~ memory management and processes. Evocation is a systems-programming -~ language, in the sense that it takes pains to not introduce mandatory -~ abstractions which would make it difficult or inefficient to work directly -~ with these topics. So, in understanding Evocation, it's important to know -~ about handles. -~ -~ Some of these bootstrap words rely on being able to invoke assembler words -~ that output machine code. Therefore, those words must be available at -~ runtime. Since nothing can be dynamically available at runtime until after -~ we've already run the log-load routine, which relies on the stuff in this -~ file, the assembler words must be statically available via the label -~ transform. That means their definitions in arm64.e must be loaded before -~ this file. - - -~ This has the same value as the constant control-stack-size, which is -~ defined in execution.e. Everything will break if it doesn't. -~ -~ TODO: remove one of them. Probably the other one. -: log-offset 0x10000 ; ~ 64 KiB - -~ (log address -- log address, "log" pointer) -: log-load-log - dup log-offset + ; -~ (log address -- log address, "s0" pointer) -: log-load-s0 - dup log-offset + 8 + ; -~ (log address -- log address, "r0" pointer) -: log-load-r0 - dup log-offset + 2 8 * + ; -~ (log address -- log address, "latest" pointer) -: log-load-latest - dup log-offset + 3 8 * + ; -~ (log address -- log address, "here" pointer) -: log-load-here - dup log-offset + 4 8 * + ; - - -~ This is a helper used by warm-start, which invokes find-in using "latest". -~ It relies on being passed the root address of the log, which is used to find -~ the global variable "latest". It's inconvenient to keep a log pointer around -~ all the time, which is why we stop doing it as soon as possible, but during -~ Evocation's startup there's no alternative. This word is used extensively -~ by code that's been compiled via the log-load transform; see transform.e for -~ details. -~ -~ It would be possible to unload this word after the log is created, but -~ there are rare situations in which it's still useful, such as injecting -~ Evocation into another process's address space. Plus, it's small. So, we -~ keep it around. -~ -~ (log address, string pointer -- log address, entry pointer or 0) -: log-load-find - swap log-load-latest @ swap 3unroll swap find-in ; - -~ In the code generated by the log-load transform, it's convenient to have -~ only a single step needed to look up a word's execution token. This helper -~ does log-load-find, then gets the execution token if an entry is found. -~ -~ (log address, string pointer -- log address, execution token or 0) -: log-load-find-execution-token - dup 3unroll log-load-find dup - { - 3roll drop - entry-to-execution-token - } { - drop swap - ." No such word: " emitstring newline - 0 - } if-else ; - - -~ This is the same as "create", from dynamic.e, except that it takes the -~ log's address as a parameter rather than hardcoding it, so that it can be -~ used in situations where the normal compilation process isn't yet available. -~ -~ The requisite stack juggling is kind of finicky, sorry if it's hard to -~ read, but it's doing the same steps in the same order as the regular -~ "create". -~ -~ (log address, string pointer -- log address) -: log-load-create - dup stringlen 1 + dup 3unroll - ~ (log address, name field length, string pointer, name field length) - - 3 pick log-load-here swap drop @ 10 + swap memmove - ~ (log address, name field length) - - over log-load-here swap drop @ - ~ (log address, name field length, output point) - - 2 pick log-load-latest swap drop @ pack64 - ~ (log address, name field length, output point) - 0 pack8 - 0 pack8 - + - ~ (log address, output point) - 8 packalign - ~ (log address, output point) - - over log-load-here swap drop @ - ~ (log address, output point, old here value) - 2 pick log-load-latest swap drop ! - ~ (log address, output point) - over log-load-here swap drop ! ; - - -~ (log address -- log address) -: log-load-self-codeword - log-load-here dup @ - ~ (log address, here, output point) - - dup 8 + pack64 - ~ (log address, here, output point) - - swap ! ; - - - -~ This is the same as ",", from dynamic.e, except that it takes the log's -~ address as a parameter rather than hardcoding it, so that it can be used in -~ situations where the normal compilation process isn't yet available. -~ -~ Again, the stack juggling is kind of a lot, sorry about that. -~ -~ (log address, value -- log address) -: log-load-comma - swap log-load-here swap 3unroll - ~ (log address, value, here) - @ swap pack64 - ~ (log address, updated here value) - swap log-load-here swap 3unroll - ~ (log address, updated here value, here) - ! ; - - -~ This is the same as `;asm`, from dynamic.e, except that it takes the -~ log's address as a parameter rather than hardcoding it, so that it can be -~ used in situations where the normal compilation process isn't yet available. -~ -~ Its two main responsibilities are to call `pack-next`, from -~ execution-support.e, and to overwrite the codeword. It also deals with -~ alignment. -~ (log address) -: log-load-semicolon-assembly - log-load-here @ - ~ (log address, output point) - - pack-next - 8 packalign - ~ (log address, output point) - - swap log-load-here swap 3unroll ! - ~ (log address) - - log-load-latest @ - ~ (log address, entry pointer) - entry-to-execution-token - dup 8 + swap ! ; - - -~ This is the same as "variable", from dynamic.e, except that it takes the -~ log's address as a parameter rather than hardcoding it, so that it can be -~ used in situations where the normal compilation process isn't yet available. -~ -~ (log address, address for new variable word, string pointer -- log address) -: log-load-variable - 3roll swap log-load-create - ~ (address for new variable word, log address) - - log-load-here swap 3unroll - ~ (log address, address for new variable word, here) - - dup @ - ~ (log address, address for new variable word, here, output point) - dup 8 + pack64 - - 3roll :rax mov-reg64-imm64 - ~ (log address, here, output point) - - :rax push-reg64 - pack-next - 8 packalign - - swap ! ; - - -~ A keyword is a word that evaluates to its own address, which makes it -~ suitable for use as a constant. See more detail on that in dynamic.e, -~ where "keyword" is defined. -~ -~ Unlike Common Lisp, the lexer doesn't create keywords for us, we have to -~ do it explicitly. If if that were to someday change, the log-load routine -~ would still need a way to do it, which is this. -~ -~ It's kind of a pain to look up the appropriate "docol" from here, so we -~ do it in assembler instead. -~ -~ (log address, string pointer -- log address) -: log-load-keyword - log-load-create - ~ (log address) - - log-load-here @ dup - ~ (log address, self execution token, output point) - - dup 8 + pack64 - ~ (log address, self execution token, output point) - - swap :rax mov-reg64-imm64 - ~ (log address, output point) - - :rax push-reg64 - pack-next - 8 packalign - ~ (log address, output point) - - swap log-load-here - ~ (output point, log address, here) - swap 3unroll - ~ (log address, output point, here) - ! ; - - -~ This is a helper used by log-load-string-alternate. It does the usual -~ string packing thing, but at one layer of indirection more than usual. Its -~ responsibility includes alignment, unlike packstring. -~ -~ (log address, string pointer -- log address) -: log-load-comma-string - swap log-load-here @ 3roll - ~ (log address, output point, string pointer) - - packstring - 8 packalign - ~ (log address, output point) - - swap log-load-here 3roll swap - ~ (log address, output point, here) - ! ; - - -~ Now we have a bunch of words that are the back-ends for the log-load -~ transform's high-level flow control alternates. These implementations -~ closely parallel the non-transformed versions in flow-control.e, which -~ should be referenced in understanding them. -~ -~ These variants are a bit unusual in their interfaces: They end with the -~ log address at the top of the stack, even when they have values to return. -~ That's because they're really just "talking" to each other; they don't need -~ to interact with anything else, and doing it this way saves the alternates -~ the work of swapping things around after. -~ -~ Notice also that, because these run entirely at log-load time, they are -~ always dealing with target pointers and don't have to convert address -~ spaces. -~ -~ (log address -- start pointer, log address) -: log-load-left-curly-brace - log-load-here @ swap ; - - -~ (start pointer, log address -- start pointer, length, log address) -: log-load-right-curly-brace - swap dup 3roll - ~ (start pointer, start pointer, log address) - log-load-here @ swap - ~ (start pointer, start pointer, end pointer, log address) - 3unroll swap - swap ; - - -~ (start, length, log address -- log address) -: log-load-if - 3unroll - ~ (log address, start, length) - 2dup swap dup - ~ (log address, start, length, length, start, start) - 5 8 * + - ~ (log address, start, length, length, start, adjusted start) - 3roll - ~ (log address, start, length, start, adjusted start, length) - memmove - ~ (log address, start, length) - swap 3roll log-load-here dup @ - ~ (length, start, log address, here pointer, old here) - swap 4 roll swap - ~ (length, log address, old here, start, here pointer) - ! - ~ (length, log address, old here) - 3unroll - ~ (old here, length, log address) - s" lit" log-load-find entry-to-execution-token log-load-comma - 0 log-load-comma - s" !=" log-load-find entry-to-execution-token log-load-comma - s" 0branch" log-load-find entry-to-execution-token log-load-comma - ~ (old here, length, log address) - swap dup 3unroll - ~ (old here, length, log address, length) - 8 + log-load-comma - ~ (old here, length, log-address) - 3unroll - ~ (log address, old here, length) - drop 5 8 * + - ~ (log address, new here) - swap log-load-here - ~ (new here, log address, here pointer) - 3roll swap ! ; - - -~ (start, length, log address -- log address) -: log-load-unless - 3unroll - ~ (log address, start, length) - 2dup swap dup - ~ (log address, start, length, length, start, start) - 5 8 * + - ~ (log address, start, length, length, start, adjusted start) - 3roll - ~ (log address, start, length, start, adjusted start, length) - memmove - ~ (log address, start, length) - swap 3roll log-load-here dup @ - ~ (length, start, log address, here pointer, old here) - swap 4 roll swap - ~ (length, log address, old here, start, here pointer) - ! - ~ (length, log address, old here) - 3unroll - ~ (old here, length, log address) - s" lit" log-load-find entry-to-execution-token log-load-comma - 0 log-load-comma - s" =" log-load-find entry-to-execution-token log-load-comma - s" 0branch" log-load-find entry-to-execution-token log-load-comma - ~ (old here, length, log address) - swap dup 3unroll - ~ (old here, length, log address, length) - 8 + log-load-comma - ~ (old here, length, log-address) - 3unroll - ~ (log address, old here, length) - drop 5 8 * + - ~ (log address, new here) - swap log-load-here - ~ (new here, log address, here pointer) - 3roll swap ! ; - - -~ (true start, true length, false start, false length, log address -~ -- log address) -: log-load-if-else - 5 unroll 2dup - ~ (log address, true start, true length, false start, false length, - ~ false start, false length) - swap dup 7 8 * + 3roll - ~ (log address, true start, true length, false start, false length, - ~ false start, adjusted false start, false length) - memmove - ~ (log address, true start, true length, false start, false length) - 3 pick dup 5 8 * + - ~ (log address, true start, true length, false start, false length, - ~ true start, adjusted true start) - 4 pick - ~ (log address, true start, true length, false start, false length, - ~ true start, adjusted true start, true length) - memmove - ~ (log address, true start, true length, false start, false length) - - 4 roll dup 5 unroll - ~ (log address, true start, true length, false start, false length, - ~ true start) - 6 roll log-load-here @ 7 unroll - ~ (old here, true start, true length, false start, false length, true start, - ~ log address) - log-load-here 3roll swap ! - ~ (old here, true start, true length, false start, false length, - ~ log address) - s" lit" log-load-find entry-to-execution-token log-load-comma - 0 log-load-comma - s" !=" log-load-find entry-to-execution-token log-load-comma - s" 0branch" log-load-find entry-to-execution-token log-load-comma - ~ (old here, true start, true length, false start, false length, - ~ log address) - 4 roll dup 5 unroll - ~ (old here, true start, true length, false start, false length, - ~ log address, true length) - 3 8 * + log-load-comma - ~ (old here, true start, true length, false start, false length, - ~ log address) - 3unroll - ~ (old here, true start, true length, log address, - ~ false start, false length) - swap dup 3unroll - ~ (old here, true start, true length, log address, - ~ false start, false length, false start) - 5 8 * + - ~ (old here, true start, true length, log address, - ~ false start, false length, adjusted false start) - 4 roll log-load-here 3roll swap ! - ~ (old here, true start, true length, - ~ false start, false length, log address) - s" branch" log-load-find entry-to-execution-token log-load-comma - swap 8 + log-load-comma - ~ (old here, true start, true length, false start, log address) - 4 unroll - ~ (old here, log address, true start, true length, false start) - drop drop drop - ~ (old here, log address) - log-load-here - 3roll 7 8 * + swap ! ; - - -~ (start, length, log address -- log address) -: log-load-forever - s" branch" log-load-find entry-to-execution-token log-load-comma - swap 8 + -1 * log-load-comma - swap drop ; - - -~ (test start, test length, body start, body length, log address -~ -- log address) -: log-load-while - 5 unroll 2dup - ~ (log address, test start, test length, body start, body length, - ~ body start, body length) - swap dup 5 8 * + 3roll - ~ (log address, test start, test length, body start, body length, - ~ body start, adjusted body start, body length) - memmove - - ~ (log address, test start, test length, body start, body length) - 5 roll log-load-here @ 6 unroll - ~ (old here, test start, test length, body start, body length, log address) - log-load-here 4 roll dup 5 unroll swap ! - ~ (old here, test start, test length, body start, body length, log address) - s" lit" log-load-find entry-to-execution-token log-load-comma - 0 log-load-comma - s" !=" log-load-find entry-to-execution-token log-load-comma - s" 0branch" log-load-find entry-to-execution-token log-load-comma - swap dup 3unroll 3 8 * + log-load-comma - ~ (old here, test start, test length, body start, body length, log address) - log-load-here 5 8 * 8 roll + swap ! - ~ (test start, test length, body start, body length, log address) - s" branch" log-load-find entry-to-execution-token log-load-comma - 5 unroll - ~ (log address, test start, test length, body start, body length) - 6 8 * + swap drop + swap drop -1 * log-load-comma ; - diff --git a/output.e b/output.e deleted file mode 100644 index 45a29b7..0000000 --- a/output.e +++ /dev/null @@ -1,252 +0,0 @@ -~ Output -~ ~~~~~~ -~ -~ It is convenient to be able to output text. This depends on the -~ OS-specific stuff in linux.e, so it's in its own file. -~ -~ The most interesting word we define here is ".", pronounced "dot"; the -~ math stuff is needed to implement it. -~ -~ Unlike Jonesforth, we do not have a global "base" variable, and this word -~ does not change its behavior depending on that value. It's always base ten. - - -~ Strings are comparatively easy. -~ -~ (string pointer --) -: emitstring dup stringlen 1 3unroll sys-write drop ; - -: space 32 value@ emitstring drop ; -: newline 10 value@ emitstring drop ; - - -~ (base, exponent -- base to the power of exponent) -: pow - 1 swap - - { - ~ If the count of remaining powers is equal to zero, exit. - dup { drop swap drop exit } unless - ~ (base, result so far, count of remaining powers) - - 1 - 3unroll - ~ (updated count of remaining powers, base, result so far) - - swap dup 4 unroll - ~ (base, updated count of remaining powers, result so far, base) - - * swap - ~ (base, updated result so far, updated count of remaining powers) - } forever ; - - -~ (base, value -- floor of logarithm of value in base base) -: logfloor - ~ Start with a product equal to the base, and a count of 0. - swap dup 3unroll 0 - - { - ~ This is the start of the loop body. - ~ (base, value, product so far, count of powers included so far) - 3unroll 2dup - ~ (base, count so far, value, product so far) - - ~ If we get here, we're done. - ~ (base, count so far, value, product so far) - >unsigned { drop drop swap drop exit } if - - ~ If we're here, we need to do another loop. - ~ (base, count so far, value, product so far) - 4 roll dup 5 unroll * 3roll 1 + - ~ (base, value, updated product so far, updated count so far) - - ~ If the product is less than the base, we overflowed. In that case, the - ~ product-so-far is the maximum, so just return it. - 4 roll dup 5 unroll 3roll dup 4 unroll - < { 4 unroll drop drop drop exit } if - - ~ Nothing else weird going on, so loop. - } forever ; - - -~ (base, value -- ceiling of logarithm of value in base base) -: logceil - ~ Start with a product of 1 and a count of 0. - 1 0 - - { - ~ This is the start of the loop body. - ~ (base, value, product so far, count of powers included so far) - 3unroll 2dup - ~ (base, count so far, value, product so far) - - ~ If we get here, we're done. - ~ (base, count so far, value, product so far) - >=unsigned { drop drop swap drop exit } if - - ~ If we're here, we need to do another loop. - ~ (base, count so far, value, product so far) - 4 roll dup 5 unroll * 3roll 1 + - ~ (base, value, updated product so far, updated count so far) - - ~ If the product is less than the base, we overflowed. In that case, the - ~ product-so-far is the maximum, so just return it. - 4 roll dup 5 unroll 3roll dup 4 unroll - < { 4 unroll drop drop drop exit } if - - ~ Nothing else weird going on, so loop. - } forever ; - - -~ This is an extremely inefficient implementation, but on the plus side, -~ doing that avoids having to think about any sort of memory management or -~ recursion, and lets us stick entirely with the trivial control-flow -~ constructs we already have. -~ -~ (integer to print, base to print in, width to zero-pad to --) -: .base-unsigned - ~ (input, base, width) - ~ Compute how many digits we need to display. Because we use logfloor, the - ~ logic of always printing at least one digit is already handled for us. - 3unroll swap 2dup logfloor 1 + - ~ (width, base, input, number of digits if no padding) - 4 roll 2dup > { - ~ (base, input, number of digits if no padding, width) - ~ If we're here, we should use the padded width - swap drop - } { - ~ (base, input, number of digits if no padding, width) - ~ If we're here, we should use the unpadded width - drop - } if-else - - { - ~ (base, input, number of digits remaining) - ~ This is the start of the loop. - 2dup 1 - - ~ (base, input, number of digits remaining, input, intermediate value) - 5 roll dup 6 unroll swap - ~ (base, input, number of digits remaining, input, base, intermediate value) - pow /% swap drop - ~ (base, input, number of digits remaining, - ~ input divided by base^x appropriately) - 4 roll dup 5 unroll - ~ (base, input, number of digits remaining, - ~ input divided by base^x appropriately, base) - /% drop - ~ (base, input, number of digits remaining, current digit) - - ~ We construct a one-character string on the stack, then use a pointer to - ~ it. It will always contain its own null-termination without us having to - ~ do anything special to that end. - dup 10 > { - 0x30 ~ ASCII "0" - } { - 10 - 0x61 ~ ASCII "a" - } if-else - + - value@ emitstring - - ~ We deallocate the string by dropping it. - ~ - ~ Saying it like that makes it sound obvious; contemplate it until it feels - ~ surprising. - drop - - 1 - - dup { drop drop drop exit } unless - } forever ; - - -~ (integer to print, base to print in --) -: .base - swap - ~ (base, input) - - ~ Deal with negative numbers. - dup 0 > { - -1 * - s" -" emitstring - } if - - swap 0 .base-unsigned ; - - -~ Although this could notionally be called emitinteger for symmetry, it's -~ well-known under the name dot and as a single period character, and that -~ name participates in conventions for names of other things. So, we go with -~ it. -~ -~ (integer to print --) -: . 10 .base ; -: .hex 16 0 .base-unsigned ; -: .hex8 16 2 .base-unsigned ; -: .hex16 16 4 .base-unsigned ; -: .hex32 16 8 .base-unsigned ; -: .hex64 16 16 .base-unsigned ; - -~ (integer to print, width --) -: .hexn 16 swap .base-unsigned ; - - - -~ The control structure here is the same as .base-unsigned, but it outputs -~ to a string. -~ -~ The use of the "pack" nomenclature here is a little odd in that most other -~ uses are for binary structures rather than text, but compare packstring. -~ -~ (output point, integer to print, base to print in, width to zero-pad to -~ -- output point) -: pack-base-unsigned - 3unroll swap 2dup logfloor 1 + - 4 roll 2dup > { - swap drop - } { - drop - } if-else - - { - ~ (output point, base, input, number of digits remaining) - 2dup 1 - - 5 roll dup 6 unroll swap - pow /% swap drop - 4 roll dup 5 unroll - /% drop - - dup 10 > { - 0x30 ~ ASCII "0" - } { - 10 - 0x61 ~ ASCII "a" - } if-else - + - ~ (output point, base, input, number of digits remaining, character) - 5 roll swap pack8 4 unroll - - 1 - - dup { drop drop drop exit } unless - } forever ; - - -~ (output point, integer to print, base to print in -- output point) -: pack-base - swap - - dup 0 > { - -1 * - 3roll s" -" packstring 3unroll - } if - - swap 0 .base-unsigned ; - - -~ (output point, integer to print -- output point) -: pack-decimal 10 pack-base ; -: pack-hex 16 0 pack-base-unsigned ; -: pack-hex8 16 2 pack-base-unsigned ; -: pack-hex16 16 4 pack-base-unsigned ; -: pack-hex32 16 8 pack-base-unsigned ; -: pack-hex64 16 16 pack-base-unsigned ; - -~ (output point, integer to print, width -- output point) -: pack-hexn 16 swap pack-base-unsigned ; diff --git a/transform.e b/transform.e deleted file mode 100644 index 4c550e1..0000000 --- a/transform.e +++ /dev/null @@ -1,6500 +0,0 @@ -~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~ ~~ 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" &" 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 linux.e. - dup s" sys-exit" stringcmp 0 = { drop -1 exit } if - dup s" sys-write" stringcmp 0 = { drop -2 exit } if - dup s" sys-read" stringcmp 0 = { drop -2 exit } if - - ~ From 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" 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 runs instead of "interpret" in code under the hex transform. The -~ proximate effect of that is to make "include" work. Note, however, that this -~ replacement only applies directly under the hex transform. It isn't a -~ sensible approach under the log-load transform at all, and under the label -~ transform it would have such strange behavior that it isn't a good idea -~ either. -: hex-interpret-replacement - ~ This is a forward reference, so we need to look it up. - s" hex-transform-one" - swap-transform-variables find swap-transform-variables - entry-to-execution-token execute - - ~ We ignore the EOF indication, on the assumption something else will - ~ detect it and return to the outer loop, the one that's ours. For example, - ~ look at "include", in files.e. - drop ; - - -~ This installs hex-interpret-replacement, compiling it in compile mode and -~ executing it in immediate mode. -: hex-interpret-alternate - interpreter-flags @ 0x01 & { - ' hex-interpret-replacement entry-to-execution-token , - } { - hex-interpret-replacement - } if-else ; make-immediate - - -~ This implements the hex transform for a single word. It is directly -~ analogous to "interpret", and reading interpret.e may help in understanding -~ it, though it's meant to still make sense on its own. -~ -~ The hex transform runs code immediately. Whereas most transforms alter -~ what the transformed code compiles into, the hex transform alters what it -~ outputs. It's assumed that the output is a binary file of some sort; the -~ binary is output as hexadecimal, interspersed with comments describing the -~ code that produced it, including descriptions of what was executed, along -~ with any comments from the original code. -~ -~ The hex transform's alternates take priority over words defined under -~ the transform when running immediately, but for compilation, words defined -~ under the transform take precedence. In the event that neither an alternate -~ nor an entry in the inner dictionary is found, the outer dictionary is -~ checked; otherwise it's irrelevant. -~ -~ The point of this precedence rule is that string literals, which require -~ special treatment, will be using the inner implementation by the time it -~ gets to actually generating an executable image. It's important that there -~ not be any alternates altering the generated code, only the program actually -~ being compiled. Other literal syntaxes, such as tick, don't have alternates -~ at all (the hex transform manages to be more parsimonious with alternates -~ than other transforms), and will always be using inner versions. -~ -~ The precedence rule does fail to have the desired effect for label -~ references. For these, the alternates take the unusual step of manually -~ calling the inner versions when they exist. -~ TODO think through whether the precedence rule is actually doing anything... -~ -~ It expects to be called from "hex-transform", below, which loops. -~ -~ (-- done) -: hex-transform-one - hex-skip-space - word - - ~ If no word was returned, end the transformation. - dup 0 = { drop 1 exit } if - - ~ The string is on the top of the stack, so to get a pointer to it we get - ~ the stack address. - ~ (string) - value@ - - ~ If it's anything but tilde, set the input state flag accordingly. - dup s" ~" stringcmp 0 != { 1 has-non-space-this-input-line! } if - - ~ Check whether it's one of the words we have alternates for, and look up - ~ the alternate if so. - 0 swap - ~ (name as stack string, placeholder, name pointer) - dup s" self-codeword" stringcmp 0 = { - swap drop ' hex-self-codeword-alternate swap } if - ~ It is nontrivial to construct a string with a double-quote in it. - dup ' s" entry-to-name stringcmp 0 = { - swap drop ' hex-string-alternate swap } if - dup ' ." entry-to-name stringcmp 0 = { - swap drop ' hex-dot-string-alternate swap } if - dup s" create" stringcmp 0 = { swap drop ' hex-create-alternate swap } if - dup s" :" stringcmp 0 = { swap drop ' hex-colon-alternate swap } if - dup s" ;" stringcmp 0 = { swap drop ' hex-semicolon-alternate swap } if - dup s" ;asm" stringcmp 0 = { - swap drop ' hex-semicolon-assembly-alternate swap } if - dup s" L@'" stringcmp 0 = { swap drop ' hex-L@'-alternate swap } if - dup s" L!'" stringcmp 0 = { swap drop ' hex-L!'-alternate swap } if - dup s" bye" stringcmp 0 = { swap drop ' hex-bye-alternate swap } if - dup s" allocate" stringcmp 0 = { - swap drop ' hex-allocate-alternate swap } if - dup s" memcopy" stringcmp 0 = { swap drop ' hex-memcopy-alternate swap } if - dup s" memmove" stringcmp 0 = { swap drop ' hex-memmove-alternate swap } if - dup s" word" stringcmp 0 = { swap drop ' hex-word-alternate swap } if - dup s" ~" stringcmp 0 = { swap drop ' hex-tilde-alternate swap } if - dup s" interpret" stringcmp 0 = { - swap drop ' hex-interpret-alternate swap } if - ~ (name as stack string, 0 or alternate entry pointer, name pointer) - - find - ~ (stack string, 0 or alternate entry pointer, 0 or inner entry pointer) - - interpreter-flags @ 0x01 & { - ~ We're in compile mode. An alternate immediate entry has the highest - ~ precedence; an inner entry of any kind has second-highest. - over { - ~ An alternate entry exists; check its flags. - over entry-flags@ 0x01 & { - ~ It's an immediate entry, so it has precedence, regardless of - ~ what's up with the inner entry. Execute it. - drop dropstring-with-result - entry-to-execution-token execute - 0 exit - } { - ~ The alternate is not immediate, so check if there's an inner entry. - dup { - ~ There is also an inner entry. Check its flags. - dup entry-flags@ 0x01 & { - ~ The inner entry is immediate, so it has precedence. Execute it. - swap drop dropstring-with-result - entry-to-execution-token execute - 0 exit - } { - ~ The inner entry is not immediate, so the alternate has - ~ precedence. Compile it. - ~ - ~ Watch this space closely for correctness issues, it's a rare - ~ codepath. - drop dropstring-with-result - entry-to-execution-token , - 0 exit - } if-else - } { - ~ There's no inner entry. Compile the alternate. - ~ - ~ This path, too, is rare and should get close scrutiny for - ~ correctness. - drop dropstring-with-result - entry-to-execution-token , - 0 exit - } if-else - } if-else - } { - ~ There is no alternate entry; check for an inner entry. - dup { - ~ An inner entry exists; check its flags. - dup entry-flags@ 0x01 & { - ~ It's an immediate entry. Execute it. - swap drop dropstring-with-result - entry-to-execution-token execute - 0 exit - } { - ~ It's not an immediate entry. Compile it. - swap drop dropstring-with-result - entry-to-execution-token , - 0 exit - } if-else - } if - ~ If we got here, there's no inner or alternate entry; fall through. - } if-else - } { - ~ We're in immediate mode. An alternate entry of any kind has precedence. - over { - ~ There's an alternate entry. Execute it. - drop dropstring-with-result - entry-to-execution-token execute - 0 exit - } { - ~ There's no alternate entry. Check for an inner entry. - dup { - ~ An inner entry exists. Execute it. - swap drop dropstring-with-result - entry-to-execution-token execute - 0 exit - } if - ~ If we got here, there's no inner or alternate; fall through. - } if-else - } if-else - drop drop - ~ (stack string) - - ~ As a final fallback, we also check the outer dictionary, for immediate - ~ use only. This will allow things like assembly words to work. - value@ - swap-transform-variables - find - swap-transform-variables - dup { - ~ There's an outer entry; check the mode. - interpreter-flags @ 0x01 & { - ~ We're in compile mode; check the outer entry's flags. - dup entry-flags@ 0x01 & { - ~ It's an immediate word; execute it. - dropstring-with-result - entry-to-execution-token - execute - 0 exit - } { - ~ It's not an immediate word. Pretend it doesn't exist, and fall - ~ through. - drop - } if-else - } { - ~ We're in immediate mode. Execute the outer entry. - dropstring-with-result - entry-to-execution-token - execute - 0 exit - } if-else - } { - ~ There's no outer entry. Fall through. - drop - } if-else - ~ (stack string) - - ~ Check whether it's a number literal. - value@ read-integer 0 = { - ~ It's a number. - ~ - ~ (name as stack string, integer value) - dropstring-with-result - ~ (integer value) - - interpreter-flags @ 0x01 & { - ~ TODO this probably needs a lit alternate (!) - ' lit entry-to-execution-token , , - 0 exit - } if - - 0 exit - } if - ~ (stack string) - - ." No such word: " value@ emitstring newline dropstring 0 ; - - -~ This implements the hex transform for all words in a region given as -~ an input string. It is directly analogous to "quit", in 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 ; - -- cgit 1.4.1