path: root/make-hello.e

~ current output point, string pointer
: pack-raw-string
  { unpack8 dup } { 3roll swap pack8 swap } while drop drop ;

: origin 0x08000000 ;

~ Status is a bit field:
~    bit zero is whether it's been used
~    bit one is whether it's been defined
~    bit two is whether it was used before being defined
~    bit three is whether the guessed value wound up equaling the actual value

: init-labels
  8 allocate s" labels" variable
  0 s" labels" find entry-to-execution-token execute !
  ;
~ This needs to happen now because otherwise the word "labels" won't exist.
init-labels

~ (entry pointer --)
: label-heading
  dup entry-to-name dup emitstring space
  stringlen 1+ 54 swap - 0 max indent
  entry-to-execution-token dup 8 + @ .hex64 space @ .hex8
  newline ;

~ (dictionary handle)
: oldest-entry-in
  dup
  dup { { dup @ } { @ } while } if
  dup 3roll = { drop 0 } if
  ;

~ (entry pointer, dictionary handle)
: next-newer-entry-in
  @
  2dup = { 2drop 0 exit } if
  { dup { 2dup @ != } if }
  { @ } while swap drop ;

: list-labels
  labels oldest-entry-in { dup }
  { dup label-heading labels next-newer-entry-in } while drop ;

~ (name string pointer -- )
: new-label labels create-in 0 , 0 , ;

: label-status entry-to-execution-token ;
: label-value entry-to-execution-token 8 + ;

: intern-label
  dup labels swap find-in
  dup { swap drop }
      { drop dup new-label labels swap find-in } if-else ;

: L'
  word value@
  interpreter-flags @ 0x01 &
  { ' litstring entry-to-execution-token ,
    here @ swap packstring 0 pack8 8 packalign here !
    ' intern-label entry-to-execution-token ,
    dropstring }
  { intern-label dropstring-with-result } if-else
  ; make-immediate

~ (label entry pointer -- label value)
: use-label
  ~ If it hasn't been defined yet, mark it used-before-set.
  dup label-status dup @ dup 0x02 & not { 0x04 | swap ! } { drop drop } if-else

  ~ Mark it used. It's faster to just do this than to check if it's needed.
  dup label-status dup @ 0x01 | swap !

  ~ Return the guessed value.
  label-value @ ;
  ;

~ (new label value, label entry pointer --)
: set-label
  ~ We always set the defined bit to true. We leave the other status bits
  ~ as-is, except that we check whether it's unused up to now, and whether
  ~ the previous value equals the new value. If either of those holds, we set
  ~ the guessed-equals-actual bit to true.
  dup label-status @ 0x02 |
  ~ (new value, entry, updated status)
  3unroll dup 4 unroll label-value @ swap dup 3unroll =
  ~ (entry, updated status, new value, equality)
  3roll dup 4 unroll 0x01 & not
  ~ (entry, updated status, new value, equality, unused)
  || { swap 0x08 | swap } if
  ~ (entry, updated status, new value)
  3roll dup 3unroll
  ~ (updated status, entry, new value, entry)
  label-value ! label-status !
  ;

~ (output memory start, current output point
~  -- output memory start, current output point, offset)
: current-offset 2dup swap - ;

~ For a label to have "converged", at least one of the following must be true:
~
~ 1. The label must never have been used (bit zero clear);
~ 2. The label was both used and defined, but not used before it was defined
~    (bits zero and one set; bit two clear);
~ 3. The label was both used and defined, and the guessed value equalled the
~    actual value (bits zero, one, and three set).
~ (label entry pointer)
: check-label-converged
  label-status @
  dup 0x01 & not swap
  dup 0x03 & 0x03 = swap dup 0x04 & not swap 3unroll && swap
  0x0b & 0x0b =
  || || ;

: check-labels-converged
  1
  labels @ { dup }
  { dup check-label-converged 3roll && swap
    @ } while drop ;

: reset-labels
  labels @ { dup }
  { dup label-status 0 swap !
    @ } while drop ;

