1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
~ 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 ;
|