diff options
| author | Irene Knapp <ireneista@irenes.space> | 2026-09-28 18:07:52 -0700 |
|---|---|---|
| committer | Irene Knapp <ireneista@irenes.space> | 2026-09-28 19:18:54 -0700 |
| commit | 77e8ce989010fbd94080e780fb0b5cb6c10434e8 (patch) | |
| tree | c1eac8abaa388d37fac957244ebe7b2c76435d78 /language/dynamic | |
| parent | 54b8077d3296ae994c2943d0d39e84a4d4047416 (diff) | |
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
Diffstat (limited to 'language/dynamic')
| -rw-r--r-- | language/dynamic/dynamic.e | 560 | ||||
| -rw-r--r-- | language/dynamic/files.e | 161 | ||||
| -rw-r--r-- | language/dynamic/flow-control.e | 151 | ||||
| -rw-r--r-- | language/dynamic/input.e | 289 | ||||
| -rw-r--r-- | language/dynamic/interpret.e | 599 | ||||
| -rw-r--r-- | language/dynamic/linux.e | 359 |
6 files changed, 2119 insertions, 0 deletions
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 + |