diff options
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 + |