~ (execution token -- output start, output length)
: label-loop
  0 swap
  0x1000 allocate dup
  ~ (iteration count, execution token, output start, output point)
  { 3 pick 100 > }
  { 2 pick execute 4 roll 1+ 4 unroll
    check-labels-converged
    { 4 roll drop
      3 roll drop
      current-offset swap drop
      exit } if
    drop dup
    reset-labels } while
  drop drop drop ." Failed after " . ."  iterations." newline ;

~ ~~
~ ~~ ELF header
~ ~~
~ ~~   This is the top-level ELF header, for the entire file. An ELF always
~ ~~ has exactly one of this header, which is always at the start of the file.
~ ~~
: elf-file-header
  0x7f pack8 s" ELF" pack-raw-string        ~ magic number
  2 pack8                                   ~ 64-bit
  1 pack8                                   ~ little-endian
  1 pack8                                   ~ ELF header format v1
  0 pack8                                   ~ System-V ABI
  0 pack64                                  ~ (padding)

  2 pack16                                  ~ executable
  0x3e pack16                               ~ Intel x86-64
  1 pack32                                  ~ ELF format version

  ~ Compute the entry pointer.
  ~ origin 0x78 + pack64                      ~ entry point
  L' start use-label origin + pack64
    ~ This includes the origin, intentionally.

  L' program-header use-label pack64
  ~ 0 pack64                                  ~ program header offset
    ~ We place the program header immediately after the ELF header. This
    ~ offset is from the start of the file.
  0 pack64                                  ~ section header offset
  0 pack32                                  ~ processor flags
  64 pack16                                 ~ ELF header size
  56 pack16                                 ~ program header entry size
  1 pack16                                  ~ number of program header entries
  0 pack16                                  ~ section header entry size
  0 pack16                                  ~ number of section header entries
  0 pack16                                  ~ section name string table index
  ;

~ ~~
~ ~~ Program header
~ ~~
~ ~~   An ELF program header consists of any number of these entries; they are
~ ~~ always consecutive, but may be anywhere in the file. We always have
~ ~~ exactly one, and it's always right after the ELF file header.
~ ~~
: elf-program-header
  current-offset L' program-header set-label
  1 pack32                                  ~ "loadable" segment type
  0x05 pack32                               ~ read+execute permission
  0 pack64                                  ~ offset in file
  origin pack64                             ~ virtual address
    ~ required, but can be anything, subject to alignment
  0 pack64                                  ~ physical address (ignored)

  L' total-size use-label pack64            ~ size in file
  L' total-size use-label pack64            ~ size in memory

  0 pack64                                  ~ segment alignment
    ~ for relocation, but this doesn't apply to us
  ;

: output-start-routine
  current-offset L' start set-label
  1 :rax mov-reg64-imm32
  1 :rdi mov-reg64-imm64
  origin L' greeting use-label + :rsi mov-reg64-imm64
  L' greeting-size use-label :rdx mov-reg64-imm64
  syscall
  60 :rax mov-reg64-imm32
  0 :rdi mov-reg64-imm32
  syscall
  ;

: output-greeting
  current-offset dup L' greeting set-label 3unroll
  s" Hello, Irenes!" packstring
  current-offset 4 roll - L' greeting-size set-label ;

~ (output memory start, current output point
~  -- output memory start, current output point)
~
~ Everything directly called by all-contents has this same interface.
~
: all-contents
  elf-file-header
  elf-program-header
  output-start-routine
  output-greeting
  current-offset L' total-size set-label
  ;

~ 0x1000 allocate dup
~ output memory start, current output point

~ all-contents
~ check-labels-converged . newline
~ list-labels reset-labels list-labels

~ The two-pass magick: Reset the output offset to the beginning of the block.
~ drop dup

~ all-contents
~ check-labels-converged . newline
~ list-labels reset-labels list-labels

~ output memory start, current output point
~ over - swap sys-write bye
' all-contents entry-to-execution-token label-loop
swap sys-write bye