kernel.lisp (19013 bytes)
1 ;;;; kernel.lisp -- layer 2 builds layer 3: the Forth kernel image for the STM32F446. 2 ;;;; 3 ;;;; Indirect-threaded. r4 = IP, r5 = data stack pointer (full descending, holds the second 4 ;;;; item), r6 = TOS, r7 = W (current xt), sp = return stack. NEXT: ldr r7,[r4],#4; 5 ;;;; ldr r0,[r7]; bx r0. Header: link, flags (80 immediate, 40 hidden), length, name, 6 ;;;; pad to 4, code field, body. Primitives are `defcode` templates (a name plus a Thumb-2 7 ;;;; body, NEXT appended); the high-level kernel is metacompiled from kernel.fs. 8 ;;;; Usage: sbcl --script kernel.lisp OUT.bin 9 10 (load (merge-pathnames "asm.lisp" *load-truename*)) 11 (in-package :thumb) 12 13 ;;; ---------- memory map ---------- 14 (defconstant +sysvars+ #x20000000) ; state base latest dp >in #tib hld nneg 15 (defconstant +tib+ #x20000040) ; 512-byte input buffer 16 (defconstant +padend+ #x200002C0) ; pictured numeric output grows down from here 17 (defconstant +ram-dict+ #x20000300) ; first free RAM for the user dictionary 18 (defconstant +dstop+ #x2001EFE0) ; data stack: 4 KiB below this 19 (defconstant +rstop+ #x2001FFE0) ; return stack: 4 KiB below this (QEMU: keep off the last 32 bytes) 20 (defconstant +dict-limit+ #x2001DEE0) ; dictionary stops 256 bytes above the data stack 21 (defconstant +usart2+ #x40004400) 22 (defparameter *sysvars* '("state" "base" "latest" "dp" ">in" "#tib" "hld" "nneg" "emit-hook")) 23 24 ;;; ---------- dictionary ---------- 25 (defvar *xts* (make-hash-table :test 'equal)) 26 (defvar *defined* (make-hash-table :test 'equal)) 27 (defvar *last-link* nil) 28 (defun xt (name) (or (gethash name *xts*) (setf (gethash name *xts*) (label)))) 29 (defun byte8 (b) (sb-assem:emit-byte *seg* (ldb (byte 8 0) b))) 30 31 (defun header (name &optional (flags 0)) 32 "Lay down a header; return NAME's xt label, marked at the code field." 33 (when (gethash name *defined*) (error "~a defined twice" name)) 34 (align4) 35 (let ((link (mark (label)))) 36 (if *last-link* (abs32 *last-link*) (w32 0)) 37 (setf *last-link* link) 38 (byte8 flags) (byte8 (length name)) 39 (loop for c across name do (byte8 (char-code c))) 40 (align4) 41 (setf (gethash name *defined*) t) 42 (mark (xt name)))) 43 44 (defvar *docol* (label)) (defvar *dovar* (label)) (defvar *docon* (label)) 45 (defun next () (ldr :w :ip 4 :post) (ldr :r0 :w) (bx :r0)) 46 (defun dpush (r) (str :tos :psp -4 :pre) (unless (eql r :tos) (mov :tos r))) 47 (defun dpop (r) (ldr r :psp 4 :post)) 48 49 (defmacro defcode (name (&key (next t) (flags 0)) &body body) 50 `(let ((code (label))) 51 (header ,name ,flags) 52 (abs32 code 1) 53 (mark code) 54 ,@body 55 ,@(when next '((next))))) 56 (defun defconst (name value &optional (addend 0)) 57 "A constant: an integer, or a label's address plus ADDEND." 58 (header name) (abs32 *docon* 1) 59 (if (integerp value) (w32 value) (abs32 value addend))) 60 61 ;;; ---------- primitives ---------- 62 (defun binop (fn) (dpop :r0) (funcall fn :tos :r0 :tos)) 63 (defun flag (c) "TOS = -1 if condition C, else 0 (flags already set)." (movw :tos 0) (it c) (mvn-0 :tos)) 64 (defun cmp2 (c) (dpop :r0) (cmp-reg :r0 :tos) (flag c)) 65 (defun cmp0 (c) (cmp-imm8 :tos 0) (flag c)) 66 (defun store-or (addr value) (li :r1 addr) (ldr :r0 :r1) (li :r2 value) (orr-reg :r0 :r0 :r2) (str :r0 :r1)) 67 68 (defun primitives () 69 (defcode "exit" () (pop1 :ip)) 70 (defcode "lit" () (dpush :tos) (ldr :tos :ip 4 :post)) 71 (defcode "branch" () (ldr :ip :ip)) 72 (defcode "0branch" () (mov :r0 :tos) (dpop :tos) (ldr :r1 :ip 4 :post) (cmp-imm8 :r0 0) (it :eq) (mov :ip :r1)) 73 (defcode "execute" (:next nil) (mov :w :tos) (dpop :tos) (ldr :r0 :w) (bx :r0)) 74 (defcode "(do)" () (ldr :r0 :ip 4 :post) (push1 :r0) (dpop :r1) (push1 :r1) (push1 :tos) (dpop :tos)) 75 (defcode "(?do)" () 76 (let ((go (label)) (done (label))) 77 (ldr :r0 :ip 4 :post) (dpop :r1) (cmp-reg :r1 :tos) (bcc :ne go) 78 (mov :ip :r0) (dpop :tos) (b done) 79 (mark go) (push1 :r0) (push1 :r1) (push1 :tos) (dpop :tos) 80 (mark done))) 81 (defcode "(loop)" () 82 (let ((out (label)) (done (label))) 83 (ldr :r0 :sp) (addw :r0 :r0 1) (ldr :r1 :sp 4) (cmp-reg :r0 :r1) (bcc :eq out) 84 (str :r0 :sp) (ldr :ip :ip) (b done) 85 (mark out) (addw :sp :sp 12) (addw :ip :ip 4) 86 (mark done))) 87 (defcode "(+loop)" () 88 (let ((out (label)) (done (label))) 89 (ldr :r2 :sp) (ldr :r1 :sp 4) (sub-reg :r0 :r2 :r1) (add-reg :r3 :r0 :tos) (add-reg :r2 :r2 :tos) 90 (dpop :tos) (eor-reg :r0 :r0 :r3) (cmp-imm8 :r0 0) (bcc :lt out) 91 (str :r2 :sp) (ldr :ip :ip) (b done) 92 (mark out) (addw :sp :sp 12) (addw :ip :ip 4) 93 (mark done))) 94 (defcode "i" () (dpush :tos) (ldr :tos :sp)) 95 (defcode "j" () (dpush :tos) (ldr :tos :sp 12)) 96 (defcode "unloop" () (addw :sp :sp 12)) 97 (defcode "leave" () (ldr :ip :sp 8) (addw :sp :sp 12)) 98 (defcode "(s\")" () 99 (ldrb :r0 :ip) (addw :r1 :ip 1) (str :tos :psp -4 :pre) (str :r1 :psp -4 :pre) (mov :tos :r0) 100 (add-reg :ip :r1 :r0) (addw :ip :ip 3) (movw :r2 3) (bic-reg :ip :ip :r2)) 101 ;; stack 102 (defcode "dup" () (dpush :tos)) 103 (defcode "drop" () (dpop :tos)) 104 (defcode "swap" () (ldr :r0 :psp) (str :tos :psp) (mov :tos :r0)) 105 (defcode "over" () (ldr :r0 :psp) (dpush :r0)) 106 (defcode "rot" () (ldr :r0 :psp) (ldr :r1 :psp 4) (str :r0 :psp 4) (str :tos :psp) (mov :tos :r1)) 107 (defcode "-rot" () (ldr :r0 :psp) (ldr :r1 :psp 4) (str :tos :psp 4) (str :r1 :psp) (mov :tos :r0)) 108 (defcode "nip" () (addw :psp :psp 4)) 109 (defcode "tuck" () (ldr :r0 :psp) (str :tos :psp) (str :r0 :psp -4 :pre)) 110 (defcode "pick" () (add-reg :r0 :psp :tos :lsl 2) (ldr :tos :r0)) 111 (defcode "?dup" () (cmp-imm8 :tos 0) (it :ne) (str :tos :psp -4 :pre)) 112 (defcode "2dup" () (ldr :r0 :psp) (str :tos :psp -4 :pre) (str :r0 :psp -4 :pre)) 113 (defcode "2drop" () (addw :psp :psp 4) (dpop :tos)) 114 (defcode ">r" () (push1 :tos) (dpop :tos)) 115 (defcode "r>" () (dpush :tos) (pop1 :tos)) 116 (defcode "r@" () (dpush :tos) (ldr :tos :sp)) 117 (defcode "rdrop" () (addw :sp :sp 4)) 118 (defcode "depth" () (li :r0 +dstop+) (sub-reg :r0 :r0 :psp) (mov-shift :r0 :r0 :asr 2) (dpush :r0)) 119 (defcode "sp@" () (dpush :tos) (mov :tos :psp)) 120 (defcode "sp!" () (addw :psp :tos 4) (ldr :tos :tos)) 121 (defcode "rp@" () (dpush :tos) (mov :tos :sp)) 122 (defcode "rp!" () (mov :sp :tos) (dpop :tos)) 123 ;; arithmetic and logic 124 (defcode "+" () (binop #'add-reg)) 125 (defcode "-" () (binop #'sub-reg)) 126 (defcode "*" () (binop #'mul)) 127 (defcode "/" () (binop #'sdiv)) 128 (defcode "mod" () (dpop :r0) (sdiv :r1 :r0 :tos) (mls :tos :r1 :tos :r0)) 129 (defcode "/mod" () (ldr :r0 :psp) (sdiv :r1 :r0 :tos) (mls :r2 :r1 :tos :r0) (str :r2 :psp) (mov :tos :r1)) 130 (defcode "u/mod" () (ldr :r0 :psp) (udiv :r1 :r0 :tos) (mls :r2 :r1 :tos :r0) (str :r2 :psp) (mov :tos :r1)) 131 (defcode "m*" () (ldr :r0 :psp) (smull :r1 :r2 :r0 :tos) (str :r1 :psp) (mov :tos :r2)) 132 (defcode "um*" () (ldr :r0 :psp) (umull :r1 :r2 :r0 :tos) (str :r1 :psp) (mov :tos :r2)) 133 (defcode "negate" () (movw :r0 0) (sub-reg :tos :r0 :tos)) 134 (defcode "abs" () (mov-shift :r0 :tos :asr 31) (eor-reg :tos :tos :r0) (sub-reg :tos :tos :r0)) 135 (defcode "and" () (binop #'and-reg)) 136 (defcode "or" () (binop #'orr-reg)) 137 (defcode "xor" () (binop #'eor-reg)) 138 (defcode "bic" () (dpop :r0) (bic-reg :tos :r0 :tos)) 139 (defcode "invert" () (mvn-reg :tos :tos)) 140 (defcode "lshift" () (dpop :r0) (lsl-reg :tos :r0 :tos)) 141 (defcode "rshift" () (dpop :r0) (lsr-reg :tos :r0 :tos)) 142 (defcode "arshift" () (dpop :r0) (asr-reg :tos :r0 :tos)) 143 (defcode "1+" () (addw :tos :tos 1)) 144 (defcode "1-" () (subw :tos :tos 1)) 145 (defcode "2+" () (addw :tos :tos 2)) 146 (defcode "2-" () (subw :tos :tos 2)) 147 (defcode "2*" () (mov-shift :tos :tos :lsl 1)) 148 (defcode "2/" () (mov-shift :tos :tos :asr 1)) 149 (defcode "cells" () (mov-shift :tos :tos :lsl 2)) 150 (defcode "cell+" () (addw :tos :tos 4)) 151 (defcode "min" () (dpop :r0) (cmp-reg :r0 :tos) (it :lt) (mov :tos :r0)) 152 (defcode "max" () (dpop :r0) (cmp-reg :r0 :tos) (it :gt) (mov :tos :r0)) 153 (defcode "=" () (cmp2 :eq)) (defcode "<>" () (cmp2 :ne)) 154 (defcode "<" () (cmp2 :lt)) (defcode ">" () (cmp2 :gt)) 155 (defcode "<=" () (cmp2 :le)) (defcode ">=" () (cmp2 :ge)) 156 (defcode "u<" () (cmp2 :lo)) (defcode "u>" () (cmp2 :hi)) 157 (defcode "0=" () (cmp0 :eq)) (defcode "0<>" () (cmp0 :ne)) 158 (defcode "0<" () (cmp0 :lt)) (defcode "0>" () (cmp0 :gt)) 159 ;; memory 160 (defcode "@" () (ldr :tos :tos)) 161 (defcode "!" () (dpop :r0) (str :r0 :tos) (dpop :tos)) 162 (defcode "c@" () (ldrb :tos :tos)) 163 (defcode "c!" () (dpop :r0) (strb :r0 :tos) (dpop :tos)) 164 (defcode "h@" () (ldrh :tos :tos)) 165 (defcode "h!" () (dpop :r0) (strh :r0 :tos) (dpop :tos)) 166 (defcode "+!" () (dpop :r0) (ldr :r1 :tos) (add-reg :r1 :r1 :r0) (str :r1 :tos) (dpop :tos)) 167 (defcode "bis!" () (dpop :r0) (ldr :r1 :tos) (orr-reg :r1 :r1 :r0) (str :r1 :tos) (dpop :tos)) 168 (defcode "bic!" () (dpop :r0) (ldr :r1 :tos) (bic-reg :r1 :r1 :r0) (str :r1 :tos) (dpop :tos)) 169 (defcode "cbis!" () (dpop :r0) (ldrb :r1 :tos) (orr-reg :r1 :r1 :r0) (strb :r1 :tos) (dpop :tos)) 170 (defcode "cbic!" () (dpop :r0) (ldrb :r1 :tos) (bic-reg :r1 :r1 :r0) (strb :r1 :tos) (dpop :tos)) 171 (defcode "move" () ; ( src dst n ) overlap-safe 172 (let ((back (label)) (fl (label)) (bl2 (label)) (done (label))) 173 (mov :r2 :tos) (dpop :r1) (dpop :r0) (dpop :tos) 174 (cmp-reg :r0 :r1) (bcc :lo back) 175 (mark fl) (cmp-imm8 :r2 0) (bcc :eq done) 176 (ldrb :r3 :r0 1 :post) (strb :r3 :r1 1 :post) (subw :r2 :r2 1) (b fl) 177 (mark back) (add-reg :r0 :r0 :r2) (add-reg :r1 :r1 :r2) 178 (mark bl2) (cmp-imm8 :r2 0) (bcc :eq done) 179 (ldrb :r3 :r0 -1 :pre) (strb :r3 :r1 -1 :pre) (subw :r2 :r2 1) (b bl2) 180 (mark done))) 181 (defcode "fill" () ; ( addr n c ) 182 (let ((lp (label)) (done (label))) 183 (mov :r1 :tos) (dpop :r2) (dpop :r0) (dpop :tos) 184 (mark lp) (cmp-imm8 :r2 0) (bcc :eq done) 185 (strb :r1 :r0 1 :post) (subw :r2 :r2 1) (b lp) 186 (mark done))) 187 (defcode "compare" () ; ( a1 n1 a2 n2 -- flag ) true if equal bytes 188 (let ((lp (label)) (no (label)) (done (label))) 189 (mov :r3 :tos) (dpop :r2) (dpop :r1) (dpop :r0) (movw :tos 0) 190 (cmp-reg :r1 :r3) (bcc :ne done) 191 (mark lp) (cmp-imm8 :r1 0) (bcc :eq no) 192 (ldrb :r3 :r0 1 :post) (ldrb :r12 :r2 1 :post) (cmp-reg :r3 :r12) (bcc :ne done) 193 (subw :r1 :r1 1) (b lp) 194 (mark no) (mvn-0 :tos) 195 (mark done))) 196 (defcode "count" () (ldrb :r0 :tos 1 :post) (dpush :r0)) 197 ;; single-precision floats on the M4F FPU; a float is its IEEE-754 bit pattern in one cell 198 (flet ((fbin (op) (dpop :r0) (vmov-s-r :s0 :r0) (vmov-s-r :s1 :tos) (funcall op :s0 :s0 :s1) (vmov-r-s :tos :s0)) 199 (fun (op) (vmov-s-r :s0 :tos) (funcall op :s0 :s0) (vmov-r-s :tos :s0)) 200 (fcmp (c) (dpop :r0) (vmov-s-r :s0 :r0) (vmov-s-r :s1 :tos) (vcmp :s0 :s1) (vmrs-apsr) (flag c))) 201 (defcode "f+" () (fbin #'vadd)) 202 (defcode "f-" () (fbin #'vsub)) 203 (defcode "f*" () (fbin #'vmul)) 204 (defcode "f/" () (fbin #'vdiv)) 205 (defcode "s>f" () (fun #'vcvt-f32-s32)) 206 (defcode "f>s" () (fun #'vcvt-s32-f32)) 207 (defcode "fsqrt" () (fun #'vsqrt)) 208 (defcode "f<" () (fcmp :mi)) 209 (defcode "f=" () (fcmp :eq))) 210 ;; console: USART2, polled 211 (defcode "emit" () ; emit-hook = 0: USART2; else execute the hook with c on the stack 212 (let ((wait (label)) (hook (label)) (done (label))) 213 (li :r1 (+ +sysvars+ 32)) (ldr :r1 :r1) (cmp-imm8 :r1 0) (bcc :ne hook) 214 (li :r1 +usart2+) (movw :r2 #x80) 215 (mark wait) (ldr :r0 :r1) (tst-reg :r0 :r2) (bcc :eq wait) 216 (str :tos :r1 4) (dpop :tos) (b done) 217 (mark hook) (mov :w :r1) (ldr :r0 :w) (bx :r0) 218 (mark done))) 219 (defcode "key" () 220 (let ((wait (label))) 221 (li :r1 +usart2+) (movw :r2 #x20) 222 (mark wait) (ldr :r0 :r1) (tst-reg :r0 :r2) (bcc :eq wait) 223 (dpush :tos) (ldr :tos :r1 4) (movw :r2 255) (and-reg :tos :tos :r2))) 224 (defcode "key?" () (li :r1 +usart2+) (ldr :r0 :r1) (movw :r2 #x20) (dpush :tos) (tst-reg :r0 :r2) (flag :ne))) 225 226 (defun runtime-code () 227 "Code fields shared by all colon words, variables and constants." 228 (mark *docol*) (push1 :ip) (addw :ip :w 4) (next) 229 (mark *dovar*) (dpush :tos) (addw :tos :w 4) (next) 230 (mark *docon*) (dpush :tos) (ldr :tos :w 4) (next)) 231 232 (defun reset-code (reset fault cold-thread) 233 (mark reset) 234 (store-or #xE000ED88 #x00F00000) ; CPACR: enable the FPU (CP10, CP11) 235 (store-or #x40023830 1) ; RCC AHB1ENR: GPIOA 236 (store-or #x40023840 (ash 1 17)) ; RCC APB1ENR: USART2 237 (store-or #x40020000 #xA0) ; GPIOA MODER: PA2, PA3 alternate function 238 (store-or #x40020020 #x7700) ; GPIOA AFRL: AF7 = USART2 239 (li :r1 (+ +usart2+ 8)) (movw :r0 #x8B) (str :r0 :r1) ; BRR: 115200 baud at 16 MHz HSI 240 (li :r1 (+ +usart2+ 12)) (movw :r0 #x200C) (str :r0 :r1) ; CR1: UE TE RE 241 (li :r1 +sysvars+) (movw :r0 0) (str :r0 :r1 0) ; state 242 (movw :r0 10) (str :r0 :r1 4) ; base 243 (li :r0 *last-link*) (str :r0 :r1 8) ; latest 244 (li :r0 +ram-dict+) (str :r0 :r1 12) ; dp 245 (movw :r0 0) (str :r0 :r1 32) ; emit-hook: console 246 (li :psp +dstop+) (movw :tos 0) 247 (li :ip cold-thread) (next) 248 (mark fault) ; print FAULT, then system reset 249 (let ((msg (label)) (lp (label)) (wait (label)) (done (label))) 250 (li :r3 msg) (li :r1 +usart2+) (movw :r2 #x80) 251 (mark lp) (ldrb :r0 :r3 1 :post) (cmp-imm8 :r0 0) (bcc :eq done) 252 (mark wait) (ldr :r12 :r1) (tst-reg :r12 :r2) (bcc :eq wait) (str :r0 :r1 4) (b lp) 253 (mark done) (li :r0 #xE000ED0C) (li :r1 #x05FA0004) (str :r1 :r0) (b done) 254 (mark msg) (loop for c across (format nil "~c~%FAULT: reset~%" #\Return) do (byte8 (char-code c))) (byte8 0) 255 (align4))) 256 257 ;;; ---------- metacompiler for kernel.fs ---------- 258 (defun tokenize (text) 259 "Whitespace tokens; \\ and ( ) comments dropped; the text after .\" s\" .( becomes (:string ...)." 260 (let ((toks '()) (i 0) (n (length text))) 261 (flet ((ws (c) (member c '(#\Space #\Tab #\Newline #\Return))) 262 (upto (ch) (let ((e (or (position ch text :start i) n))) (prog1 (subseq text i e) (setf i (min n (1+ e))))))) 263 (loop 264 (loop while (and (< i n) (ws (char text i))) do (incf i)) 265 (when (>= i n) (return)) 266 (let* ((e (or (position-if #'ws text :start i) n)) (tok (subseq text i e))) 267 (setf i e) 268 (cond ((equal (first toks) ":") (push tok toks)) ; a name, even if it looks special 269 ((string= tok "\\") (upto #\Newline)) 270 ((string= tok "(") (upto #\))) 271 ((member tok '(".\"" "s\"") :test #'string=) 272 (incf i) (push tok toks) (push (list :string (upto #\")) toks)) 273 (t (push tok toks))))) 274 (nreverse toks)))) 275 276 (defun parse-num (tok) 277 (let* ((neg (and (> (length tok) 1) (char= (char tok 0) #\-))) (s (if neg (subseq tok 1) tok)) 278 (base 10)) 279 (when (and (> (length s) 1) (char= (char s 0) #\$)) (setf base 16 s (subseq s 1))) 280 (let ((v (ignore-errors (parse-integer s :radix base)))) 281 (and v (if neg (- v) v))))) 282 283 (defun cell (name) (abs32 (xt name))) 284 (defun lit (v) (cell "lit") (if (integerp v) (w32 v) (abs32 v))) 285 286 (defun compile-def (name body) 287 "BODY: tokens between the name and ;. Control structures resolve to labels here." 288 (let ((cs '())) 289 (loop while body do 290 (let ((tok (pop body))) 291 (cond 292 ((consp tok) (error "stray string in ~a" name)) 293 ((string= tok "if") (cell "0branch") (let ((l (label))) (abs32 l) (push l cs))) 294 ((string= tok "else") (cell "branch") (let ((l (label))) (abs32 l) (mark (pop cs)) (push l cs))) 295 ((string= tok "then") (mark (pop cs))) 296 ((string= tok "begin") (push (mark (label)) cs)) 297 ((string= tok "until") (cell "0branch") (abs32 (pop cs))) 298 ((string= tok "again") (cell "branch") (abs32 (pop cs))) 299 ((string= tok "while") (cell "0branch") (let ((l (label)) (dest (pop cs))) (abs32 l) (push l cs) (push dest cs))) 300 ((string= tok "repeat") (cell "branch") (abs32 (pop cs)) (mark (pop cs))) 301 ((member tok '("do" "?do") :test #'string=) 302 (cell (if (string= tok "do") "(do)" "(?do)")) 303 (let ((leave (label))) (abs32 leave) (push leave cs) (push (mark (label)) cs))) 304 ((member tok '("loop" "+loop") :test #'string=) 305 (cell (if (string= tok "loop") "(loop)" "(+loop)")) (abs32 (pop cs)) (mark (pop cs))) 306 ((string= tok "recurse") (cell name)) 307 ((string= tok "[']") (lit (xt (pop body)))) 308 ((string= tok "[char]") (lit (char-code (char (pop body) 0)))) 309 ((member tok '(".\"" "s\"") :test #'string=) 310 (let ((s (second (pop body)))) 311 (cell "(s\")") (byte8 (length s)) (loop for c across s do (byte8 (char-code c))) (align4) 312 (when (string= tok ".\"") (cell "type")))) 313 ((parse-num tok) (lit (parse-num tok))) 314 (t (cell tok))))) 315 (when cs (error "unbalanced control structure in ~a" name)) 316 (cell "exit"))) 317 318 (defun metacompile (path) 319 (let ((toks (with-open-file (s path) (let ((str (make-string (file-length s)))) (tokenize (subseq str 0 (read-sequence str s))))))) 320 (loop while toks do 321 (let ((tok (pop toks))) 322 (unless (equal tok ":") (error "kernel.fs: expected : at ~s" tok)) 323 (let* ((name (pop toks)) (end (position ";" toks :test #'equal)) (body (subseq toks 0 end)) 324 (imm (equal (nth (1+ end) toks) "immediate"))) 325 (setf toks (nthcdr (+ end (if imm 2 1)) toks)) 326 (header name (if imm #x80 0)) 327 (abs32 *docol* 1) 328 (compile-def name body)))))) 329 330 ;;; ---------- image ---------- 331 (defun build (out) 332 (new-segment) 333 (let ((reset (label)) (fault (label)) (cold-thread (label))) 334 (w32 +rstop+) (abs32 reset 1) 335 (dotimes (i 14) (abs32 fault 1)) 336 (runtime-code) 337 (primitives) 338 (loop for name in *sysvars* for i from 0 do (defconst name (+ +sysvars+ (* 4 i)))) 339 (defconst "tib" +tib+) (defconst "padend" +padend+) (defconst "sp0" (- +dstop+ 4)) 340 (defconst "rp0" +rstop+) (defconst "dict-limit" +dict-limit+) 341 (defconst "docol" *docol* 1) (defconst "dovar" *dovar* 1) (defconst "docon" *docon* 1) 342 (metacompile (merge-pathnames "kernel.fs" *load-truename*)) 343 (align4) (mark cold-thread) (cell "cold") 344 (reset-code reset fault cold-thread)) 345 (let ((undefined (loop for k being the hash-keys of *xts* unless (gethash k *defined*) collect k))) 346 (when undefined (error "undefined words: ~{~a~^ ~}" undefined))) 347 (let ((bytes (segment-bytes))) 348 (with-open-file (s out :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) 349 (write-sequence bytes s)) 350 (format t "kernel image: ~d bytes, ~d words~%" (length bytes) (hash-table-count *defined*)))) 351 352 (build (or (second sb-ext:*posix-argv*) "kernel.bin"))