~ 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 ;

~ (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 - ;

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

: L@'
  ' L' entry-to-execution-token execute
  interpreter-flags @ 1 &
    { ' use-label entry-to-execution-token , }
    { use-label } if-else
  ; make-immediate

: L!'
  ' L' entry-to-execution-token execute
  interpreter-flags @ 1 &
    { ' set-label entry-to-execution-token , }
    { set-label } if-else
  ; make-immediate


~ 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 ;