diff options
Diffstat (limited to 'language')
| -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 | ||||
| -rw-r--r-- | language/static/amd64.e | 1383 | ||||
| -rw-r--r-- | language/static/core.e | 1371 | ||||
| -rw-r--r-- | language/static/execution-support.e | 111 | ||||
| -rw-r--r-- | language/static/linux.e | 153 | ||||
| -rw-r--r-- | language/static/log-load.e | 547 | ||||
| -rw-r--r-- | language/static/output.e | 252 |
12 files changed, 5936 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 + diff --git a/language/static/amd64.e b/language/static/amd64.e new file mode 100644 index 0000000..925abc0 --- /dev/null +++ b/language/static/amd64.e @@ -0,0 +1,1383 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Assembly language for the AMD64 architecture ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ This is also often called the x86-64 architecture, but Intel didn't +~ invent it (they had their chance) and there's no reason to name it after +~ their product line. We have a bunch of assembler words that, taken as a +~ whole, form a sort of assembly language inside of the Forth-style language. +~ +~ It's all backwards and stuff. +~ +~ Okay, but seriously, the convention is: target on the top of the stack, +~ source behind it. This is similar to how the Forth "!" and "@" words work. +~ +~ These routines use the binary packing routines such as pack64, defined in +~ language/static/core.e. They're called in the same way: an output address +~ which we call the "output point", followed by data items specific to what's +~ being output. They also chain together in the same way, returning the +~ updated output point. +~ +~ TODO cite the Intel reference manual here and explain the notation used +~ for the section citations below +~ +~ TODO define instructions, assembly code, machine code, opcodes. if we ever +~ also want to recommend a childrens' introduction to binary, this might be +~ the place to do it. +~ +~ +~ Hex-transformed output +~ ~~~~~~~~~~~~~~~~~~~~~~ +~ +~ In addition to the actual semantics of the assembly words, there's an +~ important layer of meaning atop them. The hex transform, described in detail +~ in compilation/transform.e, modifies a compilation process to produce a +~ commented hex dump instead of a binary. It includes a magic-comment feature +~ which allows words that have opinions on what their output's hex dump should +~ look like to express them. +~ +~ The code in this file makes extensive use of the magic-comment feature. +~ Any comment which starts with : as its first word is a magic comment meant +~ for the hex transform. When the hex transform is not in use, these are +~ ordinary comments and are ignored. When it is in use, they create and modify +~ metadata annotations in a complex way. +~ +~ The magic comments in this file follows two important conventions: First, +~ entries are created by whichever word directly corresponds to a top-level +~ assembly instruction from the perspective of someone programming with it, +~ at some point prior to calling any word which might pack output. Second, +~ output bytes are accounted for by whichever word directly calls a pack* word +~ for them. +~ +~ Thus, for example, the word "syscall" has a comment which creates an entry +~ describing its length as 2 bytes, which never varies. +~ +~ The word "mov-reg64-imm32", on the other hand, has a comment which +~ creates an entry describing is length as 5 bytes - the opcode and the +~ immediate value, which are output with calls to pack8 and pack32 in that +~ word. However, the actual length of the instruction is 5 bytes. When +~ mov-reg64-imm32 calls rex-w, a magic comment there modifies the most recent +~ entry in-place, marking it as being one byte longer. Subsequently, +~ mov-reg64-imm32 calls addressing-reg64, which calls modrm, which again +~ modifies the same entry. Notice that addressing-reg64 didn't need to do +~ anything, because it isn't directly responsible for any packing. +~ +~ Notice that when an entry is modified in place, it needs to have been +~ created first. Attempting to do it in the wrong order will have an +~ undesired effect, most likely editing the entry of an unrelated instruction. +~ The hex transform doesn't have detailed knowledge of assembly, and isn't in +~ a position to know that the edits that are happening are sensible. +~ +~ Hopefully these examples show why an accounting convention is needed. The +~ good news is that the convention is quite robust and needs essentially no +~ play-by-play commentary, just this explainer at the top. + + +~ Keywords +~ ~~~~~~~~ +~ +~ We define a bunch of keywords, which evaluate to their own codeword +~ addresses. We use these to refer to registers and condition codes by name. +~ +~ +~ On registers +~ ~~~~~~~~~~~~ +~ +~ The x86 architecture has been around a while, it has been through +~ several transitions from smaller word sizes to larger ones. Therefore it +~ has different names for the "same" registers, depending on how much of +~ them you're using. +~ +~ TODO there's more to write here + +~ The names of the 64-bit registers. The second half of these are considered +~ "extended" registers because they don't correspond to 32-bit registers in +~ the way the first eight do. +s" :rax" keyword +s" :rcx" keyword +s" :rdx" keyword +s" :rbx" keyword +s" :rsp" keyword +s" :rbp" keyword +s" :rsi" keyword +s" :rdi" keyword +s" :r8" keyword +s" :r9" keyword +s" :r10" keyword +s" :r11" keyword +s" :r12" keyword +s" :r13" keyword +s" :r14" keyword +s" :r15" keyword + +~ The names of the 32-bit registers. The processor treats these as being +~ alternate names for the low halves of the 64-bit registers. There is a +~ very finicky distinction about what that means in different settings: Some +~ instructions operate on a 32-bit source or target, while others merely +~ accept a 32-bit value that gets sign-extended to 64 bits. We've taken pains +~ to clarify these cases in the instruction-specific notes, as they come up. +s" :eax" keyword +s" :ecx" keyword +s" :edx" keyword +s" :ebx" keyword +s" :esp" keyword +s" :ebp" keyword +s" :esi" keyword +s" :edi" keyword + +~ The names of the 16-bit registers. Similarly, the processor treats these +~ as being alternate names for the low halves of the 32-bit registers. +s" :ax" keyword +s" :cx" keyword +s" :dx" keyword +s" :bx" keyword +s" :sp" keyword +s" :bp" keyword +s" :si" keyword +s" :di" keyword + +~ The names of the 8-bit registers. The pattern here is a little bit +~ different; these come in "low" and "high" pairs, where for example :al is +~ the low half of :ax and :ah is the high half. Yes, this architecture grows +~ like a tree, with all the old things being still present, surrounded in the +~ new ones. +s" :al" keyword +s" :cl" keyword +s" :dl" keyword +s" :bl" keyword +s" :ah" keyword +s" :ch" keyword +s" :dh" keyword +s" :bh" keyword + +~ The condition codes. Yes, there sure is a lot of duplication in these +~ names. The names are based on Intel's documented mnemonics... +~ +~ "Above" and "below" are for unsigned comparisons. "Greater" and "less" are +~ for signed comparisons. +~ +~ This is documented on the individual opcode pages, and also in B.1.4.7. +s" :cc-overflow" keyword +s" :cc-no-overflow" keyword +s" :cc-below" keyword +s" :cc-above-equal" keyword +s" :cc-equal" keyword +s" :cc-not-equal" keyword +s" :cc-below-equal" keyword +s" :cc-above" keyword +s" :cc-sign" keyword +s" :cc-not-sign" keyword +s" :cc-even" keyword +s" :cc-odd" keyword +s" :cc-less" keyword +s" :cc-greater-equal" keyword +s" :cc-less-equal" keyword +s" :cc-greater" keyword + + +~ Bits and pieces +~ ~~~~~~~~~~~~~~~ +~ +~ Here, we have a bunch of helpers which generate specific encoded +~ representations that are part of many instructions. We start with the +~ trivial ones that handle individual fields, then work up to combinations of +~ fields. +~ +~ When we say that a word accepts a register as a parameter, what we mean +~ is it accepts the name keyword for that register. When we say that a word +~ accepts a scale factor, what we mean is that it accepts a byte count for +~ that scale factor. In the cases where we mean the encoded form, we'll say +~ "encoded value" or "value". +~ +~ (register -- 3-bit encoded value for register) +: reg64 + ~ : provide-keyword + dup :rax = { drop 0 exit } if + dup :rcx = { drop 1 exit } if + dup :rdx = { drop 2 exit } if + dup :rbx = { drop 3 exit } if + dup :rsp = { drop 4 exit } if + dup :rbp = { drop 5 exit } if + dup :rsi = { drop 6 exit } if + dup :rdi = { drop 7 exit } if + ." Parameter to reg64 is not a reg64." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: extrareg64 + ~ : provide-keyword + dup :r8 = { drop 0 exit } if + dup :r9 = { drop 1 exit } if + dup :r10 = { drop 2 exit } if + dup :r11 = { drop 3 exit } if + dup :r12 = { drop 4 exit } if + dup :r13 = { drop 5 exit } if + dup :r14 = { drop 6 exit } if + dup :r15 = { drop 7 exit } if + ." Parameter to extrareg64 is not an extrareg64." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: reg32 + ~ : provide-keyword + dup :eax = { drop 0 exit } if + dup :ecx = { drop 1 exit } if + dup :edx = { drop 2 exit } if + dup :ebx = { drop 3 exit } if + dup :esp = { drop 4 exit } if + dup :ebp = { drop 5 exit } if + dup :esi = { drop 6 exit } if + dup :edi = { drop 7 exit } if + ." Parameter to reg32 is not a reg32." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: reg16 + ~ : provide-keyword + dup :ax = { drop 0 exit } if + dup :cx = { drop 1 exit } if + dup :dx = { drop 2 exit } if + dup :bx = { drop 3 exit } if + dup :sp = { drop 4 exit } if + dup :bp = { drop 5 exit } if + dup :si = { drop 6 exit } if + dup :di = { drop 7 exit } if + ." Parameter to reg16 is not a reg16." 1 sys-exit ; + +~ (register -- 3-bit encoded value for register) +: reg8 + ~ : provide-keyword + dup :al = { drop 0 exit } if + dup :cl = { drop 1 exit } if + dup :dl = { drop 2 exit } if + dup :bl = { drop 3 exit } if + dup :ah = { drop 4 exit } if + dup :ch = { drop 5 exit } if + dup :dh = { drop 6 exit } if + dup :bh = { drop 7 exit } if + ." Parameter to reg8 is not a reg8." 1 sys-exit ; + + +~ There's a packed format called the SIB byte, which we'll get to in a +~ second. One of its bitfields is called the scale field. This word produces +~ an encoded value for that field. +~ +~ The input value is a byte count; the output value is suitable for use in +~ the SIB byte. +~ +~ (scale factor -- 2-bit encoded value) +: scalefield + ~ : provide-decimal + dup 1 = { drop 0 exit } if + dup 2 = { drop 1 exit } if + dup 4 = { drop 2 exit } if + dup 8 = { drop 3 exit } if + ." Parameter to scalefield is not 1, 2, 4, or 8." 1 sys-exit ; + + +~ [Intel] volume 2D, appendix B, section B-1.4.7, table B-10. Also see the +~ individual opcode pages. +~ +~ Every instruction has an "opcode", a specific byte or sequence of bytes +~ which uniquely identifies the combination of operation, addressing mode, +~ and certain miscellaneous characteristics. This is not just another way of +~ referring to the entire sequence of bytes corresponding to the instruction; +~ the opcode is a specific part within that, as distinct from ie. the rex +~ byte, the SIB byte, the Mod/RM byte, and various immediate values and other +~ rare tidbits. +~ +~ Some of these opcodes have bitfields within them, to specify condition +~ codes. This word produces an encoded value for that condition-code field. +~ +~ (condition -- 4-bit encoded value) +: condition-code + ~ : provide-keyword + dup :cc-overflow = { drop 0 exit } if + dup :cc-no-overflow = { drop 1 exit } if + dup :cc-below = { drop 2 exit } if + dup :cc-above-equal = { drop 3 exit } if + dup :cc-equal = { drop 4 exit } if + dup :cc-not-equal = { drop 5 exit } if + dup :cc-below-equal = { drop 6 exit } if + dup :cc-above = { drop 7 exit } if + dup :cc-sign = { drop 8 exit } if + dup :cc-not-sign = { drop 9 exit } if + dup :cc-even = { drop 10 exit } if + dup :cc-odd = { drop 11 exit } if + dup :cc-less = { drop 12 exit } if + dup :cc-greater-equal = { drop 13 exit } if + dup :cc-less-equal = { drop 14 exit } if + dup :cc-greater = { drop 15 exit } if + ." Parameter to condition-code is not a condition code." 1 sys-exit ; + + +~ The "rex" byte appears before an opcode to modify its behavior in various +~ ways. It has four distinct bits within it, leading to sixteen variations, +~ as you can see. +~ +~ The way these are all spelled out like this is slightly ridiculous, there +~ must be a better way. We only ever use rex-w and rex-wb, so it's tempting to +~ get rid of the rest, but they're worth having so that our future selves +~ don't have to revisit this topic. +~ +~ (output point -- output point) +: rex-0 + ~ : 1 adjust-length + 0x40 pack8 ; +: rex-w + ~ : 1 adjust-length + 0x48 pack8 ; +: rex-r + ~ : 1 adjust-length + 0x44 pack8 ; +: rex-x + ~ : 1 adjust-length + 0x42 pack8 ; +: rex-b + ~ : 1 adjust-length + 0x41 pack8 ; +: rex-wr + ~ : 1 adjust-length + 0x4C pack8 ; +: rex-wx + ~ : 1 adjust-length + 0x4A pack8 ; +: rex-wb + ~ : 1 adjust-length + 0x49 pack8 ; +: rex-rx + ~ : 1 adjust-length + 0x46 pack8 ; +: rex-rb + ~ : 1 adjust-length + 0x45 pack8 ; +: rex-xb + ~ : 1 adjust-length + 0x43 pack8 ; +: rex-wrx + ~ : 1 adjust-length + 0x4E pack8 ; +: rex-wrb + ~ : 1 adjust-length + 0x4D pack8 ; +: rex-wxb + ~ : 1 adjust-length + 0x4B pack8 ; +: rex-rxb + ~ : 1 adjust-length + 0x47 pack8 ; +: rex-wrxb + ~ : 1 adjust-length + 0x4F pack8 ; + + +~ Some opcodes use their low three bits as a field to give a register name. +~ This is usually in addition to a register name given in a Mod/RM byte, +~ serving a different role for the instruction. +~ +~ This word accepts an opcode byte with those three bits clear, and combines +~ it with a register value, then outputs the resulting byte. Each opcode +~ accepts some specific kind of register; to allow different kinds, here we +~ expect the step of converting the register name to the encoded bits to have +~ already been done. +~ +~ (output point, 3-bit encoded value for register, opcode byte +~ -- output point) +: opcodereg + ~ : 1 adjust-length + | pack8 ; + + +~ Some opcodes use their low four bits as a field to give a condition code. +~ This word accepts an opcode byte with those four bits clear, and combines it +~ with a condition code value, then outputs the resulting byte. For +~ consistency with opcodereg, we expect the step of converting the condition +~ code name to the encoded bits to have already been done. +~ +~ (output point, 4-bit encoded value for condition code, opcode byte +~ -- output point) +: opcodecc + ~ : 1 adjust-length + | pack8 ; + + +~ A Mod/RM byte ("mode / register-or-memory") is part of the encoding of +~ many instructions. It's divided into three fields: "mod" (mode), +~ register/opcode, and register/memory ("RM"). +~ +~ This word outputs a Mod/RM byte given fully-processed, numeric values for +~ its fields. Most code will want to call one of the higher-level +~ addressing-* words, instead. +~ +~ (output point, mod field, register/opcode field, register/memory field +~ -- output point) +: modrm + ~ : 1 adjust-length + swap 8 * | swap 64 * | pack8 ; + +~ An SIB byte ("scale, index, base") is part of the encoding of many +~ instructions. It's divided into three fields, with the names you've already +~ guessed. +~ +~ This word outputs an SIB byte given fully-processed, numeric values for +~ its fields. +~ +~ (output point, scale field, index field, base field -- output point) +: sib + ~ : 1 adjust-length + swap 8 * | swap 64 * | pack8 ; + + +~ Addressing modes +~ ~~~~~~~~~~~~~~~~ +~ +~ These are higher-level words meant to be easier to use than the bits and +~ pieces above. Each corresponds to some specific addressing mode. When +~ applicable, they accept keywords rather than pre-encoded values. +~ +~ That's not all the time, because there are cases, such as the reg/op +~ field, where the meaning is up to the individual instruction. In those +~ cases, these words do accept fully-processed, numeric values. +~ +~ The general rule is that the responsibility of these addressing-mode words +~ is for the parts that are common to all instructions using that addressing +~ mode. + + +~ The simplest of the addressing modes: Direct register addressing. There +~ are no special cases to check. +~ +~ It's important to notice that the R/M field may describe either a source, +~ or a target, depending on what the instruction is. So, this helper doesn't +~ get to know that. It also doesn't get to know whether the value in the +~ reg/op field describes a register, or if instead it's an extension of the +~ opcode. The caller is responsible for figuring that all out. +~ +~ (output point, reg/op field value, reg/mem field register +~ -- output point) +: addressing-reg64 reg64 3 3unroll modrm ; +: addressing-reg8 reg8 3 3unroll modrm ; + + +~ This is a helper for assembly instructions that want to do a form of +~ addressing that requires a value of 1 in the modrm byte's mode field, and +~ do not want to do any indexing. That's the indirect mode, which takes a +~ 64-bit register, treats it as an address, and looks up the 64-bit value it +~ points to. +~ +~ The helper's main responsibility is to deal with the scenario that +~ requires an SIB byte, which happens when the R/M field has a value of 4, +~ which would otherwise refer to the register rsp. In that situation, it also +~ generates an SIB byte which indicates a scale of 1, no indexing, and rsp as +~ the base register. +~ +~ When the register is :rbp, the only modes available also have +~ displacement; we disallow that. For that case, use an instruction that +~ uses a disp8 mode, and set a displacement of 0. +~ +~ In understanding this, pay close attention to the Op/En column in the +~ opcode table. The "RM" variant means the ModRM byte's R/M field (the third +~ one) is the source, while its reg field (the middle one) is the target. This +~ is what we want, because the R/M field is the one that gets indirection +~ applied to it. Opcode 0x8B with an REX.W prefix is the all-64-bit RM +~ variant. [Intel] volume 2B, chapter 4, section 4-3, "MOV". +~ +~ For the indirection modes, don't be confused by the many similar tables. +~ 64-bit mode is encoded the same as 32-bit mode except for adding a REX.W +~ prefix, as per 2.2.1.1, so you want table 2-2 to understand the ModRM byte. +~ The presence or absence of an SIB byte is determined by where in that table +~ we fall, and we aren't using a mode that has one. [Intel] volume 2A, +~ chapter 2, section 2-1.5, table 2-2. +~ +~ (output point, reg/op field value, reg/mem field register +~ -- output point) +: addressing-indirect-reg64 + ~ Exit with an error if the R/M register is :rbp. + dup :rbp != { + ~ Check whether the R/M register is :rsp. Save the test result for later. + dup :rsp = 4 unroll + ~ (equality result, output point, reg/op value, reg/mem name) + reg64 0 3unroll modrm + ~ (equality result, output point) + ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. + swap { + 0 4 :rsp reg64 + ~ : drop-subitem + sib + } if + exit + } if + ." R/M parameter to addressing-indirect-reg64 is :rbp." 1 sys-exit ; + +~ (output point, reg/op field value, reg/mem field register, +~ displacement value -- output point) +: addressing-disp8-reg64 + ~ This mode can do :rbp fine, so no need to check for that. + ~ Check whether the R/M register is :rsp. Save the test result for later. + swap dup :rsp = 5 unroll swap + ~ Stash the displacement value out of the way, too. + 4 unroll + reg64 1 3unroll modrm + ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. + 3roll { + 0 4 :rsp reg64 + ~ : drop-subitem + sib + } if + + ~ The displacement byte. + ~ + ~ When addressing-disp8-reg64 references a source, as in + ~ lea-reg64-disp8-reg64, the first two parameters of the assembly word + ~ calling it are the source register and the source displacement value. When + ~ it references a target or destination, as in mov-disp8-reg64-reg64, the + ~ LAST two parameters are the target registera and target displacement + ~ value. + ~ + ~ In both cases, the register comes first and the displacement value + ~ comes second. When these are used in a comment template without any other + ~ rearranging going on, whichever is on the top of the stack will be popped + ~ off first. So, we swap them here, thus putting the register on the top. + swap + ~ : 1 adjust-length + ~ : provide-hex8 + ~ : swap-subitems + pack8 ; + +~ (output point, reg/op field value, reg/mem field register, +~ displacement value -- output point) +: addressing-disp32-reg64 + ~ This mode can do :rbp fine, so no need to check for that. + ~ Check whether the R/M register is :rsp. Save the test result for later. + swap dup :rsp = 5 unroll swap + ~ Stash the displacement value out of the way, too. + 4 unroll + reg64 2 3unroll modrm + ~ If the R/M register was rsp, we need an SIB byte; otherwise, skip it. + 3roll { + 0 4 :rsp reg64 + ~ : drop-subitem + sib + } if + + ~ The displacement value. This is subject to the same considerations as in + ~ addressing-disp8-reg64. + swap + ~ : 4 adjust-length + ~ : provide-hex32 + ~ : swap-subitems + pack32 ; + +~ (output point, reg/op field value, +~ scale factor, index register, base field register +~ -- output point) +: addressing-indexed-reg64 + ~ Exit with an error if the base register is :rbp. + dup :rbp != { + ~ Reg/mem value 4 means to use an SIB byte (at least, with this mode). + 5 roll 0 6 roll 4 modrm 4 unroll + reg64 3unroll reg64 3unroll scalefield 3unroll + ~ We want the scale factor to show after the registers, so we put it + ~ last on the stack. We also want the base register to show before the + ~ index register, so the base comes first. + ~ + ~ Importantly, we have to do this before the sib so it'll count as being + ~ inside the span the assembly word's description attaches to. + ~ + ~ : -3 roll-subitems + ~ : swap-subitems + sib + exit + } if + ." Base parameter to addressing-indexed-reg64 is :rbp." 1 sys-exit ; + +~ (output point, reg/op field value, +~ scale factor, index register, base field register, +~ displacement value -- output point) +: addressing-disp8-indexed-reg64 + ~ This mode can do :rbp fine, so no need to check for that. + ~ Reg/mem value 4 means to use an SIB byte (at least, with this mode). + 6 roll 1 7 roll 4 modrm 5 unroll + 5 unroll reg64 3unroll reg64 3unroll scalefield 3unroll sib + swap + ~ : 1 adjust-length + ~ : provide-hex8 + ~ + ~ We want the parameters to be shown in the order: + ~ + ~ base register, index register, index scale factor, displacement + ~ + ~ So, we put them on the stack in the opposite of that order. + ~ + ~ Importantly, we have to do this before the pack8 so it'll count as being + ~ inside the span the assembly word's description attaches to. + ~ + ~ : -4 roll-subitems + ~ : -3 roll-subitems + ~ : swap-subitems + pack8 + ; + + +~ Easy instructions +~ ~~~~~~~~~~~~~~~~~ +~ +~ It's not worth pretending there's a coherent category behind this +~ grouping. These are the ones that were easy to deal with. + +~ (output point -- output point) +: cld + ~ : 1 cld + 0xFC pack8 ; +: std + ~ : 1 std + 0xFD pack8 ; +: syscall + ~ : 2 syscall + 0x0F pack8 0x05 pack8 ; +: hlt + ~ : 1 hlt + 0xF4 pack8 ; + +~ (output point, source register -- output point) +: push-reg64 + ~ : 0 # push-reg64 + reg64 0x50 opcodereg ; +: push-extrareg64 + ~ : 0 # push-extrareg64 + swap rex-b swap extrareg64 0x50 opcodereg ; + ~ Note the use of the B rex bit here; this instruction puts the register + ~ number in the opcode field, so it uses Table 3-1. + +~ (output point, target register -- output point) +: pop-reg64 + ~ : 0 # pop-reg64 + reg64 0x58 opcodereg ; +: pop-extrareg64 + ~ : 0 # pop-extrareg64 + swap rex-b swap extrareg64 0x58 opcodereg ; + ~ Note the use of the B rex bit here; this instruction puts the register + ~ number in the opcode field, so it uses Table 3-1. + +~ (output point, immediate value -- output point) +: push-imm32-extended64 + ~ : 5 # push-imm32-extended64 + swap 0x68 pack8 swap + ~ : provide-hex + pack32 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: lea-reg64-disp8-reg64 + ~ : 1 # # # lea-reg64-disp8-reg64 + 4 roll rex-w 0x8D pack8 4 unroll + reg64 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: lea-reg64-disp32-reg64 + ~ : 1 # # # lea-reg64-disp32-reg64 + 4 roll rex-w 0x8D pack8 4 unroll + reg64 3unroll addressing-disp32-reg64 ; + +~ (output point, +~ source base register, source index register, source index scale factor, +~ target register -- output point) +: lea-reg64-indexed-reg64 + ~ : 1 # # # # lea-reg64-indexed-reg64 + 5 roll rex-w 0x8D pack8 5 unroll + reg64 4 unroll 3unroll swap addressing-indexed-reg64 ; + +~ (output point, +~ source base register, source index register, source index scale factor, +~ source displacement value, +~ target register -- output point) +: lea-reg64-disp8-indexed-reg64 + ~ : 1 # # # # # lea-reg64-disp8-indexed-reg64 + 6 roll rex-w 0x8D pack8 6 unroll + reg64 5 unroll 3 roll 4 roll 3 roll addressing-disp8-indexed-reg64 ; + + +~ Move instructions +~ ~~~~~~~~~~~~~~~~~ +~ +~ These are, like, MOST of what we care about, so they get their own +~ section. Although it's very much the case that almost every two-operand +~ instruction offers this many distinct modes, we don't care about most of +~ those and don't yet implement them. We do care about all the modes for move +~ instructions. +~ +~ Someday perhaps we'll have extra-high-level features which generate all +~ the distinct versions of each instruction in a concise way, but that is not +~ this day. + +~ (output point, immediate value, register -- output point) +: mov-reg64-imm32 + ~ : 5 # # mov-reg64-imm32 + 3roll + rex-w 0xC7 pack8 swap + 0 swap addressing-reg64 + swap + ~ : provide-hex + pack32 ; +: mov-reg64-imm64 + ~ : 8 # # mov-reg64-imm64 + 3roll rex-w swap reg64 0xB8 opcodereg swap + ~ : provide-hex + pack64 ; +: mov-extrareg64-imm64 + ~ : 8 # # mov-extrareg64-imm64 + ~ Note the use of the B rex bit here; this instruction puts the register + ~ number in the opcode field, so it uses Table 3-1. + 3roll rex-wb swap extrareg64 0xB8 opcodereg swap + ~ : provide-hex + pack64 ; + +~ (output point, source register, target register -- output point) +: mov-reg64-reg64 + ~ : 1 # # mov-reg64-reg64 + 3roll rex-w 0x89 pack8 3unroll + swap reg64 swap addressing-reg64 + ~ : swap-subitems + ; +: mov-indirect-reg64-reg64 + ~ : 1 # # mov-indirect-reg64-reg64 + 3roll rex-w 0x89 pack8 3unroll + swap reg64 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg64 + ~ : 1 # # # mov-disp8-reg64-reg64 + 4 roll rex-w 0x89 pack8 4 unroll + 3roll reg64 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg64-indirect-reg64 + ~ : 1 # # mov-reg64-indirect-reg64 + 3roll rex-w 0x8B pack8 3unroll + reg64 swap addressing-indirect-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: mov-reg64-disp8-reg64 + ~ : 1 # # # mov-reg64-disp8-reg64 + 4 roll rex-w 0x8B pack8 4 unroll + reg64 3unroll addressing-disp8-reg64 ; +: mov-reg64-disp32-reg64 + ~ : 1 # # # mov-reg64-disp32-reg64 + 4 roll rex-w 0x89 pack8 4 unroll + 3roll reg64 swap 3roll addressing-disp32-reg64 + ~ : swap-subitems + ~ : 3 roll-subitems + ; + +~ (output point, +~ source base register, source index register, source index scale factor, +~ target register -- output point) +: mov-reg64-indexed-reg64 + ~ : 1 # # # # mov-reg64-indexed-reg64 + 5 roll rex-w 0x8B pack8 5 unroll + reg64 4 unroll 3unroll swap addressing-indexed-reg64 ; + +~ (output point, source register, +~ target base register, target index register, target index scale factor +~ -- output point) +: mov-indexed-reg64-reg64 + ~ : 1 # # # # mov-indexed-reg64-reg64 + 5 roll rex-w 0x89 pack8 5 unroll + 4 roll reg64 4 unroll + 3unroll swap addressing-indexed-reg64 + ~ : 4 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-indirect-reg64-reg32 + ~ : 1 # # mov-indirect-reg64-reg32 + 3roll 0x89 pack8 3unroll + swap reg32 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg32 + ~ : 1 # # # mov-disp8-reg64-reg32 + 4 roll 0x89 pack8 4 unroll + 3roll reg32 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg32-indirect-reg64 + ~ : 1 # # mov-reg32-indirect-reg64 + 3roll 0x8B pack8 3unroll + reg32 swap addressing-indirect-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: mov-reg32-disp8-reg64 + ~ : 1 # # # mov-reg32-disp8-reg64 + 4 roll 0x8B pack8 4 unroll + reg32 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, target register -- output point) +: mov-indirect-reg64-reg16 + ~ : 2 # # mov-indirect-reg64-reg16 + 3roll 0x66 pack8 0x89 pack8 3unroll + swap reg16 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg16 + ~ : 2 # # # mov-disp8-reg64-reg16 + 4 roll 0x66 pack8 0x89 pack8 4 unroll + 3roll reg16 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg16-indirect-reg64 + ~ : 2 # # mov-reg16-indirect-reg64 + 3roll 0x66 pack8 0x8B pack8 3unroll + reg16 swap addressing-indirect-reg64 ; + +~ (output point, source register, target displacement value, target register +~ -- output point) +: mov-reg16-disp8-reg64 + ~ : 2 # # # mov-reg16-disp8-reg64 + 4 roll 0x66 pack8 0x8B pack8 4 unroll + reg16 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, target register -- output point) +: mov-indirect-reg64-reg8 + ~ : 1 # # mov-indirect-reg64-reg8 + 3roll 0x88 pack8 3unroll + swap reg8 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register, target displacement value +~ -- output point) +: mov-disp8-reg64-reg8 + ~ : 1 # # # mov-disp8-reg64-reg8 + 4 roll 0x88 pack8 4 unroll + 3roll reg8 3unroll addressing-disp8-reg64 + ~ : 3 roll-subitems + ; + +~ (output point, source register, target register -- output point) +: mov-reg8-indirect-reg64 + ~ : 1 # # mov-reg8-indirect-reg64 + 3roll 0x8A pack8 3unroll + reg8 swap addressing-indirect-reg64 ; + +~ (output point, source register, source displacement value, target register +~ -- output point) +: mov-reg8-disp8-reg64 + ~ : 2 # # # mov-reg8-disp8-reg64 + 4 roll 0x8A pack8 4 unroll + reg8 3unroll addressing-disp8-reg64 ; + +~ (output point, source register, target register -- output point) +: mov-reg8-reg8 + ~ : 1 # # mov-reg8-reg8 + 3roll 0x88 pack8 3unroll + swap reg8 swap addressing-reg8 + ~ : swap-subitems + ; + + +~ String instructions +~ ~~~~~~~~~~~~~~~~~~~ +~ +~ These are in their own section because there's an awful lot of +~ combinations, and fortunately they are very uniform in structure. +~ +~ What makes these useful is that they take their parameters from certain +~ fixed registers, which are chosen such that the operations chain into each +~ other well. Thus you can use them to build various block-memory and string +~ operations, and even if you need unusual forms of loop unrolling or +~ alignment tweaking, the code will end up uniform in structure. On modern +~ processors, this is even the high-performance approach, due to highly +~ optimized microcode, though these operations were inefficient when they +~ were first invented. +~ +~ We break with the Intel mnemonics, which follow the pattern +~ movsb/movsw/movsd/movsq, because this would otherwise be the only place we +~ use the b/w/d/q thing instead of 8/16/32/64. Tradition and pronounceability +~ are both nice things, but approachability to newcomers is important, too. +~ +~ Some of these are repeatable; whether you view the repeatable variants +~ as different instructions is up to you. At any rate the machine code +~ representation of the repeatable variants is the same as for the regular +~ variants with an extra prefix, so we define them together. +~ +~ This is a proper superset of the flatassembler implementations of string +~ instructions. The wisdom of that is questionable, but at least it's noted +~ here... + +~ (output point -- output point) +: movs8 + ~ : 1 movs8 + 0xA4 pack8 ; +: movs16 + ~ : 2 movs16 + 0x66 pack8 0xA5 pack8 ; +: movs32 + ~ : 1 movs32 + 0xA5 pack8 ; +: movs64 + ~ : 1 movs64 + rex-w 0xA5 pack8 ; +: rep-movs8 + ~ : 2 rep-movs8 + 0xF3 pack8 0xA4 pack8 ; +: rep-movs16 + ~ : 3 rep-movs16 + 0xF3 pack8 0x66 pack8 0xA5 pack8 ; +: rep-movs32 + ~ : 2 rep-movs32 + 0xF3 pack8 0xA5 pack8 ; +: rep-movs64 + ~ : 2 rep-movs64 + 0xF3 pack8 rex-w 0xA5 pack8 ; + +~ (output point -- output point) +: lods8 + ~ : 1 lods8 + 0xAC pack8 ; +: lods16 + ~ : 2 lods16 + 0x66 pack8 0xAd pack8 ; +: lods32 + ~ : 1 lods32 + 0xAD pack8 ; +: lods64 + ~ : 1 lods64 + rex-w 0xAD pack8 ; +: rep-lods8 + ~ : 2 rep-lods8 + 0xF3 pack8 0xAC pack8 ; +: rep-lods16 + ~ : 3 rep-lods16 + 0xF3 pack8 0x66 pack8 0xAD pack8 ; +: rep-lods32 + ~ : 2 rep-lods32 + 0xF3 pack8 0xAD pack8 ; +: rep-lods64 + ~ : 2 rep-lods64 + 0xF3 pack8 rex-w 0xAD pack8 ; + +~ (output point -- output point) +: stos8 + ~ : 1 stos8 + 0xAA pack8 ; +: stos16 + ~ : 2 stos16 + 0x66 pack8 0xAB pack8 ; +: stos32 + ~ : 1 stos32 + 0xAB pack8 ; +: stos64 + ~ : 1 stos64 + rex-w 0xAB pack8 ; +: rep-stos8 + ~ : 2 rep-stos8 + 0xF3 pack8 0xAA pack8 ; +: rep-stos16 + ~ : 3 rep-stos16 + 0xF3 pack8 0x66 pack8 0xAB pack8 ; +: rep-stos32 + ~ : 2 rep-stos32 + 0xF3 pack8 0xAB pack8 ; +: rep-stos64 + ~ : 2 rep-stos64 + 0xF3 pack8 rex-w 0xAB pack8 ; + +~ (output point -- output point) +: cmps8 + ~ : 1 cmps8 + 0xA6 pack8 ; +: cmps16 + ~ : 2 cmps16 + 0x66 pack8 0xA7 pack8 ; +: cmps32 + ~ : 1 cmps32 + 0xA7 pack8 ; +: cmps64 + ~ : 1 cmps64 + rex-w 0xA7 pack8 ; +: repz-cmps8 + ~ : 2 repz-cmps8 + 0xF3 pack8 0xA6 pack8 ; +: repz-cmps16 + ~ : 3 repz-cmps16 + 0xF3 pack8 0x66 pack8 0xA7 pack8 ; +: repz-cmps32 + ~ : 2 repz-cmps32 + 0xF3 pack8 0xA7 pack8 ; +: repz-cmps64 + ~ : 2 repz-cmps64 + 0xF3 pack8 rex-w 0xA7 pack8 ; +: repnz-cmps8 + ~ : 2 repnz-cmps8 + 0xF2 pack8 0xA6 pack8 ; +: repnz-cmps16 + ~ : 3 repnz-cmps16 + 0xF2 pack8 0x66 pack8 0xA7 pack8 ; +: repnz-cmps32 + ~ : 2 repnz-cmps32 + 0xF2 pack8 0xA7 pack8 ; +: repnz-cmps64 + ~ : 2 repnz-cmps64 + 0xF2 pack8 rex-w 0xA7 pack8 ; + +~ (output point -- output point) +: scas8 + ~ : 1 scas8 + 0xA8 pack8 ; +: scas16 + ~ : 2 scas16 + 0x66 pack8 0xAF pack8 ; +: scas32 + ~ : 1 scas32 + 0xAF pack8 ; +: scas64 + ~ : 1 scas64 + rex-w 0xAF pack8 ; +: repz-scas8 + ~ : 2 repz-scas8 + 0xF3 pack8 0xAE pack8 ; +: repz-scas16 + ~ : 3 repz-scas16 + 0xF3 pack8 0x66 pack8 0xAF pack8 ; +: repz-scas32 + ~ : 2 repz-scas32 + 0xF3 pack8 0xAF pack8 ; +: repz-scas64 + ~ : 2 repz-scas64 + 0xF3 pack8 rex-w 0xAF pack8 ; +: repnz-scas8 + ~ : 2 repnz-scas8 + 0xF2 pack8 0xAE pack8 ; +: repnz-scas16 + ~ : 3 repnz-scas16 + 0xF2 pack8 0x66 pack8 0xAF pack8 ; +: repnz-scas32 + ~ : 2 repnz-scas32 + 0xF2 pack8 0xAF pack8 ; +: repnz-scas64 + ~ : 2 repnz-scas64 + 0xF2 pack8 rex-w 0xAF pack8 ; + + +~ Arithmetic instructions +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Operations between two registers always have the target register as the +~ last parameter. Operations between a register and an immediate ALSO have the +~ target register as the last parameter, which is obvious for add-reg64-imm8 +~ but can be confusing for sub-reg64-imm8 or cmp-reg64-imm8. Also note what +~ this means for sub-reg64-reg64 and cmp-reg64-reg64. +~ +~ Every possible convention here leads to counterintuitive behavior in some +~ cases. This one has proven to be more memorable than the other obvious +~ choices, and that'll have to be enough. + +~ (output point, source register, target register -- output point) +: add-reg64-reg64 + ~ : 1 # # add-reg64-reg64 + 3roll rex-w 0x01 pack8 3unroll + swap reg64 swap addressing-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register -- output point) +: add-indirect-reg64-reg64 + ~ : 1 # # add-indirect-reg64-reg64 + 3roll rex-w 0x01 pack8 3unroll + swap reg64 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ (output point, source register, target register -- output point) +: add-reg64-indirect-reg64 + ~ : 1 # # add-reg64-indirect-reg64 + 3roll rex-w 0x03 pack8 3unroll + reg64 swap addressing-indirect-reg64 ; + +~ (output point, immediate value, target register -- output point) +: add-reg64-imm8 + ~ : 2 # # add-reg64-imm8 + 3roll rex-w 0x83 pack8 swap 0 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ See above re: parameter order. +~ +~ (output point, source register, target register -- output point) +: sub-reg64-reg64 + ~ : 1 # # sub-reg64-reg64 + 3roll rex-w 0x2B pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, source register, target register -- output point) +: sub-indirect-reg64-reg64 + ~ : 1 # # sub-indirect-reg64-reg64 + 3roll rex-w 0x2B pack8 3unroll + swap reg64 swap addressing-indirect-reg64 + ~ : swap-subitems + ; + +~ See above re: parameter order. +~ +~ (output point, immediate value, target register -- output point) +: sub-reg64-imm8 + ~ : 2 # # sub-reg64-imm8 + 3roll rex-w 0x83 pack8 swap 5 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ See above re: parameter order. +~ +~ (output point, source register, target register -- output point) +: sbb-reg64-imm8 + ~ : 2 # # sbb-reg64-imm8 + 3roll rex-w 0x83 pack8 swap 3 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ The target register is always rax. +~ +~ (output point, source register -- output point) +: mul-reg64 + ~ : 1 # mul-reg64 + swap rex-w 0xF7 pack8 swap + 4 swap addressing-reg64 ; + +~ The dividend is 128 bits, and is formed from rdx as the high half and rax +~ as the low half. The divisor is a specified register. The quotient is +~ returned in rax, truncated towards zero. The remainder is in rdx. This +~ entire process is unsigned. +~ +~ The official mnemonic for this is "div", but divmod is what it does. +~ +~ (output point, divisor register -- output point) +: divmod-reg64 + ~ : 1 # divmod-reg64 + swap rex-w 0xF7 pack8 swap + 6 swap addressing-reg64 ; + +~ Same as divmod, but signed. +~ +~ (output point, divisor register -- output point) +: idivmod-reg64 + ~ : 1 # idivmod-reg64 + swap rex-w 0xF7 pack8 swap + 7 swap addressing-reg64 ; + +~ (output point, target register -- output point) +: inc-reg64 + ~ : 1 # inc-reg64 + swap rex-w 0xFF pack8 swap 0 swap addressing-reg64 ; + +~ (output point, target register -- output point) +: dec-reg64 + ~ : 1 # dec-reg64 + swap rex-w 0xFF pack8 swap 1 swap addressing-reg64 ; + +~ (output point, source register, target register -- output point) +: and-reg64-reg64 + ~ : 1 # # and-reg64-reg64 + 3roll rex-w 0x23 pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, source value, target register -- output point) +: and-reg64-imm8 + ~ : 2 # # and-reg64-imm8 + 3roll rex-w 0x83 pack8 swap + 4 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, source register, target register -- output point) +: or-reg64-reg64 + ~ : 1 # # or-reg64-reg64 + 3roll rex-w 0x0B pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, source value, target register -- output point) +: or-reg64-imm8 + ~ : 2 # # or-reg64-imm8 + 3roll rex-w 0x83 pack8 swap + 1 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, source register, target register -- output point) +: xor-reg64-reg64 + ~ : 1 # # xor-reg64-reg64 + 3roll rex-w 0x33 pack8 3unroll + reg64 swap addressing-reg64 ; + +~ (output point, target register -- output point) +: not-reg64 + ~ : 1 # not-reg64 + swap rex-w 0xF7 pack8 + swap 2 swap addressing-reg64 ; + +~ (output point, bit count, target register -- output point) +: rol-reg64-imm8 + ~ : 2 # # rol-reg64-imm8 + 3roll rex-w 0xC1 pack8 swap + 0 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, bit count, target register -- output point) +: rol-reg8-imm8 + ~ : 2 # # rol-reg8-imm8 + 3roll 0xC0 pack8 swap + 0 swap addressing-reg8 + swap + ~ : provide-hex + pack8 ; + +~ (output point, bit count, target register -- output point) +: ror-reg64-imm8 + ~ : 1 # # ror-reg64-imm8 + 3roll rex-w 0xC1 pack8 swap + 1 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + +~ (output point, bit count, target register -- output point) +: ror-reg8-imm8 + ~ : 2 # # ror-reg8-imm8 + 3roll 0xC0 pack8 swap + 1 swap addressing-reg64 + swap + ~ : provide-hex + pack8 ; + + +~ Control flow instructions +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The comparator instructions cmp and test follow the same argument-order +~ conventions as the arithmetic instructions: The target register always comes +~ last. See the arithmetic section for more discussion. + +~ Pretend to subtract right from left, and set the flags the same way as if +~ we actually had. +~ +~ (output point, left register, right register -- output point) +: cmp-reg64-reg64 + ~ : 1 # # cmp-reg64-reg64 + 3roll rex-w 0x3B pack8 3unroll + reg64 swap addressing-reg64 ; + +~ See above re: parameter order. +~ +~ (output point, immediate value, target register -- output point) +: cmp-reg64-imm8 + ~ : 2 # # cmp-reg64-imm8 + 3roll rex-w 0x83 pack8 + ~ (immediate value, register, output point) + swap 7 swap addressing-reg64 + ~ ( output point, immediate value) + swap + ~ : provide-hex + pack8 ; + +~ Pretend to bitwise-and left with right, and set the flags the same way as +~ if we actually had. +~ +~ The names of the condition codes can be a little confusing when using them +~ after "test", because they're really premised on the idea that you did +~ "cmp". +~ +~ (output point, left register, right register -- output point) +: test-reg64-reg64 + ~ : 1 # # test-reg64-reg64 + 3roll rex-w 0x85 pack8 3unroll + swap reg64 swap addressing-reg64 + ~ : swap-subitems + ; + +~ (output point, condition code, target register -- output point) +: set-reg8-cc + ~ : 1 # # set-reg8-cc + 3roll 0x0F pack8 + 3roll condition-code 0x90 opcodecc + swap reg8 3 0 3roll modrm + ~ : swap-subitems + ; + +~ (output point, address offset value, condition code -- output point) +: jmp-cc-rel-imm8 + ~ : 1 # # jmp-cc-rel-imm8 + 3roll swap condition-code 0x70 opcodecc + swap + ~ : provide-hex + pack8 ; + +~ (output point, address offset value, condition code -- output point) +: jmp-cc-rel-imm32 + ~ : 5 # # jmp-cc-rel-imm32 + 3roll 0x0F pack8 + swap condition-code 0x70 opcodecc + swap + ~ : provide-hex + pack32 ; + +~ (output point, register -- output point) +: jmp-abs-indirect-reg64 + ~ : 1 # jmp-abs-indirect-reg64 + swap 0xFF pack8 swap + 4 swap addressing-indirect-reg64 ; + +~ (output point, address offset value -- output point) +: jmp-rel-imm8 + ~ : 2 # jmp-rel-imm8 + swap 0xEB pack8 + swap + ~ : provide-hex + pack8 ; + +~ (output point, address offset value -- output point) +: jmp-rel-imm32 + ~ : 5 # jmp-rel-imm32 + swap 0xE9 pack8 + swap + ~ : provide-hex + pack32 ; + +~ This is technically a "near" call. The name intentionally doesn't say so. +~ +~ (output point, address offset value -- output point) +: call-rel-imm32 + ~ : 5 # call-rel-imm32 + swap 0xE8 pack8 + swap + ~ : provide-hex + pack32 ; + +~ Similarly, this is a "near" return. +~ +~ (output point) +: ret + ~ : 1 ret + 0xC3 pack8 ; + diff --git a/language/static/core.e b/language/static/core.e new file mode 100644 index 0000000..10d5d61 --- /dev/null +++ b/language/static/core.e @@ -0,0 +1,1371 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Core Forth features ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ This file provides extremely fundamental functionality which is a +~ necessary component of any Forth dialect, including Evocation. It is +~ included statically as part of any generated executable, and a second copy +~ of it is later copied into the log when that executable runs. Therefore, it +~ is written to obey the constraints of both the label transform, and the +~ log-load transform; see compilation/transform.e for more details on that. + + +~ Execution support +~ ~~~~~~~~~~~~~~~~~ +~ +~ There's two words, docol and exit, which are essential parts of the +~ indirect-threaded execution model. It would be tempting to put them in +~ compilation/execution.e, so they'd be closer to the explanation of what they +~ do, but we need two copies of them (just like we do of every other word in +~ this file), one statically compiled and one in the log. So, they're here, +~ because that's significantly simpler, even though it creates a little bit of +~ extra work for the label transform. + + +~ Docol is the "interpreter" that is responsible for the semantics of words +~ written as Forth high-level code. The name is said to be short for +~ "do colon", because word definitions begin with a colon. +~ +~ Concretely, when interpreting, it saves rsi (the "instruction pointer") to +~ the control stack, takes the address of the codeword from rax and increments +~ it in-place to form the new instruction pointer, and copies that to rsi. +~ +~ Having then done this, we're now in the state that normal execution +~ expects, so docol ends by it using "next" to begin the callee's execution, +~ kicking off a nested call. +~ +~ At runtime, invoke docol directly and it will return the value that should +~ be used as a codeword. When compiling to a binary executable, the +~ transformation facility needs to reference it directly, and for that +~ purpose, the label "docol-codeword-value" points to the correct place. +~ +~ Registers in: +~ +~ * rsi is the caller's instruction pointer +~ * rbp is the control stack pointer +~ * rax is the address of the callee's codeword +~ +~ Registers out: +~ +~ * rsi is the callee's instruction pointer +~ * rbp is the control stack pointer + +~ We need this one snippet of assembly code that's just on the log raw, +~ without a word header, because of its role in making words work. We define +~ a label pointing to it. +~ +~ This is the only use of labels in core.e. There's no easy way to +~ remove it. We can't use immediate computation based on "here" because +~ the label transform uses the host address space, not the target address +~ space. The transformation facility's support for labels in transformed +~ code was added just for this. +~ +~ It may seem as if we could have used some extra space in the middle of +~ the proper docol word, which is defined just below. That would work fine +~ with the label transform, which can do forward references, but the log-load +~ transform's label support is special-cased to ONLY do this, and it will only +~ work with a backward reference. +~ +~ We begin by outputting the actual docol routine, the one that codewords +~ should point to. Note that this is before we've done any word header. +~ +~ : This is the actual docol routine, the interpreter which is pointed to by +~ : the codeword of every interpreted word. It does not itself have an entry +~ : in the dictionary; the word "docol" will return a pointer to this routine. +~ : The word's entry follows immediately after the routine. +~ : indent +here @ +dup L!' docol-codeword-value +:rsi pack-pushcontrol +8 :rax add-reg64-imm8 +:rax :rsi mov-reg64-reg64 +pack-next +8 packalign +here ! +~ : deindent + +~ We can't use colon to create docol, not even the part that's a word, +~ because colon tries to dynamically invoke docol to fill in the codeword. +~ : blank-line +~ : This is the dictionary entry for docol. +~ : indent +s" docol" create +self-codeword +here @ +L@' docol-codeword-value :rax mov-reg64-imm64 +:rax push-reg64 +pack-next +8 packalign +here ! +~ : deindent +~ Now that we have docol, colon will work and we can define words the normal +~ way. + +~ This is the mechanism to "return" from a word interpreted by docol. +~ We pop the control stack, and then, since this is threaded execution, we +~ do the next thing the caller wants to do, by inlining "next". +: exit + [ here @ + :rsi pack-popcontrol + here ! ] ;asm + +~ Now that we have exit, semicolon will also work and we can define +~ non-assembly words. However, it will be hard to make them do much until we +~ have lit as well. There's no special hurry; most of the words in core.e are +~ assembly words. We'll get to it further down. + + +~ Stack manipulation routines +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ We start with the three traditional stack operations, swap drop and +~ roll. Sorry to fans of the name "ROT"; we were an HP calculator kid. It'll +~ always be roll to us. Anyway, we do a couple other operations too. Since +~ our goal right now is just to bootstrap the heap, we keep this short and +~ sweet. +~ +~ This code has been written to satisfy the assumptions needed by the label +~ transform, described in-depth in compilation/transform.e. This means that it +~ is, in effect, written in a restricted dialect of Evocation rather than in +~ the full language. +~ +~ There is definitely plenty of optimization that could be done. + +: swap + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rax push-reg64 + :rbx push-reg64 + here ! ] ;asm + +: drop + [ here @ + :rax pop-reg64 + here ! ] ;asm + +: 2drop + [ here @ + :rax pop-reg64 + :rax pop-reg64 + here ! ] ;asm + +~ Rotates "up" (pops its parameter, n; nth item then becomes current item). +~ +~ We implement this the high-performance way, with rep movsq, aka the +~ instruction that exists to optimize C's memcpy(). The details of setting +~ that up are complex; see below. +: roll + [ here @ + + ~ Pop our parameter. The rep instruction takes rcx as its count, so we + ~ reduce copying by using it to hold our count, as well. + :rcx pop-reg64 + + ~ We have n - 1 items to slide, so decrement rcx. For the purpose of + ~ counting how many repetitions will happen, it's one-based. This is because + ~ the rep instruction performs a single movsq, then decrements rcx, then + ~ stops if rcx is zero. + :rcx dec-reg64 + + ~ Retrieve the nth item, for later. For this purpose we're thinking in + ~ zero-based terms, so we do this after already having decremented rcx. + :rsp :rcx 8 :rbx mov-reg64-indexed-reg64 + + ~ The source address for movsq is rsi and the destination is rdi; we can + ~ use rdi as we wish, but rsi is our Forth "instruction pointer", so we must + ~ save and restore it. Doing so alters rsp, so we have to adjust the address + ~ calculations by eight bytes as compared to the expressions above, but + ~ happily we can use the disp8 field to do that. We'd be using disp8 anyway + ~ because it's helpful. + :rsi push-reg64 + + ~ Now we set up parameters for the memory-sliding operation. We have + ~ n - 1 items to copy, moving the range rsp through rsp + (n-2)*8 onto the + ~ range rsp + 8 through rsp + (n-1)*8. That's with the value of rsp as it + ~ exists at this moment (it's going to change soon). + ~ + ~ We're sliding them upwards in memory, so we start at the high end so + ~ that we're always moving into a location that doesn't have anything + ~ precious. We use lea as a convenient way to do the stack math. + ~ + ~ When rcx is 1, we want rsp + 8. + :rsp :rcx 8 :rsi lea-reg64-indexed-reg64 + ~ When rcx is 1, we want rsp + 16. + :rsp :rcx 8 8 :rdi lea-reg64-disp8-indexed-reg64 + ~ + ~ Using rcx = 1 is the most convenient example to use for figuring out the + ~ arithmetic. It's a linear relationship, so as long as we get the 8-byte + ~ stride correct, we just need to pick a single point and verify that our + ~ math is right for that point, and it'll be right for any value of rcx. + + ~ Another of our Forth conventions is that the DF flag should be kept at + ~ zero, which directs string instruction to increment rsi. Here, however, + ~ because our source and destination ranges overlap, we need to start at the + ~ high end, which means we need it to decrement. So we set DF to one, and + ~ we'll clear it after. + std + rep-movs64 + + ~ Set everything back. + cld + :rsi pop-reg64 + + ~ There is now an extra item at the low end of the stack (the top) that + ~ needs to go away, and coincidentally we have a value in rbx that needs to + ~ be in that spot. Rather than doing a drop and push, we overwrite it, to + ~ save a little work. + :rbx :rsp mov-indirect-reg64-reg64 + + ~ All done, wow! What a mouthful. + here ! ] ;asm + +~ Rotates "down" (pops its parameter, n; current item then becomes nth +~ item). +~ +~ Jonesforth calls this "-roll" and we could do that, but honestly the name +~ unroll sounds nicer and it's only a single character longer. You might say +~ it rolls off the tongue better. +~ +~ We implement this the high-performance way, with rep movsq, aka the +~ instruction that exists to optimize C's memcpy(). The details of setting +~ that up are complex; see below. +: unroll + [ here @ + + ~ Pop our parameter. The rep instruction takes rcx as its count, so we + ~ reduce copying by using it to hold our count, as well. + :rcx pop-reg64 + + ~ We have n - 1 items to slide, so decrement rcx. Also, save a copy of it in + ~ rdx after doing that, for later. + :rcx dec-reg64 + :rcx :rdx mov-reg64-reg64 + + ~ Retrieve the 0th item, for later. + :rsp :rbx mov-reg64-indirect-reg64 + + ~ Now we set up parameters for the memory-sliding operation. We have + ~ n - 1 items to copy, moving the range rsp + 8 through rsp + (n-1)*8 onto + ~ the range rsp through rsp + (n-2)*8. That's with the value of rsp as it + ~ exists at this moment (it's going to change soon). + ~ + ~ We're sliding them downwards in memory, so we start at the low end so + ~ that we're always moving into a location that doesn't have anything + ~ precious. We use lea as a convenient way to do the stack math. + ~ + ~ As with roll, we need to save rsi and adjust those rsp calculations + ~ accordingly. + :rsi push-reg64 + + ~ Regardless of rcx, we want rsp + 16. + :rsp 16 :rsi lea-reg64-disp8-reg64 + ~ Regardless of rcx, we want rsp + 8. + :rsp 8 :rdi lea-reg64-disp8-reg64 + + ~ With roll, we were starting at the high end. Here, we start at the low + ~ end, which means we need rsi to increment after each repetition. That's + ~ what it does when the DF flag is clear, and another of our Forth + ~ conventions is to keep it clear normally. So, we don't have to touch DF! + ~ Yay! + rep-movs64 + + ~ Restore our original rsi. + :rsi pop-reg64 + + ~ There is now an extra item in the middle of the stack, at the high end of + ~ the sliding we did, that needs to be overwritten with our value in rbx. + ~ Since we destructively updated our count in rcx, we saved a copy of the + ~ count in rdx, and we use that to find the right address. + ~ + ~ When the original count was n, we want rsp + (n-1)*8, so we saved rdx + ~ after decrementing rcx, above. + :rbx :rsp :rdx 8 mov-indexed-reg64-reg64 + + ~ All done, wow! What a mouthful. + here ! ] ;asm + +~ Rotates "up" (third item becomes current item) +: 3roll + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rcx pop-reg64 + :rbx push-reg64 + :rax push-reg64 + :rcx push-reg64 + here ! ] ;asm + +~ Rotates "down" (current item becomes third item) +: 3unroll + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rcx pop-reg64 + :rax push-reg64 + :rcx push-reg64 + :rbx push-reg64 + here ! ] ;asm + +: dup + [ here @ + :rax pop-reg64 + :rax push-reg64 + :rax push-reg64 + here ! ] ;asm + +: 2dup + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx push-reg64 + :rax push-reg64 + :rbx push-reg64 + :rax push-reg64 + here ! ] ;asm + + +~ Arithmetic routines +~ ~~~~~~~~~~~~~~~~~~~ +~ +~ No surprises here. Again, since our goal is to bootstrap the heap, we +~ keep it short. Also again, this is nowhere near optimal. + +: + + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax add-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: - + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax sub-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: * + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx mul-reg64 + :rax push-reg64 + here ! ] ;asm + +~ Jonesforth calls this "/mod" but % is widely recognized and has no special +~ Forth significance. +: /% + [ here @ + :rdx :rdx xor-reg64-reg64 ~ rdx is the high bits of the input; zero it + :rbx pop-reg64 + :rax pop-reg64 + :rbx divmod-reg64 + :rdx push-reg64 ~ remainder + :rax push-reg64 ~ quotient + here ! ] ;asm + +~ We define a pair of words that increment and decrement a single item. +~ These were inspired by Common Lisp, where they're constantly useful. +: 1+ + [ here @ + :rax pop-reg64 + :rax inc-reg64 + :rax push-reg64 + here ! ] ;asm + +: 1- + [ here @ + :rax pop-reg64 + :rax dec-reg64 + :rax push-reg64 + here ! ] ;asm + + +~ Comparison routines +~ ~~~~~~~~~~~~~~~~~~~ +~ +~ So. This is subtle. These comparison routines all have the same structure. +~ Notice that = and != are commutative, whereas the others are not, so +~ consider > as the archetypical one when reasoning about correctness. To +~ test if A > B, we do cmp A, B, which sets the flags the same way as +~ subtracting B from A does. The mnemonic names of the condition codes are +~ based on the assumption you do it in this order. +~ +~ We want to treat the top of the stack as the first operand, so we +~ carefully pop in the appropriate order. +~ +~ There are both signed and unsigned variants of the condition codes. We +~ provide both; the unmarked comparisons such as > and <= are signed, while +~ the marked ones such as >unsigned and <=unsigned are of course unsigned. + +~ Jonesforth calls this "="; most languages would call it "==". +: = + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Jonesforth calls this "<>", but even most modern SQL dialects recognize +~ C's legacy and allow "!=" these days. As someone who learned C in childhood, +~ this is not actually a hard call for us. +: != + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-not-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than the second item in the stack, when +~ both are treated as signed? +: > + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-greater :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than the second item in the stack, when both +~ are treated as signed? +: < + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-less :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than or equal to the second item in the +~ stack, when both are treated as signed? +: >= + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-greater-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than or equal to the second item in the +~ stack, when both are treated as signed? +: <= + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-less-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than the second item in the stack, when +~ both are treated as unsigned? +: >unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-above :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than the second item in the stack, when +~ both are treated as unsigned? +: <unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-below :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack greater than or equal to the second item in the +~ stack, when both are treated as unsigned? +: >=unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-above-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + +~ Is the top of the stack less than or equal to the second item in the +~ stack, when both are treated as unsigned? +: <=unsigned + [ here @ + :rax pop-reg64 + :rbx pop-reg64 + :rbx :rax cmp-reg64-reg64 + :cc-below-equal :al set-reg8-cc + 0x01 :rax and-reg64-imm8 + :rax push-reg64 + here ! ] ;asm + + +~ Bitwise routines +~ ~~~~~~~~~~~~~~~~ +~ + +: & + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax and-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: | + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax or-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +: xor + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rbx :rax xor-reg64-reg64 + :rax push-reg64 + here ! ] ;asm + +~ The HP overloads the name "not", so we follow the Forth convention. +: invert + [ here @ + :rax pop-reg64 + :rax not-reg64 + :rax push-reg64 + here ! ] ;asm + + +~ Literal routines +~ ~~~~~~~~~~~~~~~~ +~ +~ These words are rarely used directly from user code, but are emitted by +~ the interpreter, in compile mode. They allow literal values of various kinds +~ to exist inline as part of compiled code, which would otherwise be only an +~ array of codeword pointers. They do this, in their various ways, by pushing +~ any appropriate value on the stack and making sure execution skips over the +~ bytes used to represent it. + +: lit + [ here @ + lods64 + :rax push-reg64 + here ! ] ;asm + +: litstring + [ here @ + ~ The string immediately follows the codeword in memory, so rsi is + ~ already pointing to it. That address will be our returned result, so we + ~ push it to the stack. + :rsi push-reg64 + + ~ Now we need to skip over the string, so that rsi will be valid for the + ~ next Forth word. To do that, we're going to do a string operation with + ~ scas8, which takes rdi as the address to look at. This means scas8 is + ~ treating its operand as analogous to the destination operand of movs*. + :rsi :rdi mov-reg64-reg64 + ~ We want to compare for equality with zero; scas8 looks in al for the + ~ other half of the comparison, so we clear rax. + :rax :rax xor-reg64-reg64 + ~ Counterintuitively, we do need to pass a count. We pass -1, which will + ~ always work. + :rcx :rcx xor-reg64-reg64 + :rcx not-reg64 + ~ The DF flag is zero per our Forth execution-model convention, which + ~ means scas8 increments rdi after each iteration. This is what we want, + ~ so there's no need to mess with it. + ~ + ~ We also need to worry about ZF, but fortunately that "not" will make + ~ sure it's clear. + ~ + ~ So, we're ready; do it! + repnz-scas8 + ~ The scas8 completes, incrementing rdi, before the repnz checks its + ~ condition. So, rdi is now pointing immediately after the terminating + ~ null byte. Of course, we want this in rsi for Forth's purposes. + :rdi :rsi mov-reg64-reg64 + + ~ Finally, we need to align rsi to the next word boundary. + 7 :rsi add-reg64-imm8 + 7 invert :rsi and-reg64-imm8 + + here ! ] ;asm + + +~ Memory access routines +~ ~~~~~~~~~~~~~~~~~~~~~~ +~ +~ We go with Forth names for this stuff. The HP's names for memory and +~ storage operations heavily leverage the fact they have an object system +~ with type tags and so on; we want to stay close to the bytes. + +~ (value, address --) +: ! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rax :rbx mov-indirect-reg64-reg64 + here ! ] ;asm + +~ (address -- value) +: @ + [ here @ + :rax pop-reg64 + :rax :rax mov-reg64-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +~ This follows the general convention that words that set things take the +~ destination as the final parameter. +~ +~ (value, address --) +: +! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rax :rbx add-indirect-reg64-reg64 + here ! ] ;asm + +~ (value, address --) +: -! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :rax :rbx sub-indirect-reg64-reg64 + here ! ] ;asm + +~ Jonesforth calls this "c!" but we categorically reject the use of letters +~ that are meant to indicate byte sizes. It's unfriendly to newcomers. There's +~ some risk that this name will be confused for meaning "store a value of 8", +~ but that would not be a useful task, so hopefully it'll be okay. +: 8! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :al :rbx mov-indirect-reg64-reg8 + here ! ] ;asm + +: 8@ + [ here @ + :rbx pop-reg64 + :rax :rax xor-reg64-reg64 + :rbx :al mov-reg8-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +: 16! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :ax :rbx mov-indirect-reg64-reg16 + here ! ] ;asm + +: 16@ + [ here @ + :rbx pop-reg64 + :rax :rax xor-reg64-reg64 + :rbx :ax mov-reg16-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +: 32! + [ here @ + :rbx pop-reg64 + :rax pop-reg64 + :eax :rbx mov-indirect-reg64-reg32 + here ! ] ;asm + +: 32@ + [ here @ + :rbx pop-reg64 + :rax :rax xor-reg64-reg64 + :rbx :eax mov-reg32-indirect-reg64 + :rax push-reg64 + here ! ] ;asm + +~ Before we get too deep into it, we also define a few reflection routines +~ that retrieve, or set, the address of either of the two stacks. +~ +~ The result, or the new value, is on the top of the data stack. That's the +~ same as how it works for any other word, but given the metacircular nature +~ of these ones it's easy to get confused about that... +~ +~ Jonesforth calls this RSP!, which looks as if it's meant to be an Intel +~ register name but is actually short for return stack pointer. There is no +~ register by that name, it's a Forth-provided abstraction. That's super +~ confusing, plus as discussed above we call it the control stack not the +~ return stack, so we call the words... +~ +~ (stack pointer --) +: control! + [ here @ + :rbp pop-reg64 + here ! ] ;asm + +~ (-- stack pointer) +: control@ + [ here @ + :rbp push-reg64 + here ! ] ;asm + +~ Jonesforth calls this DSP!, for data stack pointer. Again, there's no +~ Intel register by that name, and we call it the value stack, so... +~ +~ (stack pointer --) +: value! + [ here @ + ~ Per Intel's description of POP this reads from the old location, and + ~ there is no increment applied to the resulting value. See, the + ~ description says it increments the register then overwrites it, in that + ~ order. + :rsp pop-reg64 + here ! ] ;asm + +~ (-- stack pointer) +: value@ + [ here @ + ~ Per Intel's description of PUSH this pushes the old value. + :rsp push-reg64 + here ! ] ;asm + +~ Copy one non-overlapping block of memory over another. For the overlapping +~ logic, see roll and unroll. This always copies at byte granularity, for ease +~ of implementation. +~ +~ Jonesforth calls this CMOVE and has a CCOPY which is a single byte. POSIX, +~ however, has memcpy() for non-overlapping blocks and memmove() for +~ overlapping blocks. We follow the latter convention, because it feels like +~ the more important distinction. +~ +~ Also, the "c" was meant to indicate that it works at one-byte granularity, +~ but that isn't, uh... actually an important property here, and as a blanket +~ call we're not using letters to denote data sizes. So we call it "memcopy". +~ Apologies to the C programming tradition but vowels are good, actually. +~ +~ Jonesforth also offers C@C! as another name for its CCOPY, but neither +~ "@!" nor "mem@mem!" seems particularly nice. +~ +~ (source, destination, length --) +: memcopy + [ here @ + ~ We need to save and restore rsi; the other registers we can trample. + :rsi :rdx mov-reg64-reg64 + :rcx pop-reg64 + :rdi pop-reg64 + :rsi pop-reg64 + ~ We start from the low end, since that's easier arithmetic. So, we get + ~ to leave the DF flag alone. + rep-movs8 + :rdx :rsi mov-reg64-reg64 + here ! ] ;asm + +~ This does the same thing as memcopy, but correctly handles situations +~ where the destination overlaps with the source. It achieves this by being +~ careful about which end the transfer starts from. This "move" vs. "copy" +~ distinction mirrors C terminology. +~ +~ (source, destination, length --) +: memmove + [ here @ + ~ We need to save and restore rsi; the other registers we can trample. + :rsi :rdx mov-reg64-reg64 + :rcx pop-reg64 + :rdi pop-reg64 + :rsi pop-reg64 + + ~ We need to check source < destination to decide which end to start from. + :rsi :rax mov-reg64-reg64 + :rdi :rax cmp-reg64-reg64 + ~ Relative offsets are from the start of the instruction after the jmp. + 4 :cc-below jmp-cc-rel-imm8 + + ~ If source is greater, we are sliding downwards so we start from the low + ~ end. So, we get to leave the DF flag alone. + rep-movs8 ~ 2 bytes + 16 jmp-rel-imm8 ~ 2 bytes + + ~ If destination is greater, we are sliding upwards so we start from the + ~ high end. So, we have to save and restore DF. Also, we have to adjust the + ~ pointers. + :rcx :rsi add-reg64-reg64 ~ 3 bytes + :rsi dec-reg64 ~ 3 bytes + :rcx :rdi add-reg64-reg64 ~ 3 bytes + :rdi dec-reg64 ~ 3 bytes + std ~ 1 byte + rep-movs8 ~ 2 bytes + cld ~ 1 byte + + :rdx :rsi mov-reg64-reg64 + here ! ] ;asm + + +~ (string pointer -- string length not including null byte) +: stringlen + [ here @ + :rdi pop-reg64 + :rdi :rbx mov-reg64-reg64 + :rax :rax xor-reg64-reg64 + :rcx :rcx xor-reg64-reg64 + :rcx not-reg64 + repnz-scas8 + :rbx :rdi sub-reg64-reg64 + 1 :rdi sub-reg64-imm8 + :rdi push-reg64 + here ! ] ;asm + +~ This word is for working with strings that are null-terminated at both +~ ends. It counts backwards from the end to find the string length. It accepts +~ an input pointer to the final non-null byte at the end of the string, and +~ returns the length not including either null byte. +~ +~ (string end pointer -- string length not including null) +: reverse-stringlen + [ here @ + :rdi pop-reg64 + + :rdi :rbx mov-reg64-reg64 + :rax :rax xor-reg64-reg64 + :rcx :rcx xor-reg64-reg64 + :rcx not-reg64 + + std + repnz-scas8 + cld + + :rdi :rbx sub-reg64-reg64 + 1 :rbx sub-reg64-imm8 + + :rbx push-reg64 + here ! ] ;asm + + +~ If you have a variable-length string followed by alignment padding, and +~ you want to traverse it in reverse, you also need to skip the alignment +~ padding... +~ +~ The alignment padding can have a total length of no more than 8 bytes. The +~ returned value counts from the end, backwards, to the nearest non-null byte, +~ or at most a distance of eight. +~ +~ (address of final null byte in padding -- count of null bytes in padding) +: reverse-padding-len + [ here @ + :rdi pop-reg64 + + :rdi :rbx mov-reg64-reg64 + :rax :rax xor-reg64-reg64 + 9 :rcx mov-reg64-imm32 + + std + repz-scas8 + cld + + :rdi :rbx sub-reg64-reg64 + 1 :rbx sub-reg64-imm8 + + :rbx push-reg64 + here ! ] ;asm + + +~ We make this work using exactly two jump instructions, which is likely the +~ minimum possible. To avoid relying on labels, we hand-compute the byte +~ offsets, so every instruction within their ranges is annotated with its +~ length in bytes. Good fun. +~ +~ The returned comparsion value is 0 for equal, 1 to indicate the left +~ string (lower on the stack) is greater, and -1 to indicate the right string +~ (top of the stack) is greater. +~ +~ (left string pointer, right string pointer -- comparison value) +: stringcmp + [ here @ + ~ Save the rsi register. + ~ + ~ Happily, we don't need a lot of registers for this code, so we can + ~ dedicate rdx to this and not have to deal with stack juggling.. + :rsi :rdx mov-reg64-reg64 + + ~ Get the parameters off the stack. + ~ + ~ For reasons that will be explained below, the left and right strings + ~ from our caller's perspective are swapped from the perspective of the + ~ comparisons we'll be doing. The rdi register points to the right-hand + ~ operand of the "cmps" instruction, while rsi points to the left-hand + ~ operand; [Intel] volume 2A, chapter 3, section 4-3.3, "CMPS"; note that + ~ the PDF mis-numbers the sections in the second half of chapter 3. + :rsi pop-reg64 + :rdi pop-reg64 + + ~ For the comparison-unequal loop-exit code, we'll need rbx set to zero. + ~ The easy way to do that is by xor'ing it with itself, but doing it at + ~ the end of the loop would overwrite the comparison flags, which we need. + ~ So we do it in advance, and carefully don't touch it anywhere else. + ~ + ~ See the list of which instructions affect the flags in [Intel] + ~ volume 1, appendix A, section A-1, table A-2. + :rbx :rbx xor-reg64-reg64 + + ~ We also clear rax; we'll be using al later, and it will be convenient + ~ to know the upper bits are always zero. + :rax :rax xor-reg64-reg64 + + ~ Now we've initialized everything we need; everything after this point is + ~ part of the loop. + + ~ At the start of each iteration, save a copy of the byte we're at now. + ~ We need to do this before cmps because the pointers will increment; + ~ we'll eventually use it to test whether we've reached the end delimiter. + ~ + ~ We do a 64-bit load into rcx, which is otherwise unused, then copy the + ~ low byte from cl to al. This avoids having to think about addressing + ~ modes that combine 64-bit addresses with smaller data sizes; those are + ~ very subtle. + :rsi :rcx mov-reg64-indirect-reg64 ~ 3 bytes + :cl :al mov-reg8-reg8 ~ 2 bytes + + ~ Now do the cmps, which is the heart of the loop. + ~ + ~ Note that, in addition to relying on this comparison to test content + ~ bytes against each other, in the event that one string is a prefix of + ~ the other, this will also test content bytes against null delimiters. + ~ The longer string will compare as "greater", because zero is less than + ~ all other possible byte values. This is what we want. + ~ + ~ Since strings of different lengths are necessarily unequal, letting + ~ this test do the work of detecting that also means we don't have to deal + ~ with scenarios where we're past the end of one string but not the other. + cmps8 ~ 1 byte + + ~ The flags are now set based on the simulated subtraction of the next + ~ bytes from the two strings. If they were unequal, the loop will end. If + ~ they were equal, we have another test to do before we're finished with + ~ this iteration. So we put the loop-end code next, and conditionally jump + ~ forward past it. + ~ + ~ Recall that relative offsets are from the start of the instruction after + ~ the jmp. + 15 :cc-equal jmp-cc-rel-imm8 ~ 2 bytes + + ~ If we got here, the strings are unequal, so we need to turn the flags + ~ into a comparison value. We cleared rbx earlier; now we set its low bit + ~ to the "above" flag, then use sbb to subtract the "carry" flag (which it + ~ thinks of as the "borrow" flag). + ~ + ~ Recall that "carry" is based on whether the comparison would cause a + ~ change to the next bit "outside" the bits being compared; [Intel] + ~ volume 1, chapter 3, section 3-4.3.1. Since the comparison is a + ~ subtraction, "carry" is true when the right-hand byte is strictly + ~ greater than the left-hand byte. + ~ + ~ Also recall that "zero", also called "equal", is based on whether the + ~ comparison's result produces output that's all zero bits. Since the + ~ comparison is a subtraction, "zero" is true when the two bytes are + ~ identical. + ~ + ~ The "above" condition is not a flag, but a composite of flags. It's + ~ true when both "carry" and "zero" are false; [Intel] volume 1, chapter + ~ 7, section 7-3.1.1, table 7-2. For us, this is equivalent to saying the + ~ left-hand byte is strictly greater than the right-hand. + ~ + ~ So, after the "set" instruction, rbx is 1 if left > right, and 0 if + ~ left = right or left < right. The "sbb" instruction with an immediate + ~ value of zero subtracts the value of the carry flag from rbx; the flag + ~ is true in the case where left < right, and false otherwise. So, after + ~ the "sbb", rbx is 1 if left > right, 0 if left = right, and -1 if + ~ left < right. + ~ + ~ This sounds like the opposite of what we want, but recall that we + ~ exchanged the operands, so these are the values our caller is expecting. + ~ While it might be tempting to look for a way to not need that + ~ transposition, and indeed there exists an approach using "not above", + ~ it's fiddly in a way that's even harder to explain. + ~ + ~ Note that it's important that the "jmp" and "set" instructions don't + ~ change the flags (see table A-2 again), so the "cmps" is the most recent + ~ thing that did. The "sbb" instruction does change them, but we don't + ~ need them again after that point so it doesn't matter. + ~ + ~ Finally, we need to restore rsi before we return to Forth. + ~ + ~ The two-instruction set-sbb sequence is one of those classic assembly + ~ programming tricks that often goes unexplained, because most of its + ~ appeal is its brevity and a proper explanation is quite lengthy. Please + ~ enjoy this gift of knowledge, and thanks to our friends who showed it to + ~ us. + :cc-above :bl set-reg8-cc ~ 3 bytes + 0 :rbx sbb-reg64-imm8 ~ 4 bytes + :rbx push-reg64 ~ 1 byte + :rdx :rsi mov-reg64-reg64 ~ 3 bytes + pack-next ~ 4 bytes + + ~ If we got here, the current bytes are equal to each other. We still + ~ need to test if they're null terminators; if so, we exit, and if not, we + ~ loop. + ~ + ~ At the beginning of this iteration, we saved a copy of the byte being + ~ inspected in rax. The "test" instruction simulates a xor and sets the + ~ flags accordingly. We check the "not equal" condition, also known as + ~ "not zero", and jump backwards to the start of the loop when that's the + ~ case. + ~ + ~ Recall that relative offsets are from the start of the instruction + ~ after the jmp. + :rax :rax test-reg64-reg64 ~ 3 bytes + -28 :cc-not-equal jmp-cc-rel-imm8 ~ 2 bytes + + ~ If we got here, we got all the way to the end of both strings and + ~ found a null byte, so we return 0 to indicate they're equal. + ~ + ~ We can use push-imm32-extended64 even though our stack holds 64-bit + ~ values, because it gets sign-extended. + ~ + ~ We need to restore rsi before we return to Forth. + 0 push-imm32-extended64 + :rdx :rsi mov-reg64-reg64 + here ! ] ;asm + + +~ Branching +~ ~~~~~~~~~ + +~ Okay, so there's a weird thing about how branch and 0branch are defined. +~ 0branch jumps into branch, so they need to be next to each other in the log. +~ To compute the offset to jump by, we pass an address on the stack. Notice +~ that assembly words are always defined in immediate mode; it's just they +~ usually only do trivial logic. + +~ This takes a number of bytes, not machine words. That allows it to be used +~ for putting weird things embedded in the code. +~ +~ The offset is relative to the start of the word the number of bytes is in, +~ so, make sure to have it skip itself. +: branch + [ here @ + dup swap ~ Save a copy of this address for later. + :rsi :rsi add-reg64-indirect-reg64 + here ! ] ;asm +~ (jump destination) + +: 0branch + [ here @ + ~ (jump destination, output point) + + :rax pop-reg64 + :rax :rax test-reg64-reg64 + + ~ Please notice the 8-bit branch to the nearby word. This is the offset + ~ from the end of the jmp instruction, to the start of the target + ~ instruction. To avoid needing the label system for this, we compute it + ~ based on the address before the jmp; the jmp itself is two bytes. + ~ + ~ Remember, with jump arithmetic, subtract the start from the + ~ destination. + ~ + ~ What we're testing with :cc-equal is that the input value is zero. + ~ The name is slightly counterintuitive; it's a result of the condition + ~ names favoring cmp over test. While cmp simulates subtraction, test + ~ simulates bitwise AND. + dup 2 + 3roll swap - :cc-equal jmp-cc-rel-imm8 + ~ (output point) + + ~ In the event we didn't jump, we still need to skip over the literal + ~ value. Using lods here is just a convenient way to skip rsi forward. + lods64 + + here ! ] ;asm +~ the stack is empty once more + + +~ This is like next, but instead of using rsi as the "instruction pointer", +~ it takes a codeword address from the value stack. +~ +~ In the event that the codeword is docol, docol will handle any +~ manipulation of the control stack that needs to happen. Yes, it really is +~ that simple. +~ +~ (execution token --) +: execute + [ here @ + :rax pop-reg64 + :rax jmp-abs-indirect-reg64 + here ! ] ;asm + + +~ Dictionary entries +~ ~~~~~~~~~~~~~~~~~~ +~ +~ Now, we have a bunch of words that are used for traversing the Forth +~ core data structures that describe words. First, we have a couple that +~ relate to individual words and their pieces... +~ +~ The log-load transform produces code that requires +~ entry-to-execution-token, which means it's needed statically. So this stuff +~ to deal with word entry headers might as well go in core, since it has no +~ dependencies to speak of. +~ +~ These are the first words in core that are implemented in Forth rather +~ than assembler. That's not as big a deal as it may seem; the Forth execution +~ model has been ready-to-go ever since we implemented docol and exit, and +~ at this point we have enough basics to do useful things with it. + +~ Jonesforth calls this "TFCA" and ">CFA"; its author speculates that the +~ original meaning is "code field address". +~ +~ (entry pointer -- execution token) +: entry-to-execution-token + ~ Skip next-entry pointer, flag byte, and start terminator. + 10 + + ~ Skip string contents. + dup stringlen + + ~ Skip one for the null terminator, seven more for alignment. + 8 + + ~ Zero the low bits and now it's aligned. + 7 invert & ; + +~ Jonesforth calls this "CFA>". Jonesforth's implementation searches the +~ entire dictionary, since its word header format isn't designed to be +~ traversed in reverse, but ours is, so it should be fast. +~ +~ (execution token -- entry pointer) +: execution-token-to-entry + 1 - + dup reverse-padding-len - + dup reverse-stringlen - + 9 - ; + +~ (entry pointer -- flags byte) +: entry-flags@ + 8 + @ 0xFF & ; + +~ (new flags byte, entry pointer --) +: entry-flags! + 8 + + dup @ 3roll + 0xFF & + swap 0xFFFFFFFFFFFFFF00 & | + swap ! + ; + +~ (entry pointer -- name string pointer) +: entry-to-name 10 + ; + + +~ Binary packing +~ ~~~~~~~~~~~~~~ +~ +~ These routines are for building up data structures in-memory. Sometimes +~ they're used for structures that are meant to stay in memory; other times +~ it's a buffer that will become output. +~ +~ The general pattern is that each routine takes an output address and +~ some specific datum, and returns the output address adjusted to point +~ after the new datum. That makes them easy to chain together. We call this +~ address the "output point", to capture the idea that it's a running total +~ which gets updated by each new datum as it's packed. + +~ (output point, value -- output point) +: pack64 swap dup 3unroll ! 8 + ; +: pack32 swap dup 3unroll 32! 4 + ; +: pack16 swap dup 3unroll 16! 2 + ; +: pack8 swap dup 3unroll 8! 1 + ; + +~ This works on C-style strings, which are characters followed by a null +~ terminator. The packed data includes the null terminator. +~ +~ (output point, string pointer -- output point) +: packstring + dup stringlen 1 + dup + ~ (output point, source, length, length) + 4 roll dup 4 unroll + + ~ (source, destination, length, length, output point) + + 4 unroll + ~ (output point, source, destination, length) + memcopy ; + +~ This also works on C-style strings, relying on the null terminator, but +~ the packed data does not include it. +~ +~ (output point, string pointer -- output point) +: pack-raw-string + dup stringlen dup + ~ (output point, source, length, length) + 4 roll dup 4 unroll + + ~ (source, destination, length, length, output point) + + 4 unroll + ~ (output point, source, destination, length) + memcopy ; + +~ (output point, alignment byte width -- output point) +: packalign + ~ It's possible the padding will be of length zero; keep that in mind + ~ while maintaining these magic comments, as it comes up in several ways. + ~ : fresh-line + ~ : 0 #-- (alignment padding) + { 2dup /% drop { drop exit } unless + swap 0 pack8 swap + ~ : 1 adjust-length + } forever ; + + +~ Binary unpacking +~ ~~~~~~~~~~~~~~~~ +~ +~ These routines are for examining data structures in-memory. +~ +~ Similarly to the output routines, each routine takes an input address, +~ which it updates to point after the data item being read. We call this the +~ "input point". Since this is input, the routines return data items rather +~ than accepting them. + +~ (input point -- input point, value) +: unpack64 dup @ swap 8 + swap ; +: unpack32 dup 32@ swap 4 + swap ; +: unpack16 dup 16@ swap 2 + swap ; +: unpack8 dup 8@ swap 1 + swap ; + +~ (proposed size, alignment byte width -- adjusted size) +: align-size + dup 3unroll dup 3unroll + ~ (alignment, alignment, proposed size, alignment) + 1 - + swap /% swap drop * ; + +~ You might think this would be identical to packalign, but packalign has +~ side effects. +~ +~ (input point, alignment byte width -- input point) +: unpackalign align-size ; + + +~ The first hint of a debugging tool +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +~ This peforms the "hlt" instruction (Intel's mnemomic, short for "halt"), +~ which will cause the program to exit with a segmentation fault. If you're +~ running under a debugger, this is a convenient way to get execution to stop +~ at a certain point. +~ +~ It's called "crash" rather than "hlt" to distinguish it from the word +~ which outputs the instruction as machine code. +~ +~ This is the main diagnostic tool available under the label transform. Yep. +~ That's all we get. Don't make those eyes. +: crash + [ here @ + hlt + here ! ] ;asm + + +~ Additional conveniences +~ ~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ Please feel free to find an organizing principle for these and put them +~ where they go. It would be kind of nice to re-write these either in +~ assembly, or with high-level flow control, but it doesn't seem urgent... + +: max + 2dup >= { swap } if + drop ; + +: min + 2dup <= { swap } if + drop ; + +: over swap dup 3unroll ; + +~ 0 pick is equivalent to dup. 1 pick is equivlent to over. +: pick 2 + dup roll dup 3roll unroll ; + +~ Standard Forth doesn't have equivalents of our ndrop and ndup. The HP +~ calls them DROPN and DUPN but that doesn't go well with ie. 2dup or 3roll, +~ so we do it like this. +: ndrop { dup } { swap drop 1- } while drop ; + +: ndup + dup 1+ swap + { dup } { swap dup pick 3unroll swap 1- } while + 2drop ; + +: 3drop drop drop drop ; +: 3dup 2 pick 2 pick 2 pick ; + +: && 0 != swap 0 != * ; +: || | 0 != ; +: not 0 = ; +: negate -1 * ; + +: align-floor dup 3unroll /% swap drop * ; + + +~ Find-in is the main word that provides the capability to look up words by +~ name, though it's usually used via "find" rather than being called directly. +~ +~ Find-in traverses the linked list formed by a particular dictionary's +~ next-entry pointers, looking for an entry that matches a given name. The +~ dictionary pointer is the pointer (not handle) to the root of the list, +~ which runs from newest to oldest. For example, dereferencing the value of +~ "latest" gives the pointer to the main dictionary, which can be passed to +~ find-in. +~ +~ Having find-in separated out is convenient when working with alternate +~ dictionaries, but the main reason for having it is not convenience but +~ necessity: During Evocation's startup, there is a period before global +~ variables are easily accessible, so there would be no way to implement +~ "find". The warm-start routine (see compilation/execution.e and +~ compilation/transform.e) has the job of fixing that, and it makes extensive +~ use of find-in to do so. +~ +~ The definition of "find" is in language/dynamic/dynamic.e, with the other +~ stuff that needs to access the log. +~ +~ (dictionary pointer, string pointer -- entry pointer or 0) +: find-in + ~ It will be more convenient to have the entry pointer on top. + swap + + { + ~ If the entry pointer is null, exit. + ~ (name pointer to find, current entry pointer) + dup 0 = { swap drop exit } if + + ~ Check this entry's "hidden" flag. + ~ (name pointer to find, current entry pointer) + dup entry-flags@ 0x80 & 0x80 != { + ~ Test whether this entry is a match. + ~ (name pointer to find, current entry pointer) + 2dup 10 + stringcmp 0 = { + ~ If we're here, it's a match. Clean up our working state and exit. + ~ (name pointer to find, current entry pointer) + swap drop exit + } if + } if + + ~ If we're here, it's not a match; traverse the pointer and repeat. + ~ (name pointer to find, current entry pointer) + @ + } forever ; + diff --git a/language/static/execution-support.e b/language/static/execution-support.e new file mode 100644 index 0000000..1592643 --- /dev/null +++ b/language/static/execution-support.e @@ -0,0 +1,111 @@ +~ Execution support +~ ~~~~~~~~~~~~~~~~~ +~ +~ These macros are an important part of the execution model described in +~ compilation/execution.e. They're here, in this file, because they need to be +~ statically available via the label transform, so that the log-load transform +~ can rely on them. + + +~ Macro next +~ ~~~~~~~~~~ +~ +~ Include this inline at the end of a word implemented in machine-code. +~ Conceptually, it returns. What it actually does is do the next thing the +~ caller would do, which is call the next word from the caller's array of +~ word pointers. +~ +~ This is a widespread technique in Forth implementation, referred to as +~ indirect threaded code. It's "threaded" in the sense that each word takes +~ responsibility for finishing up by following the notional thread through the +~ metaphorical labyrinth to figure out the next word that its caller wants to +~ run after it. In other words, control never directly returns to the parent, +~ it proceeds directly to the sibling. +~ +~ Registers in: +~ +~ * rsi points to the address of the word to execute +~ +~ Registers out: +~ +~ * rax points to the codeword in the contents of the word that was executed +~ * rsi points to the next word-address after this one +~ +~ Flags +~ * DF = 0 is required +~ +~ (output point -- output point) +: pack-next + ~ : "next" macro + ~ Copy the next word's address from *rsi into rax. Increment rsi (as per + ~ the DF flag). + lods64 + + ~ Load the codeword from the word's contents, and jump to the interpreter + ~ it points to. + :rax jmp-abs-indirect-reg64 ; + + +~ Macro beforenext +~ ~~~~~~~~~~~~~~~~ +~ +~ Sometimes we want to transfer control from a word implemented in +~ machine-code to another word, without coming back after, as if we were +~ simply jumping to it. This is an innovation of ours; Jonesforth doesn't do +~ it. It is similar to the tail-call optimization that many Lisp dialects +~ have. +~ +~ This implementation will work regardless of how the receiving word is +~ implemented. It impersonates the "next" snippet, setting up rax to point +~ to the codeword then jumping to the interpreter. Since it doesn't change +~ the control stack or rsi, when the receiving word eventually invokes +~ "next"; it will pick up in the same place as if this sending word had done +~ it. +~ +~ Thus, notionally we are doing just this one transfer of control before +~ eventually getting around to inlining "next". Hence the name. +~ +~ (output point, target address -- output point) +: pack-beforenext + ~ : "beforenext" macro + ~ Do a permanent transfer of control by setting rax and invoking the + ~ codeword. Of course, we could jump to docol ourselves but this will work + ~ regardless of what the receiving codeword is. + :rax mov-reg64-imm64 + :rax jmp-abs-indirect-reg64 ; + + +~ Macros pushcontrol +~ popcontrol +~ ~~~~~~~~~~~~~~~~~~ +~ +~ Include these inline to push an address onto the control stack, or pop +~ one off of it. You will recall the control stack is kept in rbp. The +~ parameter is given in a user-specified register. +~ +~ Jonesforth's analogous macros are called PUSHRSP and POPRSP but I think +~ that's super confusing, since rsp is also the name of a register, but a +~ different one. I guess it was less confusing in 32-bit, since esp doesn't +~ start with an "r". Anyway, this has to be named something that +~ distinguishes it from Intel's PUSH and POP opcodes, so... +~ +~ "Load effective address" is just a cute way to do arithmetic on a +~ register, here. To push or pop we decrement or increment rbp by 8. To +~ actually interact with the space in the stack, we indirect through rbp. +~ +~ Registers in and out: +~ +~ * rbp points to the top of the control stack. +~ +~ (output point, source register -- output point) +: pack-pushcontrol + ~ : "pushcontrol" macro + swap :rbp -8 :rbp lea-reg64-disp8-reg64 + swap :rbp 0 mov-disp8-reg64-reg64 ; + +~ (output point, target register -- output point) +: pack-popcontrol + ~ : "popcontrol" macro + :rbp 0 3roll mov-reg64-disp8-reg64 + :rbp 8 :rbp lea-reg64-disp8-reg64 ; + diff --git a/language/static/linux.e b/language/static/linux.e new file mode 100644 index 0000000..fd15ae0 --- /dev/null +++ b/language/static/linux.e @@ -0,0 +1,153 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ System calls for the Linux kernel ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The kernel preserves every register except rax, rcx, and r11. The system +~ call number goes in rax, as does the return value. Parameters go in rdi, +~ rsi, rdx, r10, r8, and r9, in that order. [SysV] A.2.1. +~ +~ Notice that rsi is our control stack, so we have to save it (for +~ syscalls with at least two parameters). We can use the value stack to do +~ that, since rsp is preserved, or we can use one of the other registers. We +~ don't ourselves save other registers because our caller should do that, if +~ it cares. +~ +~ In the kernel source, you may find the following files useful to +~ reference: +~ +~ * arch/x86/entry/syscalls/syscall_64.tbl +~ * include/linux/syscalls.h +~ * include/linux/compat.h +~ +~ Don't be confused by tools/scripts/syscall.tbl, it's not for x86. +~ +~ This file loads early, before anything in language/dynamic/. So, although +~ it superficially appears to be able to do allocation and high-level flow +~ control, those come from the transforms, which means they're shallow +~ implementations. The stuff here can't be moved later, because +~ language/dynamic/input.e relies on it, and the other dynamic stuff relies on +~ that. So, there's additional Linux functionality in another file that loads +~ later, language/dynamic/linux.e. + + +~ (call number -- return value) +: syscall-0 + [ here @ + :rax pop-reg64 ~ syscall number + syscall + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, call number -- return value) +: syscall-1 + [ here @ + :rax pop-reg64 ~ syscall number + :rdi pop-reg64 ~ first param + syscall + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, second param, call number -- return value) +: syscall-2 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, second param, third param, call number -- return value) +: syscall-3 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + +~ (first param, second param, third param, fourth param, call number +~ -- return value) +: syscall-4 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :r10 pop-extrareg64 ~ fourth param + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + + +~ (first param, second param, third param, fourth param, fifth param, +~ call number -- return value) +: syscall-5 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :r8 pop-extrareg64 ~ fifth param + :r10 pop-extrareg64 ~ fourth param + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + + +~ (first param, second param, third param, fourth param, fifth param, +~ sixth param, call number -- return value) +: syscall-6 + [ here @ + :rsi :rbx mov-reg64-reg64 ~ save rsi + :rax pop-reg64 ~ syscall number + :r9 pop-extrareg64 ~ sixth param + :r8 pop-extrareg64 ~ fifth param + :r10 pop-extrareg64 ~ fourth param + :rdx pop-reg64 ~ third param + :rsi pop-reg64 ~ second param + :rdi pop-reg64 ~ first param + syscall + :rbx :rsi mov-reg64-reg64 ~ restore rsi + :rax push-reg64 ~ return value + here ! ] ;asm + + +~ Raw system calls +~ ~~~~~~~~~~~~~~~~ + +~ This does the Linux exit() system call, passing it an exit code taken +~ from the stack. It does not return. +~ +~ (exit code -- *) +: sys-exit 60 syscall-1 + ~ In the event we're still here, let's minimize confusion. + crash ; + +~ This does the Linux write() system call, passing it an address from the +~ top of the stack and a length from the second position on the stack. It +~ uses a Unix file descriptor, which is a non-negative integer, to tell it +~ where to write to. For stdout, use fd 1. +~ +~ (file descriptor, base address, length to write -- result code or length) +: sys-write 1 syscall-3 ; + +~ (file descriptor, base address, length to read -- result code or length) +: sys-read 0 syscall-3 ; + +~ (filename, flags, mode -- result code or file descriptor) +: sys-open 2 syscall-3 ; + +~ (file descriptor -- result code) +: sys-close 3 syscall-1 ; + diff --git a/language/static/log-load.e b/language/static/log-load.e new file mode 100644 index 0000000..54a9d42 --- /dev/null +++ b/language/static/log-load.e @@ -0,0 +1,547 @@ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ ~~ Bootstrapping the log ~~ +~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~ +~ The log is the main region of memory within which most dynamic allocation +~ happens. It's a single contiguous segment of virtual memory, which is +~ requested from the kernel when Evocation starts up. Almost all of +~ Evocation's dynamic data is kept in the log, including the main dictionary; +~ several important global variables which make it possible to find and +~ allocate other data structures; and the control stack. +~ +~ This file has the task of providing words which are useful for working +~ with the log, and more specifically which are useful for helping to bring +~ the log into existence. Once the log exists, it can be used to manage +~ itself, but there's a bootstrapping challenge in getting there. That +~ challenge is solved by the warm-start routine in compilation/execution.e, +~ which relies on the words in this file and should load after it. +~ +~ Some modern Forths, including Jonesforth, refer to the log as the heap. +~ This is a misnomer; a heap is a data structure that allows non-contiguous +~ allocation. Although there are Forths that have true heaps, Evocation is not +~ one of them. Space in the log is allocated by incrementing the "here" +~ variable (one of those important globals), which necessarily can only +~ allocate contiguous blocks; there is no way to compact allocations to +~ reclaim fragmented, unused space in between them. Evocation does allow +~ deallocation using "forget", but this is done by resetting "here" and +~ "latest" to older values, unwinding every allocation that's been done since +~ the point in time they return to. +~ +~ It would be a mistake to confuse this allocation strategy with the +~ more-general facilities for allocation, reallocation, and deallocation of +~ individual memory blocks that many other languages have. To avoid confusion, +~ we stay away from the name "heap", though it may still occasionally be used +~ colloquially because it's familiar from other Forths, and because most +~ programming languages have a heap as the main memory segment they request +~ from the kernel. +~ +~ In the strictest technical sense, the log is a stack: Things are added +~ to the end of it, and removed from that same end. However, Evocation already +~ has two other stacks, the control and value stacks. Adding to the potential +~ confusion, the control stack is actually stored inside the log (as a +~ fixed-size chunk at the bottom). However, the log isn't really that much +~ like a stack when you look at how it's actually used. Unlike Evocation's +~ control and value stacks, data structures on the log tend to be rich and +~ complex, interlinked in various ways through the use of pointers. They also +~ tend to be long-lived, with the log tending to grow over time, whereas the +~ control and value stacks tend to remain roughly the same size through cycles +~ of growth and shrinking. In order to be able to speak precisely about what +~ we're doing, we introduce the name "log" to refer to the entire memory +~ segment and everything stored within it. +~ +~ Another linguistic choice we make is to be clear about dictionaries. A +~ dictionary is a linked list of word entries. Each dictionary has a specific +~ handle, a pointer to a pointer, which is the root of the list. Each +~ word entry begins with a specific data structure, which among other things +~ includes a next-entry pointer, a flags byte, and a string that serves as +~ the entry's name. Older entries in a dictionary seldom change; newer entries +~ are added at the beginning of it, with their next-entry pointers leading to +~ the older entries. It is possible for several dictionaries to exist at once, +~ each with its own dictionary handle. +~ +~ Since dictionaries are managed using pointers to individual entries, there +~ is no specific requirement about the order in which those entries occur in +~ memory or where they are allocated, but usually a new entry is allocated at +~ the end of the log, by incrementing the variable "here", in the same manner +~ as any other allocation. There is one particular dictionary, the main +~ dictionary, whose handle is the variable "latest". The main dictionary holds +~ every executable word that can be used normally via Evocation's interpreter. +~ +~ Since the main dictionary is by far the most important thing in the log, +~ it can be tempting to conflate the log with the main dictionary. This is +~ accurate enough for some purposes, but note that other dictionaries are +~ often interleaved with it, their allocations entwining like grape vines even +~ while each remains separate, reachable only via its own root. See the +~ machine label facility, in compilation/labels.e, for an example of how a +~ secondary dictionary can be useful. +~ +~ This may feel tangential, but it's important background and there's no +~ better place to explain it: A handle is a pointer to a pointer. The variable +~ "latest" returns a handle, a fixed address which always holds the pointer to +~ the root entry of the main dictionary. Dereferencing that handle gives you +~ the dictionary pointer, the address of the root entry, which is suitable to +~ pass to find-in and similar words that read the dictionary's contents. When +~ you want to add a new entry to a dictionary, you need the dictionary's +~ handle, so that the root pointer can be changed. When you only want to write +~ it, you only need the regular single pointer. +~ +~ When reading the documentation of words that work with dictionaries, pay +~ close attention to whether their parameters include a dictionary handle, or +~ a dictionary pointer. +~ +~ The term "handle" was widely known in the early days of microcomputing, +~ when memory-safe languages without direct pointer access were less common. +~ Today it is usually considered specific to systems programming, the type of +~ programming which lies beneath other software and deals with topics such as +~ memory management and processes. Evocation is a systems-programming +~ language, in the sense that it takes pains to not introduce mandatory +~ abstractions which would make it difficult or inefficient to work directly +~ with these topics. So, in understanding Evocation, it's important to know +~ about handles. +~ +~ Some of these bootstrap words rely on being able to invoke assembler words +~ that output machine code. Therefore, those words must be available at +~ runtime. Since nothing can be dynamically available at runtime until after +~ we've already run the log-load routine, which relies on the stuff in this +~ file, the assembler words must be statically available via the label +~ transform. That means their definitions in arm64.e must be loaded before +~ this file. + + +~ This has the same value as the constant control-stack-size, which is +~ defined in compilation/execution.e. Everything will break if it doesn't. +~ +~ TODO: remove one of them. Probably the other one. +: log-offset 0x10000 ; ~ 64 KiB + +~ (log address -- log address, "log" pointer) +: log-load-log + dup log-offset + ; +~ (log address -- log address, "s0" pointer) +: log-load-s0 + dup log-offset + 8 + ; +~ (log address -- log address, "r0" pointer) +: log-load-r0 + dup log-offset + 2 8 * + ; +~ (log address -- log address, "latest" pointer) +: log-load-latest + dup log-offset + 3 8 * + ; +~ (log address -- log address, "here" pointer) +: log-load-here + dup log-offset + 4 8 * + ; + + +~ This is a helper used by warm-start, which invokes find-in using "latest". +~ It relies on being passed the root address of the log, which is used to find +~ the global variable "latest". It's inconvenient to keep a log pointer around +~ all the time, which is why we stop doing it as soon as possible, but during +~ Evocation's startup there's no alternative. This word is used extensively +~ by code that's been compiled via the log-load transform; see +~ compilation/transform.e for details. +~ +~ It would be possible to unload this word after the log is created, but +~ there are rare situations in which it's still useful, such as injecting +~ Evocation into another process's address space. Plus, it's small. So, we +~ keep it around. +~ +~ (log address, string pointer -- log address, entry pointer or 0) +: log-load-find + swap log-load-latest @ swap 3unroll swap find-in ; + +~ In the code generated by the log-load transform, it's convenient to have +~ only a single step needed to look up a word's execution token. This helper +~ does log-load-find, then gets the execution token if an entry is found. +~ +~ (log address, string pointer -- log address, execution token or 0) +: log-load-find-execution-token + dup 3unroll log-load-find dup + { + 3roll drop + entry-to-execution-token + } { + drop swap + ." No such word: " emitstring newline + 0 + } if-else ; + + +~ This is the same as "create", from language/dynamic/dynamic.e, except that +~ it takes the log's address as a parameter rather than hardcoding it, so that +~ it can be used in situations where the normal compilation process isn't yet +~ available. +~ +~ The requisite stack juggling is kind of finicky, sorry if it's hard to +~ read, but it's doing the same steps in the same order as the regular +~ "create". +~ +~ (log address, string pointer -- log address) +: log-load-create + dup stringlen 1 + dup 3unroll + ~ (log address, name field length, string pointer, name field length) + + 3 pick log-load-here swap drop @ 10 + swap memmove + ~ (log address, name field length) + + over log-load-here swap drop @ + ~ (log address, name field length, output point) + + 2 pick log-load-latest swap drop @ pack64 + ~ (log address, name field length, output point) + 0 pack8 + 0 pack8 + + + ~ (log address, output point) + 8 packalign + ~ (log address, output point) + + over log-load-here swap drop @ + ~ (log address, output point, old here value) + 2 pick log-load-latest swap drop ! + ~ (log address, output point) + over log-load-here swap drop ! ; + + +~ (log address -- log address) +: log-load-self-codeword + log-load-here dup @ + ~ (log address, here, output point) + + dup 8 + pack64 + ~ (log address, here, output point) + + swap ! ; + + + +~ This is the same as ",", from language/dynamic/dynamic.e, except that it +~ takes the log's address as a parameter rather than hardcoding it, so that it +~ can be used in situations where the normal compilation process isn't yet +~ available. +~ +~ Again, the stack juggling is kind of a lot, sorry about that. +~ +~ (log address, value -- log address) +: log-load-comma + swap log-load-here swap 3unroll + ~ (log address, value, here) + @ swap pack64 + ~ (log address, updated here value) + swap log-load-here swap 3unroll + ~ (log address, updated here value, here) + ! ; + + +~ This is the same as `;asm`, from language/dynamic/dynamic.e, except that +~ it takes the log's address as a parameter rather than hardcoding it, so that +~ it can be used in situations where the normal compilation process isn't yet +~ available. +~ +~ Its two main responsibilities are to call `pack-next`, from +~ language/static/execution-support.e, and to overwrite the codeword. It also +~ deals with alignment. +~ (log address) +: log-load-semicolon-assembly + log-load-here @ + ~ (log address, output point) + + pack-next + 8 packalign + ~ (log address, output point) + + swap log-load-here swap 3unroll ! + ~ (log address) + + log-load-latest @ + ~ (log address, entry pointer) + entry-to-execution-token + dup 8 + swap ! ; + + +~ This is the same as "variable", from language/dynamic/dynamic.e, except +~ that it takes the log's address as a parameter rather than hardcoding it, so +~ that it can be used in situations where the normal compilation process isn't +~ yet available. +~ +~ (log address, address for new variable word, string pointer -- log address) +: log-load-variable + 3roll swap log-load-create + ~ (address for new variable word, log address) + + log-load-here swap 3unroll + ~ (log address, address for new variable word, here) + + dup @ + ~ (log address, address for new variable word, here, output point) + dup 8 + pack64 + + 3roll :rax mov-reg64-imm64 + ~ (log address, here, output point) + + :rax push-reg64 + pack-next + 8 packalign + + swap ! ; + + +~ A keyword is a word that evaluates to its own address, which makes it +~ suitable for use as a constant. See more detail on that in +~ language/dynamic/dynamic.e, where "keyword" is defined. +~ +~ Unlike Common Lisp, the lexer doesn't create keywords for us, we have to +~ do it explicitly. If if that were to someday change, the log-load routine +~ would still need a way to do it, which is this. +~ +~ It's kind of a pain to look up the appropriate "docol" from here, so we +~ do it in assembler instead. +~ +~ (log address, string pointer -- log address) +: log-load-keyword + log-load-create + ~ (log address) + + log-load-here @ dup + ~ (log address, self execution token, output point) + + dup 8 + pack64 + ~ (log address, self execution token, output point) + + swap :rax mov-reg64-imm64 + ~ (log address, output point) + + :rax push-reg64 + pack-next + 8 packalign + ~ (log address, output point) + + swap log-load-here + ~ (output point, log address, here) + swap 3unroll + ~ (log address, output point, here) + ! ; + + +~ This is a helper used by log-load-string-alternate. It does the usual +~ string packing thing, but at one layer of indirection more than usual. Its +~ responsibility includes alignment, unlike packstring. +~ +~ (log address, string pointer -- log address) +: log-load-comma-string + swap log-load-here @ 3roll + ~ (log address, output point, string pointer) + + packstring + 8 packalign + ~ (log address, output point) + + swap log-load-here 3roll swap + ~ (log address, output point, here) + ! ; + + +~ Now we have a bunch of words that are the back-ends for the log-load +~ transform's high-level flow control alternates. These implementations +~ closely parallel the non-transformed versions in +~ language/dynamic/flow-control.e, which should be referenced in understanding +~ them. +~ +~ These variants are a bit unusual in their interfaces: They end with the +~ log address at the top of the stack, even when they have values to return. +~ That's because they're really just "talking" to each other; they don't need +~ to interact with anything else, and doing it this way saves the alternates +~ the work of swapping things around after. +~ +~ Notice also that, because these run entirely at log-load time, they are +~ always dealing with target pointers and don't have to convert address +~ spaces. +~ +~ (log address -- start pointer, log address) +: log-load-left-curly-brace + log-load-here @ swap ; + + +~ (start pointer, log address -- start pointer, length, log address) +: log-load-right-curly-brace + swap dup 3roll + ~ (start pointer, start pointer, log address) + log-load-here @ swap + ~ (start pointer, start pointer, end pointer, log address) + 3unroll swap - swap ; + + +~ (start, length, log address -- log address) +: log-load-if + 3unroll + ~ (log address, start, length) + 2dup swap dup + ~ (log address, start, length, length, start, start) + 5 8 * + + ~ (log address, start, length, length, start, adjusted start) + 3roll + ~ (log address, start, length, start, adjusted start, length) + memmove + ~ (log address, start, length) + swap 3roll log-load-here dup @ + ~ (length, start, log address, here pointer, old here) + swap 4 roll swap + ~ (length, log address, old here, start, here pointer) + ! + ~ (length, log address, old here) + 3unroll + ~ (old here, length, log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" !=" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + ~ (old here, length, log address) + swap dup 3unroll + ~ (old here, length, log address, length) + 8 + log-load-comma + ~ (old here, length, log-address) + 3unroll + ~ (log address, old here, length) + drop 5 8 * + + ~ (log address, new here) + swap log-load-here + ~ (new here, log address, here pointer) + 3roll swap ! ; + + +~ (start, length, log address -- log address) +: log-load-unless + 3unroll + ~ (log address, start, length) + 2dup swap dup + ~ (log address, start, length, length, start, start) + 5 8 * + + ~ (log address, start, length, length, start, adjusted start) + 3roll + ~ (log address, start, length, start, adjusted start, length) + memmove + ~ (log address, start, length) + swap 3roll log-load-here dup @ + ~ (length, start, log address, here pointer, old here) + swap 4 roll swap + ~ (length, log address, old here, start, here pointer) + ! + ~ (length, log address, old here) + 3unroll + ~ (old here, length, log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" =" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + ~ (old here, length, log address) + swap dup 3unroll + ~ (old here, length, log address, length) + 8 + log-load-comma + ~ (old here, length, log-address) + 3unroll + ~ (log address, old here, length) + drop 5 8 * + + ~ (log address, new here) + swap log-load-here + ~ (new here, log address, here pointer) + 3roll swap ! ; + + +~ (true start, true length, false start, false length, log address +~ -- log address) +: log-load-if-else + 5 unroll 2dup + ~ (log address, true start, true length, false start, false length, + ~ false start, false length) + swap dup 7 8 * + 3roll + ~ (log address, true start, true length, false start, false length, + ~ false start, adjusted false start, false length) + memmove + ~ (log address, true start, true length, false start, false length) + 3 pick dup 5 8 * + + ~ (log address, true start, true length, false start, false length, + ~ true start, adjusted true start) + 4 pick + ~ (log address, true start, true length, false start, false length, + ~ true start, adjusted true start, true length) + memmove + ~ (log address, true start, true length, false start, false length) + + 4 roll dup 5 unroll + ~ (log address, true start, true length, false start, false length, + ~ true start) + 6 roll log-load-here @ 7 unroll + ~ (old here, true start, true length, false start, false length, true start, + ~ log address) + log-load-here 3roll swap ! + ~ (old here, true start, true length, false start, false length, + ~ log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" !=" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + ~ (old here, true start, true length, false start, false length, + ~ log address) + 4 roll dup 5 unroll + ~ (old here, true start, true length, false start, false length, + ~ log address, true length) + 3 8 * + log-load-comma + ~ (old here, true start, true length, false start, false length, + ~ log address) + 3unroll + ~ (old here, true start, true length, log address, + ~ false start, false length) + swap dup 3unroll + ~ (old here, true start, true length, log address, + ~ false start, false length, false start) + 5 8 * + + ~ (old here, true start, true length, log address, + ~ false start, false length, adjusted false start) + 4 roll log-load-here 3roll swap ! + ~ (old here, true start, true length, + ~ false start, false length, log address) + s" branch" log-load-find entry-to-execution-token log-load-comma + swap 8 + log-load-comma + ~ (old here, true start, true length, false start, log address) + 4 unroll + ~ (old here, log address, true start, true length, false start) + drop drop drop + ~ (old here, log address) + log-load-here + 3roll 7 8 * + swap ! ; + + +~ (start, length, log address -- log address) +: log-load-forever + s" branch" log-load-find entry-to-execution-token log-load-comma + swap 8 + -1 * log-load-comma + swap drop ; + + +~ (test start, test length, body start, body length, log address +~ -- log address) +: log-load-while + 5 unroll 2dup + ~ (log address, test start, test length, body start, body length, + ~ body start, body length) + swap dup 5 8 * + 3roll + ~ (log address, test start, test length, body start, body length, + ~ body start, adjusted body start, body length) + memmove + + ~ (log address, test start, test length, body start, body length) + 5 roll log-load-here @ 6 unroll + ~ (old here, test start, test length, body start, body length, log address) + log-load-here 4 roll dup 5 unroll swap ! + ~ (old here, test start, test length, body start, body length, log address) + s" lit" log-load-find entry-to-execution-token log-load-comma + 0 log-load-comma + s" !=" log-load-find entry-to-execution-token log-load-comma + s" 0branch" log-load-find entry-to-execution-token log-load-comma + swap dup 3unroll 3 8 * + log-load-comma + ~ (old here, test start, test length, body start, body length, log address) + log-load-here 5 8 * 8 roll + swap ! + ~ (test start, test length, body start, body length, log address) + s" branch" log-load-find entry-to-execution-token log-load-comma + 5 unroll + ~ (log address, test start, test length, body start, body length) + 6 8 * + swap drop + swap drop -1 * log-load-comma ; + diff --git a/language/static/output.e b/language/static/output.e new file mode 100644 index 0000000..cadd5fb --- /dev/null +++ b/language/static/output.e @@ -0,0 +1,252 @@ +~ Output +~ ~~~~~~ +~ +~ It is convenient to be able to output text. This depends on the +~ OS-specific stuff in language/static/linux.e, so it's in its own file. +~ +~ The most interesting word we define here is ".", pronounced "dot"; the +~ math stuff is needed to implement it. +~ +~ Unlike Jonesforth, we do not have a global "base" variable, and this word +~ does not change its behavior depending on that value. It's always base ten. + + +~ Strings are comparatively easy. +~ +~ (string pointer --) +: emitstring dup stringlen 1 3unroll sys-write drop ; + +: space 32 value@ emitstring drop ; +: newline 10 value@ emitstring drop ; + + +~ (base, exponent -- base to the power of exponent) +: pow + 1 swap + + { + ~ If the count of remaining powers is equal to zero, exit. + dup { drop swap drop exit } unless + ~ (base, result so far, count of remaining powers) + + 1 - 3unroll + ~ (updated count of remaining powers, base, result so far) + + swap dup 4 unroll + ~ (base, updated count of remaining powers, result so far, base) + + * swap + ~ (base, updated result so far, updated count of remaining powers) + } forever ; + + +~ (base, value -- floor of logarithm of value in base base) +: logfloor + ~ Start with a product equal to the base, and a count of 0. + swap dup 3unroll 0 + + { + ~ This is the start of the loop body. + ~ (base, value, product so far, count of powers included so far) + 3unroll 2dup + ~ (base, count so far, value, product so far) + + ~ If we get here, we're done. + ~ (base, count so far, value, product so far) + >unsigned { drop drop swap drop exit } if + + ~ If we're here, we need to do another loop. + ~ (base, count so far, value, product so far) + 4 roll dup 5 unroll * 3roll 1 + + ~ (base, value, updated product so far, updated count so far) + + ~ If the product is less than the base, we overflowed. In that case, the + ~ product-so-far is the maximum, so just return it. + 4 roll dup 5 unroll 3roll dup 4 unroll + < { 4 unroll drop drop drop exit } if + + ~ Nothing else weird going on, so loop. + } forever ; + + +~ (base, value -- ceiling of logarithm of value in base base) +: logceil + ~ Start with a product of 1 and a count of 0. + 1 0 + + { + ~ This is the start of the loop body. + ~ (base, value, product so far, count of powers included so far) + 3unroll 2dup + ~ (base, count so far, value, product so far) + + ~ If we get here, we're done. + ~ (base, count so far, value, product so far) + >=unsigned { drop drop swap drop exit } if + + ~ If we're here, we need to do another loop. + ~ (base, count so far, value, product so far) + 4 roll dup 5 unroll * 3roll 1 + + ~ (base, value, updated product so far, updated count so far) + + ~ If the product is less than the base, we overflowed. In that case, the + ~ product-so-far is the maximum, so just return it. + 4 roll dup 5 unroll 3roll dup 4 unroll + < { 4 unroll drop drop drop exit } if + + ~ Nothing else weird going on, so loop. + } forever ; + + +~ This is an extremely inefficient implementation, but on the plus side, +~ doing that avoids having to think about any sort of memory management or +~ recursion, and lets us stick entirely with the trivial control-flow +~ constructs we already have. +~ +~ (integer to print, base to print in, width to zero-pad to --) +: .base-unsigned + ~ (input, base, width) + ~ Compute how many digits we need to display. Because we use logfloor, the + ~ logic of always printing at least one digit is already handled for us. + 3unroll swap 2dup logfloor 1 + + ~ (width, base, input, number of digits if no padding) + 4 roll 2dup > { + ~ (base, input, number of digits if no padding, width) + ~ If we're here, we should use the padded width + swap drop + } { + ~ (base, input, number of digits if no padding, width) + ~ If we're here, we should use the unpadded width + drop + } if-else + + { + ~ (base, input, number of digits remaining) + ~ This is the start of the loop. + 2dup 1 - + ~ (base, input, number of digits remaining, input, intermediate value) + 5 roll dup 6 unroll swap + ~ (base, input, number of digits remaining, input, base, intermediate value) + pow /% swap drop + ~ (base, input, number of digits remaining, + ~ input divided by base^x appropriately) + 4 roll dup 5 unroll + ~ (base, input, number of digits remaining, + ~ input divided by base^x appropriately, base) + /% drop + ~ (base, input, number of digits remaining, current digit) + + ~ We construct a one-character string on the stack, then use a pointer to + ~ it. It will always contain its own null-termination without us having to + ~ do anything special to that end. + dup 10 > { + 0x30 ~ ASCII "0" + } { + 10 - 0x61 ~ ASCII "a" + } if-else + + + value@ emitstring + + ~ We deallocate the string by dropping it. + ~ + ~ Saying it like that makes it sound obvious; contemplate it until it feels + ~ surprising. + drop + + 1 - + dup { drop drop drop exit } unless + } forever ; + + +~ (integer to print, base to print in --) +: .base + swap + ~ (base, input) + + ~ Deal with negative numbers. + dup 0 > { + -1 * + s" -" emitstring + } if + + swap 0 .base-unsigned ; + + +~ Although this could notionally be called emitinteger for symmetry, it's +~ well-known under the name dot and as a single period character, and that +~ name participates in conventions for names of other things. So, we go with +~ it. +~ +~ (integer to print --) +: . 10 .base ; +: .hex 16 0 .base-unsigned ; +: .hex8 16 2 .base-unsigned ; +: .hex16 16 4 .base-unsigned ; +: .hex32 16 8 .base-unsigned ; +: .hex64 16 16 .base-unsigned ; + +~ (integer to print, width --) +: .hexn 16 swap .base-unsigned ; + + + +~ The control structure here is the same as .base-unsigned, but it outputs +~ to a string. +~ +~ The use of the "pack" nomenclature here is a little odd in that most other +~ uses are for binary structures rather than text, but compare packstring. +~ +~ (output point, integer to print, base to print in, width to zero-pad to +~ -- output point) +: pack-base-unsigned + 3unroll swap 2dup logfloor 1 + + 4 roll 2dup > { + swap drop + } { + drop + } if-else + + { + ~ (output point, base, input, number of digits remaining) + 2dup 1 - + 5 roll dup 6 unroll swap + pow /% swap drop + 4 roll dup 5 unroll + /% drop + + dup 10 > { + 0x30 ~ ASCII "0" + } { + 10 - 0x61 ~ ASCII "a" + } if-else + + + ~ (output point, base, input, number of digits remaining, character) + 5 roll swap pack8 4 unroll + + 1 - + dup { drop drop drop exit } unless + } forever ; + + +~ (output point, integer to print, base to print in -- output point) +: pack-base + swap + + dup 0 > { + -1 * + 3roll s" -" packstring 3unroll + } if + + swap 0 .base-unsigned ; + + +~ (output point, integer to print -- output point) +: pack-decimal 10 pack-base ; +: pack-hex 16 0 pack-base-unsigned ; +: pack-hex8 16 2 pack-base-unsigned ; +: pack-hex16 16 4 pack-base-unsigned ; +: pack-hex32 16 8 pack-base-unsigned ; +: pack-hex64 16 16 pack-base-unsigned ; + +~ (output point, integer to print, width -- output point) +: pack-hexn 16 swap pack-base-unsigned ; |