~remexre/stahlos

ref: 7bf2eb256167be5b7093a32d8819707d1bca1286 stahlos/src/kernel-aarch64/init/init.fth -rw-r--r-- 8.0 KiB
7bf2eb25Nathan Ringo ... 2 months ago
                                                                                
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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
CREATE : ] CREATE ] (;) [ ' (:) SET-DOES
CREATE ; ' [ COMPILE, ] (LITERAL) (;) COMPILE, (LITERAL) (:) SET-DOES (;) [ ' (:) SET-DOES IMMEDIATE

: \ 10 PARSE 2DROP ; IMMEDIATE
: ( 41 PARSE 2DROP ; IMMEDIATE
\ woo, comments are now defined!

: NOOP ;
: LITERAL (LITERAL) [ ' (LITERAL) , ] COMPILE, COMPILE, ; IMMEDIATE
: ['] ' [ ' LITERAL COMPILE, ] ; IMMEDIATE
: CONSTANT CREATE ['] (CONSTANT) SET-DOES , ;
: VARIABLE CREATE ['] (VARIABLE) SET-DOES 1 CELLS ALLOT ;
: NIP SWAP DROP ;
: TUCK SWAP OVER ;
: EXIT RDROP ;
: / /MOD NIP ;
: 2* 1 LSHIFT ;
: 2/ 1 RSHIFT ;
: 0< 0 < ;

: CELL+ ( addr -- addr ) 8 + ;
: 1+! ( addr -- ) DUP @ 1+ SWAP ! ;
: 1-! ( addr -- ) DUP @ 1- SWAP ! ;

: CATCH ( i*x xt -- j*x 0 | i*x n )
  \ Save depth (not including XT), flags, and source.
  DEPTH 1- >R FLAGS >R SOURCE >R >R >R
  \ Save previous catch handler.
  PROCESS-TABLE $30 + @ >R
  \ Save previous rstack depth.
  PROCESS-TABLE $38 + @ >R

  \ Install a new handler, whose address is the second part of this word.
  (LITERAL) [ HERE 0 , ] PROCESS-TABLE $30 + !
  \ Save the rdepth.
  RDEPTH PROCESS-TABLE $38 + !

  \ Run the XT and push zero.
  EXECUTE 0

  \ Throw away saved source, flags, and depth.
  R> DROP R> DROP R> DROP R> DROP R> DROP
  \ Restore previous rstack depth.
  R> PROCESS-TABLE $38 + !
  \ Restore previous catch handler.
  R> PROCESS-TABLE $30 + !
  \ Return if we got here normally.
  (;)

  \ The handler for exceptions.
  [ HERE SWAP ! ] PROCESS-TABLE $38 + @ SET-RDEPTH
  \ Restore old state, except depth.
  R> PROCESS-TABLE $38 + !
  R> PROCESS-TABLE $30 + !
  R> R> R> SET-SOURCE R> SET-FLAGS R>
  \ Save the throw code, then restore the depth and throw code.
  SWAP >R SET-DEPTH R> ;

\ TODO(remexre): These should probably have some mechanism for arbitrary-length
\ stacks.
\ An sstack (software stack) has the memory layout:
\ +--------+----------+--------+
\ | Length | Capacity | Items ...
\ +--------+----------+--------+
: SSTACK CREATE 0 , DUP , CELLS ALLOT ;
: SSTACK/LEN ( sstack -- val ) @ ;
: SSTACK/CAP ( sstack -- val ) CELL+ @ ;
: SSTACK/CHECK/NONFULL ( sstack -- ) DUP SSTACK/LEN SWAP SSTACK/CAP = -256 AND THROW ;
: SSTACK/CHECK/NONEMPTY ( sstack -- ) @ NOT -257 AND THROW ;
: SSTACK/UNSAFE/DROP ( sstack -- ) 1-! ;
: SSTACK/UNSAFE/UNDROP ( sstack -- ) 1+! ;
: SSTACK/UNSAFE/TOP-ADDR ( sstack -- addr ) DUP SSTACK/LEN 1+ CELLS + ;
: SSTACK/UNSAFE/PEEK ( sstack -- val ) SSTACK/UNSAFE/TOP-ADDR @ ;
: SSTACK/UNSAFE/SET-TOP ( val sstack -- ) SSTACK/UNSAFE/TOP-ADDR ! ;
: SSTACK/DROP ( sstack -- val ) DUP SSTACK/CHECK/NONEMPTY SSTACK/UNSAFE/DROP ;
: SSTACK/PEEK ( sstack -- val ) DUP SSTACK/CHECK/NONEMPTY SSTACK/UNSAFE/PEEK ;
: SSTACK/POP ( sstack -- val ) DUP SSTACK/PEEK SWAP SSTACK/UNSAFE/DROP ;
: SSTACK/PUSH ( val sstack -- ) DUP SSTACK/CHECK/NONFULL DUP SSTACK/UNSAFE/UNDROP SSTACK/UNSAFE/SET-TOP ;
: SSTACK/1+ ( stack -- ) DUP SSTACK/POP 1+ SWAP SSTACK/PUSH ;
: SSTACK/1- ( stack -- ) DUP SSTACK/POP 1- SWAP SSTACK/PUSH ;

32 SSTACK IF-STACK
: IF ['] (BRANCH0) COMPILE, HERE IF-STACK SSTACK/PUSH 0 COMPILE, ; IMMEDIATE
: ELSE ['] (BRANCH) COMPILE, HERE 0 COMPILE, HERE IF-STACK SSTACK/POP ! IF-STACK SSTACK/PUSH ; IMMEDIATE
: THEN HERE IF-STACK SSTACK/POP ! ; IMMEDIATE

: POSTPONE PARSE-AND-FIND DUP HEADER>XT SWAP HEADER>IMMEDIATE?
  IF COMPILE,
  ELSE [ ' LITERAL COMPILE, ] ['] COMPILE, COMPILE,
  THEN ; IMMEDIATE

32 SSTACK BEGIN-STACK
: BEGIN HERE BEGIN-STACK SSTACK/PUSH ; IMMEDIATE
: AGAIN POSTPONE (BRANCH) BEGIN-STACK SSTACK/POP COMPILE, ; IMMEDIATE
: UNTIL POSTPONE (BRANCH0) BEGIN-STACK SSTACK/POP COMPILE, ; IMMEDIATE
: WHILE
  POSTPONE (BRANCH0) HERE 0 COMPILE,
  BEGIN-STACK SSTACK/POP SWAP BEGIN-STACK SSTACK/PUSH BEGIN-STACK SSTACK/PUSH ; IMMEDIATE
: REPEAT POSTPONE AGAIN HERE BEGIN-STACK SSTACK/POP ! ; IMMEDIATE

64 SSTACK CASE-STACK
: CASE 0 CASE-STACK SSTACK/PUSH ; IMMEDIATE
: OF
  POSTPONE OVER POSTPONE = POSTPONE (BRANCH0)
  HERE CASE-STACK SSTACK/PUSH 0 COMPILE,
  POSTPONE DROP ; IMMEDIATE
: ENDOF
  POSTPONE (BRANCH)
  CASE-STACK SSTACK/POP
  HERE CASE-STACK SSTACK/PUSH 0 COMPILE,
  HERE SWAP ! ; IMMEDIATE
: ENDCASE
  POSTPONE DROP
  BEGIN CASE-STACK SSTACK/POP DUP WHILE HERE SWAP ! REPEAT
  DROP ; IMMEDIATE

\ Notes: At runtime, loop-sys looks like ( R: -- leave limit index )
\ TODO(remexre): Rework this to not be as dynamic (i.e., leave shouldn't be
\ part of loop-sys).
32 SSTACK DO-STACK
: DO
  POSTPONE (LITERAL) HERE 0 COMPILE, DO-STACK SSTACK/PUSH
  POSTPONE >R POSTPONE 2>R HERE DO-STACK SSTACK/PUSH ; IMMEDIATE
: ?DO
  POSTPONE (LITERAL) HERE 0 COMPILE, DO-STACK SSTACK/PUSH
  POSTPONE >R POSTPONE 2DUP POSTPONE =
  POSTPONE IF POSTPONE 2DROP POSTPONE EXIT POSTPONE THEN
  POSTPONE 2>R HERE DO-STACK SSTACK/PUSH ; IMMEDIATE
: UNLOOP R> RDROP RDROP RDROP >R ;
: +LOOP
  POSTPONE 2R> POSTPONE ROT POSTPONE + POSTPONE 2DUP POSTPONE 2>R POSTPONE =
  POSTPONE (BRANCH0) DO-STACK SSTACK/POP COMPILE, POSTPONE UNLOOP HERE DO-STACK SSTACK/POP !
  ; IMMEDIATE
: LOOP POSTPONE (LITERAL) 1 COMPILE, POSTPONE +LOOP ; IMMEDIATE
: I 2R> OVER -ROT 2>R ;
: LEAVE RDROP RDROP RDROP ;

: TO ' CELL+ CELL+ FLAGS 1 AND IF ! ELSE POSTPONE LITERAL POSTPONE ! THEN ; IMMEDIATE
: VALUE CREATE ['] (VALUE) SET-DOES , ;

: 3DROP ( a b c -- ) 2DROP DROP ;
: 3DUP ( a b c -- a b c a b c ) 2DUP 5 PICK -ROT ;
: STR= ( addr1 len1 addr2 len2 -- flag )
  ROT OVER <> IF 3DROP FALSE EXIT THEN
  0 ?DO 2DUP I + C@ SWAP I + C@ <> IF 2DROP FALSE UNLOOP EXIT THEN LOOP 2DROP TRUE ;

: S"
  34 PARSE
  FLAGS 1 AND NOT
  IF SWAP POSTPONE LITERAL POSTPONE LITERAL THEN
  ; IMMEDIATE
: ." POSTPONE S" FLAGS 1 AND NOT IF POSTPONE TYPE ELSE TYPE THEN ; IMMEDIATE
: .( 41 PARSE TYPE CR ; IMMEDIATE

32 CONSTANT BL
: SPACE BL EMIT ;
: SPACES 0 ?DO SPACE LOOP ;
: QUOTE 34 EMIT ;
: .N FLAGS 2 AND IF .HEX ELSE .DECIMAL THEN ;
: . .N SPACE ;
: DECIMAL FLAGS 2 INVERT AND SET-FLAGS ;
: HEX FLAGS 2 OR SET-FLAGS ;

: NYBBLE>HEXCH 15 AND S" 0123456789abcdef" DROP + C@ ;
: C.HEX DUP 4 RSHIFT NYBBLE>HEXCH EMIT NYBBLE>HEXCH EMIT ;
: H.HEX DUP 8 RSHIFT C.HEX C.HEX ;
: W.HEX DUP 16 RSHIFT H.HEX H.HEX ;
: D.HEX DUP 32 RSHIFT W.HEX W.HEX ;

: BTYPE ( addr len -- ) OVER + SWAP ?DO I C@ C.HEX LOOP ;

: .S ." <" DEPTH .DECIMAL ." > " 1 DEPTH ?DO I 1- PICK . -1 +LOOP CR ;
: (DEBUG) ." : " HEX .S BP TODO ;
: DEBUG" POSTPONE ." POSTPONE (DEBUG) ; IMMEDIATE
: DEBUG DEBUG" DEBUG" ;

: COUNT DUP C@ SWAP 1+ SWAP ;
: CTYPE COUNT TYPE ;
: CSTR>STR ( addr -- addr len ) 0 BEGIN 2DUP + C@ WHILE 1+ REPEAT ;
: >BODY 16 + ;
: LATEST PROCESS-TABLE @ ;
: POW2 ( u -- u ) 1 SWAP LSHIFT ;
: ALIGN-DOWN-TO-POW2 ( u b -- u ) POW2 1- INVERT AND ;
: ALIGN-UP-TO-POW2 ( u b -- u ) POW2 1- DUP ROT + SWAP INVERT AND ;
: ALIGNED ( u -- u ) 3 ALIGN-UP-TO-POW2 ;
: WALIGNED ( u -- u ) 2 ALIGN-UP-TO-POW2 ;
: PRINT-WORD-NAME ( word-addr -- ) DUP 10 + SWAP 9 + C@ TYPE SPACE ;
: WORDS ( -- ) LATEST BEGIN DUP WHILE DUP PRINT-WORD-NAME @ REPEAT ;

: (DOES>) R@ CELL+ SET-DOES ;
: DOES> POSTPONE (DOES>) POSTPONE EXIT
  \ Ideally, this inline asm wouldn't be needed... It's the same as in
  \ SET-DOES, though, so I guess I'm fine with it?
  $d63f012058000049 , \ ldr x9, [pc, 8]; blr x9
  ['] (DOES) , ; IMMEDIATE

: (DEFER-ABORT) -259 THROW ;
: DEFER CREATE ['] (DEFER-ABORT) , DOES> @ EXECUTE ;
: DEFER! >BODY ! ;
: IS FLAGS 1 AND IF ' DEFER! ELSE POSTPONE ['] POSTPONE DEFER! THEN ; IMMEDIATE

: ARRAY CREATE DUP , CELLS ALLOT
  DOES> 2DUP @ < NOT IF -260 THROW THEN SWAP CELLS + CELL+ ;

\ A simple bitmap structure, used in the buddy allocator.
\ This has the memory layout:
\ +---------+---------+
\ |  Length | Bitmap ...
\ | (Bytes) |  Data  ...
\ +---------+---------+
: NONAME-BITMAP ( bit-count -- ) ALIGNED 3 RSHIFT DUP , ALLOT ;
: BITMAP ( bit-count -- ) CREATE NONAME-BITMAP ;
: BITMAP/IDX ( idx -- byte-idx bit-idx ) DUP 3 RSHIFT SWAP 7 AND ;
: BITMAP/CHECK ( idx bitmap -- ) SWAP BITMAP/IDX DROP SWAP @ < NOT -261 AND THROW ;
: BITMAP/GET ( idx bitmap -- flag ) 2DUP BITMAP/CHECK
  CELL+ SWAP BITMAP/IDX -ROT + C@ SWAP POW2 AND 0<> ;
: BITMAP/SET ( idx flag bitmap -- ) 3DUP NIP BITMAP/CHECK
  CELL+ ROT BITMAP/IDX
  -ROT + 2DUP C@ SWAP POW2 INVERT AND
  ROT POW2 4 PICK 0<> AND OR SWAP C! DROP ;
: BITMAP/FLIP ( idx bitmap -- ) 2DUP BITMAP/GET NOT SWAP BITMAP/SET ;