commit 2b69c5718183ad48381db24c5cbf362e521eb50a Spenser Truex <truex@equwal.com> 2026-10-04 08:47:28 +0000 Initial import
.github/workflows/ci.yml | 24 ++++ LICENSE | 21 +++ README.md | 76 ++++++++++ asm-test.lisp | 115 +++++++++++++++ asm-tests.txt | 1 + asm.lisp | 202 +++++++++++++++++++++++++++ build-firmware.sh | 9 ++ demo.sh | 13 ++ docs/forth-cheatsheet.txt | 46 ++++++ forth-tests.txt | 74 ++++++++++ kernel-tests.txt | 1 + kernel.fs | 135 ++++++++++++++++++ kernel.lisp | 348 ++++++++++++++++++++++++++++++++++++++++++++++ stm32-forth | 15 ++ stm32-lisp | 20 +++ test.sh | 30 ++++ transcript.txt | 65 +++++++++ 17 files changed, 1195 insertions(+)
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..0183502 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,24 @@ +name: ci +on: [push, pull_request] +jobs: + layers: + # Assembler encodings vs GNU as, then the kernel and the Scheme on QEMU netduinoplus2. + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + with: { path: forthlisp-stm32 } + - uses: actions/checkout@v4 + with: { repository: equwal/forthlisp, path: forthlisp } + - run: sudo apt-get update && sudo apt-get install -y sbcl qemu-system-arm binutils-arm-none-eabi + - run: cd forthlisp-stm32 && sh test.sh + r7rs-suite: + # chibi-scheme's R7RS suite on the emulated chip (about 10 minutes); counts in results.txt. + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + with: { path: forthlisp-stm32 } + - uses: actions/checkout@v4 + with: { repository: equwal/forthlisp, path: forthlisp } + - run: sudo apt-get update && sudo apt-get install -y sbcl qemu-system-arm binutils-arm-none-eabi + - run: cd forthlisp-stm32 && SUITE=1 sh test.sh + - run: head -1 forthlisp/tests/r7rs/results.txt diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..da3111d --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Spenser Truex + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..0c6ee3d --- /dev/null +++ b/README.md @@ -0,0 +1,76 @@ +# forthlisp-stm32 + +A Forth kernel for the STM32F446 (Cortex-M4F, 128 KiB RAM, 512 KiB flash), written from +scratch: a Thumb-2 assembler in SBCL builds it, and the shared Scheme from +[forthlisp](https://github.com/equwal/forthlisp) runs on it. No third-party Forth. + +``` + 4 LISP the Scheme (forthlisp core: lisp.fs, prims.lisp, prelude.scm), loaded through + the kernel's console + 3 FORTH kernel.lisp + kernel.fs: indirect-threaded Forth. Primitives are Thumb-2 + templates; the outer interpreter is Forth, metacompiled by the host + 2 SBCL asm.lisp: Thumb-2 + FPv4-SP encoders on SBCL's sb-assem segments and labels, + with its own fixup pass; kernel.lisp lays out headers and writes the image + 1 ASM Thumb-2 / ARMv7-M, FPv4-SP single-precision floats +``` + +## Quickstart + +```sh +git clone https://github.com/equwal/forthlisp # the core, next to this repo +git clone https://github.com/equwal/forthlisp-stm32 +cd forthlisp-stm32 +./build-firmware.sh # SBCL writes kernel-f446.bin (about 10 KiB) +./stm32-forth # the kernel's own prompt: 1 2 + . -> 3 +./stm32-lisp # Scheme: (+ 1 2) -> 3 +./test.sh # all layers; SUITE=1 also runs the R7RS suite (about 10 minutes) +``` + +Needs SBCL, `qemu-system-arm` (machine `netduinoplus2`), `arm-none-eabi-as` and +`arm-none-eabi-objcopy`, and `nc`. Override the tools with `SBCL`, `QEMU`, `ARM_AS`, +`ARM_OBJCOPY`, `NC`, `STTY`. `PORT` picks the TCP port of the emulated console. + +A real board takes the image with `st-flash write kernel-f446.bin 0x8000000`. + +## Board and emulation + +- QEMU has no F446 board. `netduinoplus2` (STM32F405) is the closest. The kernel uses only + what the F446 has: RAM ends at `0x20020000`, and the image fits in 512 KiB of flash. +- The console is USART2 at 115200 baud from the 16 MHz HSI. It is QEMU's second `-serial`. +- QEMU breaks on writes to the last 32 bytes of RAM, so the stacks stop short of them. +- QEMU does not model the F4 flash controller, so words compile to RAM. + +## Memory map and registers + +- Flash `0x08000000`: vector table, primitives, kernel headers and threads. +- RAM `0x20000000`: system variables, the 512-byte input buffer, then the dictionary. +- Data stack: 4 KiB below `0x2001EFE0`. Return stack (`sp`): 4 KiB below `0x2001FFE0`. +- r4 = IP, r5 = data stack pointer, r6 = top of stack, r7 = W. + NEXT is `ldr r7,[r4],#4; ldr r0,[r7]; bx r0`. + +## Tests, in layer order + +| Layer | Test | Result file | At publication | +|---|---|---|---| +| 1-2 | `asm-test.lisp`: every encoder form byte-identical to GNU as | `asm-tests.txt` | 105/105 | +| 3 | `forth-tests.txt`: kernel words over the serial console | `kernel-tests.txt` | 71/71 | +| 4 | the core's `r7rs-tests.scm` | core `conformance.txt` | 297/297 | +| 4 | chibi-scheme's R7RS suite | core `tests/r7rs/results.txt` | 486 pass / 123 fail / 523 skip | + +## Limits + +- 23.5 KiB RAM stays free after the Scheme loads. The cons heap is 48 KiB, the blob heap + 16 KiB. +- Floats are single precision. +- A runtime `flash!` is not written yet, because QEMU cannot test it. + +## Influences + +- Paul Khuong, "SBCL: the ultimate assembly code breadboard" + (https://pvk.ca/Blog/2014/03/15/sbcl-the-ultimate-assembly-code-breadboard/) +- Ron Garret, gll-mag-patch (https://github.com/rongarret/gll-mag-patch) +- Ron Garret, "Lisping at JPL" (https://flownet.com/gat/jpl-lisp.html) + +## Licence + +MIT (see `LICENSE`). diff --git a/asm-test.lisp b/asm-test.lisp new file mode 100644 index 0000000..bc46863 --- /dev/null +++ b/asm-test.lisp @@ -0,0 +1,115 @@ +;;;; asm-test.lisp -- layer 2 tests: every encoder form, byte-identical to arm-none-eabi-as. +;;;; Run: sbcl --script asm-test.lisp (needs arm-none-eabi-as and -objcopy on PATH, or ARM_AS / ARM_OBJCOPY) + +(load (merge-pathnames "asm.lisp" *load-truename*)) +(in-package :thumb) + +(defparameter *cases* + ;; (lisp form . gas text); (:label NAME) defines a label both sides. + '(((nop) . "nop") + ((bx :r0) . "bx r0") ((blx :r3) . "blx r3") + ((mov :r4 :r1) . "mov r4, r1") ((mov :r8 :r6) . "mov r8, r6") ((mov :r6 :sp) . "mov r6, sp") + ((cmp-imm8 :r6 0) . "cmp r6, #0") ((cmp-imm8 :r2 200) . "cmp r2, #200") + ((it :eq) . "it eq") ((mov :r4 :r1) . "moveq r4, r1") + ((it :ne) . "it ne") ((mov :r4 :r1) . "movne r4, r1") + ((it :lt) . "it lt") ((mvn-0 :r6) . "mvnlt.w r6, #0") + ((it :eq :e) . "ite eq") ((mov :r0 :r1) . "moveq r0, r1") ((mov :r0 :r2) . "movne r0, r2") + ((it :mi :tt) . "ittt mi") ((nop) . "nopmi") ((nop) . "nopmi") ((nop) . "nopmi") + ((ldr :r7 :r4 4 :post) . "ldr.w r7, [r4], #4") ((ldr :r0 :r7) . "ldr.w r0, [r7]") + ((ldr :r6 :r5 4 :post) . "ldr.w r6, [r5], #4") ((str :r6 :r5 -4 :pre) . "str.w r6, [r5, #-4]!") + ((ldr :r1 :r2 100) . "ldr.w r1, [r2, #100]") ((str :r3 :r9 4095) . "str.w r3, [r9, #4095]") + ((ldr :r0 :r1 -8) . "ldr.w r0, [r1, #-8]") ((push1 :r4) . "str.w r4, [sp, #-4]!") ((pop1 :r4) . "ldr.w r4, [sp], #4") + ((ldrb :r6 :r6) . "ldrb.w r6, [r6]") ((strb :r0 :r6) . "strb.w r0, [r6]") ((ldrb :r1 :r4 1 :post) . "ldrb.w r1, [r4], #1") + ((ldrh :r6 :r6) . "ldrh.w r6, [r6]") ((strh :r0 :r6 2) . "strh.w r0, [r6, #2]") + ((ldrsb :r1 :r2) . "ldrsb.w r1, [r2]") ((ldrsh :r1 :r2) . "ldrsh.w r1, [r2]") + ((add-reg :r6 :r6 :r0) . "add.w r6, r6, r0") ((sub-reg :r6 :r0 :r6) . "sub.w r6, r0, r6") + ((rsb-reg :r6 :r6 :r0) . "rsb r6, r6, r0") ((and-reg :r6 :r6 :r0) . "and.w r6, r6, r0") + ((orr-reg :r6 :r6 :r0) . "orr.w r6, r6, r0") ((eor-reg :r6 :r6 :r0) . "eor.w r6, r6, r0") + ((bic-reg :r6 :r0 :r6) . "bic.w r6, r0, r6") ((orn-reg :r1 :r2 :r3) . "orn r1, r2, r3") + ((add-reg :r4 :r4 :r1 :lsl 2) . "add.w r4, r4, r1, lsl #2") + ((adc-reg :r1 :r2 :r3) . "adc.w r1, r2, r3") ((sbc-reg :r1 :r2 :r3) . "sbc.w r1, r2, r3") + ((adds-reg :r1 :r2 :r3) . "adds.w r1, r2, r3") ((subs-reg :r1 :r2 :r3) . "subs.w r1, r2, r3") + ((mov-shift :r6 :r6 :lsl 2) . "lsl.w r6, r6, #2") ((mov-shift :r6 :r6 :asr 1) . "asr.w r6, r6, #1") + ((mov-shift :r6 :r6 :lsr 31) . "lsr.w r6, r6, #31") ((mov-shift :r1 :r2 :asr 32) . "asr.w r1, r2, #32") + ((mvn-reg :r6 :r6) . "mvn.w r6, r6") ((cmp-reg :r0 :r6) . "cmp.w r0, r6") ((tst-reg :r0 :r6) . "tst.w r0, r6") + ((lsl-reg :r6 :r0 :r6) . "lsl.w r6, r0, r6") ((lsr-reg :r6 :r0 :r6) . "lsr.w r6, r0, r6") + ((asr-reg :r6 :r0 :r6) . "asr.w r6, r0, r6") + ((addw :r6 :r6 1) . "addw r6, r6, #1") ((subw :r6 :r6 4095) . "subw r6, r6, #4095") + ((addw :r4 :r7 4) . "addw r4, r7, #4") + ((movw :r6 0) . "movw r6, #0") ((movw :r0 #xBEEF) . "movw r0, #0xbeef") ((movt :r0 #x2001) . "movt r0, #0x2001") + ((li :r1 #x4000440C) . "movw r1, #0x440c + movt r1, #0x4000") + ((mul :r6 :r6 :r0) . "mul r6, r6, r0") ((mls :r6 :r0 :r6 :r1) . "mls r6, r0, r6, r1") + ((sdiv :r6 :r0 :r6) . "sdiv r6, r0, r6") ((udiv :r6 :r0 :r6) . "udiv r6, r0, r6") + ((smull :r0 :r6 :r0 :r6) . "smull r0, r6, r0, r6") ((umull :r0 :r1 :r2 :r3) . "umull r0, r1, r2, r3") + ((clz :r0 :r1) . "clz r0, r1") + ((vadd :s0 :s0 :s1) . "vadd.f32 s0, s0, s1") ((vadd :s3 :s14 :s31) . "vadd.f32 s3, s14, s31") + ((vsub :s0 :s0 :s1) . "vsub.f32 s0, s0, s1") ((vsub :s5 :s2 :s9) . "vsub.f32 s5, s2, s9") + ((vmul :s0 :s0 :s1) . "vmul.f32 s0, s0, s1") ((vdiv :s0 :s0 :s1) . "vdiv.f32 s0, s0, s1") + ((vdiv :s17 :s8 :s3) . "vdiv.f32 s17, s8, s3") + ((vcvt-f32-s32 :s0 :s0) . "vcvt.f32.s32 s0, s0") ((vcvt-f32-s32 :s1 :s2) . "vcvt.f32.s32 s1, s2") + ((vcvt-s32-f32 :s0 :s0) . "vcvt.s32.f32 s0, s0") ((vcvt-s32-f32 :s3 :s4) . "vcvt.s32.f32 s3, s4") + ((vsqrt :s0 :s0) . "vsqrt.f32 s0, s0") ((vsqrt :s7 :s30) . "vsqrt.f32 s7, s30") + ((vcmp :s0 :s1) . "vcmp.f32 s0, s1") ((vcmp :s9 :s2) . "vcmp.f32 s9, s2") ((vmrs-apsr) . "vmrs APSR_nzcv, fpscr") + ((vmov-s-r :s0 :r0) . "vmov s0, r0") ((vmov-s-r :s1 :r6) . "vmov s1, r6") ((vmov-s-r :s13 :r2) . "vmov s13, r2") + ((vmov-r-s :r6 :s0) . "vmov r6, s0") ((vmov-r-s :r1 :s9) . "vmov r1, s9") + ((:label "back") . "back:") + ((b "fwd") . "b.w fwd") ((bl "fwd") . "bl fwd") ((bcc :eq "fwd") . "beq.w fwd") ((bcc :ne "back") . "bne.w back") + ((b "back") . "b.w back") ((bl "back") . "bl back") ((bcc :ge "back") . "bge.w back") + ((nop) . "nop") + ((:label "fwd") . "fwd:") + ((nop) . "nop"))) + +(defun run-lisp () + (new-segment) + (let ((labels (make-hash-table :test 'equal)) (ranges '())) + (flet ((lab (n) (or (gethash n labels) (setf (gethash n labels) (label))))) + (dolist (c *cases*) + (let ((f (car c)) (start (here))) + (if (eq (car f) :label) + (mark (lab (second f))) + (apply (car f) (mapcar (lambda (a) (if (stringp a) (lab a) a)) (cdr f)))) + (push (list start (here) (cdr c)) ranges)))) + (values (segment-bytes) (nreverse ranges)))) + +(defun run-gas () + (let ((as (or (sb-ext:posix-getenv "ARM_AS") "arm-none-eabi-as")) + (objcopy (or (sb-ext:posix-getenv "ARM_OBJCOPY") "arm-none-eabi-objcopy"))) + (with-open-file (s "/tmp/asm-test.s" :direction :output :if-exists :supersede) + (format s ".syntax unified~%.thumb~%.cpu cortex-m4~%.fpu fpv4-sp-d16~%") + (dolist (c *cases*) (format s " ~a~%" (cdr c)))) + (assert (zerop (sb-ext:process-exit-code + (sb-ext:run-program as '("/tmp/asm-test.s" "-o" "/tmp/asm-test.o") + :search t :output t :error t)))) + (sb-ext:run-program objcopy '("-O" "binary" "-j" ".text" "/tmp/asm-test.o" "/tmp/asm-test.bin") + :search t :output t :error t) + (with-open-file (s "/tmp/asm-test.bin" :element-type '(unsigned-byte 8)) + (let ((v (make-array (file-length s) :element-type '(unsigned-byte 8)))) (read-sequence v s) v)))) + +(defun repeated-refs-ok () + "Regression: sb-assem emit-back-patch resolved only the first of adjacent references." + (new-segment) + (let ((a (label))) + (abs32 a) (abs32 a) (li :r4 a) (li :r4 a) (b a) (b a) (mark a) (nop)) + (let ((v (segment-bytes))) + (and (equalp (subseq v 0 4) (subseq v 4 8)) (plusp (aref v 3)) + (equalp (subseq v 8 16) (subseq v 16 24)) (plusp (aref v 8)) + (= (aref v 27) #xB8) (= (aref v 31) #xB8)))) ; both b.w: hw2 = B8xx (9000 | J1 J2 set) + +(multiple-value-bind (mine ranges) (run-lisp) + (let ((gas (run-gas)) (fail 0) (n 0)) + (dolist (r ranges) + (destructuring-bind (a z text) r + (unless (= a z) + (incf n) + (let ((m (subseq mine a z)) (g (subseq gas a (min z (length gas))))) + (unless (equalp m g) + (incf fail) + (format t "FAIL ~a: mine ~{~2,'0x~^ ~} gas ~{~2,'0x~^ ~}~%" + (substitute #\Space #\Newline text) (coerce m 'list) (coerce g 'list))))))) + (incf n) + (unless (repeated-refs-ok) (incf fail) (format t "FAIL repeated references to one label~%")) + (unless (= (length mine) (length gas)) + (incf fail) (format t "FAIL total length mine ~d gas ~d~%" (length mine) (length gas))) + (format t "asm-test: ~d forms, ~d failed~%" n fail) + (sb-ext:exit :code (if (zerop fail) 0 1)))) diff --git a/asm-tests.txt b/asm-tests.txt new file mode 100644 index 0000000..e7dd291 --- /dev/null +++ b/asm-tests.txt @@ -0,0 +1 @@ +asm-test: 105 forms, 0 failed diff --git a/asm.lisp b/asm.lisp new file mode 100644 index 0000000..52f043e --- /dev/null +++ b/asm.lisp @@ -0,0 +1,202 @@ +;;;; asm.lisp -- layer 2: a Thumb-2 (ARMv7-M + FPv4-SP) assembler on SBCL's sb-assem. +;;;; +;;;; sb-assem supplies the ISA-neutral parts: segments and labels; `fixup` resolves references. The encoders +;;;; below are plain functions, one per instruction form, that emit little-endian halfwords +;;;; into *seg*. asm-test.lisp checks every form against arm-none-eabi-as byte for byte. + +(defpackage :thumb (:use :cl) + (:export #:*seg* #:*base* #:new-segment #:segment-bytes #:here #:label #:mark #:label-address + #:h16 #:w32 #:abs32 #:align4 #:reg)) +(in-package :thumb) + +(defvar *seg*) +(defvar *base* #x08000000 "Address of segment position 0.") +(defvar *fixups* '() "(position size function): bytes computed after all labels are placed.") + +(defun new-segment () (setf *fixups* '() *seg* (sb-assem:make-segment))) +(defun fixup (size fn) + "Reserve SIZE bytes; segment-bytes later calls (FN position) to emit them with labels known. +sb-assem's emit-back-patch resolved only the first of several patches in a row here (SBCL +2.6.9), so label references go through this list instead." + (push (list (sb-assem::segment-current-posn *seg*) size fn) *fixups*) + (dotimes (i size) (sb-assem:emit-byte *seg* 0))) +(defun segment-bytes () + (sb-assem:finalize-segment *seg*) + (let ((v (copy-seq (coerce (sb-assem:segment-contents-as-vector *seg*) '(simple-array (unsigned-byte 8) (*))))) + (main *seg*)) + (unwind-protect + (dolist (f *fixups* v) + (destructuring-bind (posn size fn) f + (setf *seg* (sb-assem:make-segment)) + (funcall fn posn) + (sb-assem:finalize-segment *seg*) + (let ((bytes (sb-assem:segment-contents-as-vector *seg*))) + (assert (= (length bytes) size) () "fixup at ~d wrote ~d bytes, not ~d" posn (length bytes) size) + (replace v bytes :start1 posn)))) + (setf *seg* main)))) +(defun here () (sb-assem::segment-current-posn *seg*)) +(defun label () (sb-assem:gen-label)) +(defun mark (l) (sb-assem::%emit-label *seg* nil l) l) +(defun label-address (l) (+ *base* (sb-assem:label-position l))) + +(defun h16 (h) (sb-assem:emit-byte *seg* (ldb (byte 8 0) h)) (sb-assem:emit-byte *seg* (ldb (byte 8 8) h))) +(defun w32 (w) (h16 (ldb (byte 16 0) w)) (h16 (ldb (byte 16 16) w))) +(defun h32 (hw1 hw2) (h16 hw1) (h16 hw2)) +(defun align4 () (loop until (zerop (mod (here) 4)) do (sb-assem:emit-byte *seg* 0))) + +(defun abs32 (l &optional (addend 0)) + "A 32-bit cell holding label L's absolute address plus ADDEND (resolved at finalize)." + (fixup 4 (lambda (posn) (declare (ignore posn)) (w32 (+ (label-address l) addend))))) + +;;; ---------- operands ---------- + +(defun reg (r) + (let ((n (case r (:sp 13) (:lr 14) (:pc 15) (:ip 4) (:psp 5) (:tos 6) (:w 7) + (t (if (and (symbolp r) (char= (char (symbol-name r) 0) #\R)) + (parse-integer (symbol-name r) :start 1) + r))))) + (assert (and (integerp n) (<= 0 n 15)) () "bad register ~s" r) + n)) +(defun sreg (s) (let ((n (parse-integer (symbol-name s) :start 1))) (assert (<= 0 n 31)) n)) + +(defparameter *conds* '(:eq 0 :ne 1 :cs 2 :hs 2 :cc 3 :lo 3 :mi 4 :pl 5 :vs 6 :vc 7 + :hi 8 :ls 9 :ge 10 :lt 11 :gt 12 :le 13 :al 14)) +(defun cnd (c) (or (getf *conds* c) (error "bad condition ~s" c))) + +;;; ---------- 16-bit forms ---------- + +(defun nop () (h16 #xBF00)) +(defun bx (rm) (h16 (logior #x4700 (ash (reg rm) 3)))) +(defun blx (rm) (h16 (logior #x4780 (ash (reg rm) 3)))) +(defun mov (rd rm) "MOV Rd,Rm (T1, any registers, flags unchanged)." + (let ((d (reg rd))) (h16 (logior #x4600 (ash (ldb (byte 1 3) d) 7) (ash (reg rm) 3) (ldb (byte 3 0) d))))) +(defun it (c &optional (pattern "")) "IT block: PATTERN (string or keyword) of T/E for the 2nd..4th instructions." + (let* ((pattern (string pattern)) (fc (cnd c)) (bit0 (ldb (byte 1 0) fc)) (mask 0) (n (length pattern))) + (loop for ch across pattern for i downfrom 3 + do (setf (ldb (byte 1 i) mask) (if (char-equal ch #\T) bit0 (- 1 bit0)))) + (setf (ldb (byte 1 (- 3 n)) mask) 1) + (h16 (logior #xBF00 (ash fc 4) mask)))) +(defun cmp-imm8 (rn imm) (assert (and (< (reg rn) 8) (<= 0 imm 255))) (h16 (logior #x2800 (ash (reg rn) 8) imm))) + +;;; ---------- loads and stores ---------- + +(defun mem12 (op rt rn off) + (assert (<= 0 off 4095)) + (h32 (logior op (reg rn)) (logior (ash (reg rt) 12) off))) +(defun mem8 (op rt rn off mode) + "T4 form. MODE :pre (pre-index with writeback), :post (post-index), :neg (offset, no writeback)." + (let ((u (if (minusp off) 0 1)) (a (abs off))) + (assert (<= a 255)) + (multiple-value-bind (p w) (ecase mode (:pre (values 1 1)) (:post (values 0 1)) (:neg (values 1 0))) + (h32 (logior op (reg rn)) + (logior (ash (reg rt) 12) #x800 (ash p 10) (ash u 9) (ash w 8) a))))) +(macrolet ((def (name op12 op8) + `(defun ,name (rt rn &optional (off 0) mode) + (if (and (null mode) (<= 0 off 4095)) + (mem12 ,op12 rt rn off) + (mem8 ,op8 rt rn off (or mode :neg)))))) + (def ldr #xF8D0 #xF850) (def str #xF8C0 #xF840) + (def ldrb #xF890 #xF810) (def strb #xF880 #xF800) + (def ldrh #xF8B0 #xF830) (def strh #xF8A0 #xF820) + (def ldrsb #xF990 #xF910) (def ldrsh #xF9B0 #xF930)) +(defun push1 (r) (str r :sp -4 :pre)) +(defun pop1 (r) (ldr r :sp 4 :post)) + +;;; ---------- data processing ---------- + +(defparameter *shift-types* '(:lsl 0 :lsr 1 :asr 2 :ror 3)) +(defun dp-reg (op rd rn rm &optional (shift :lsl) (amount 0) s) + "Data processing, shifted register (T2/T3 32-bit forms)." + (let ((amt (if (and (member shift '(:lsr :asr)) (= amount 32)) 0 amount))) + (assert (<= 0 amt 31)) + (h32 (logior op (if s #x10 0) (reg rn)) + (logior (ash (ldb (byte 3 2) amt) 12) (ash (reg rd) 8) (ash (ldb (byte 2 0) amt) 6) + (ash (getf *shift-types* shift) 4) (reg rm))))) +(macrolet ((def (name op) + `(defun ,name (rd rn rm &optional (shift :lsl) (amount 0) s) (dp-reg ,op rd rn rm shift amount s)))) + (def and-reg #xEA00) (def bic-reg #xEA20) (def orr-reg #xEA40) (def orn-reg #xEA60) + (def eor-reg #xEA80) (def add-reg #xEB00) (def adc-reg #xEB40) (def sbc-reg #xEB60) + (def sub-reg #xEBA0) (def rsb-reg #xEBC0)) +(defun adds-reg (rd rn rm) (dp-reg #xEB00 rd rn rm :lsl 0 t)) +(defun subs-reg (rd rn rm) (dp-reg #xEBA0 rd rn rm :lsl 0 t)) +(defun mov-shift (rd rm shift amount) (dp-reg #xEA40 rd 15 rm shift amount)) +(defun mvn-reg (rd rm) (dp-reg #xEA60 rd 15 rm)) +(defun cmp-reg (rn rm) (dp-reg #xEBA0 15 rn rm :lsl 0 t)) +(defun tst-reg (rn rm) (dp-reg #xEA00 15 rn rm :lsl 0 t)) +(defun shift-reg (op rd rn rm) (h32 (logior op (reg rn)) (logior #xF000 (ash (reg rd) 8) (reg rm)))) +(defun lsl-reg (rd rn rm) (shift-reg #xFA00 rd rn rm)) +(defun lsr-reg (rd rn rm) (shift-reg #xFA20 rd rn rm)) +(defun asr-reg (rd rn rm) (shift-reg #xFA40 rd rn rm)) + +(defun imm12-form (op rd rn imm) + (assert (<= 0 imm 4095)) + (h32 (logior op (ash (ldb (byte 1 11) imm) 10) (reg rn)) + (logior (ash (ldb (byte 3 8) imm) 12) (ash (reg rd) 8) (ldb (byte 8 0) imm)))) +(defun addw (rd rn imm) (imm12-form #xF200 rd rn imm)) +(defun subw (rd rn imm) (imm12-form #xF2A0 rd rn imm)) +(defun mov16-form (op rd imm) + (assert (<= 0 imm #xFFFF)) + (h32 (logior op (ash (ldb (byte 1 11) imm) 10) (ldb (byte 4 12) imm)) + (logior (ash (ldb (byte 3 8) imm) 12) (ash (reg rd) 8) (ldb (byte 8 0) imm)))) +(defun movw (rd imm) (mov16-form #xF240 rd imm)) +(defun movt (rd imm) (mov16-form #xF2C0 rd imm)) +(defun li (rd value) + "Load a 32-bit constant, or a label's absolute address, with MOVW (+ MOVT)." + (if (integerp value) + (let ((v (ldb (byte 32 0) value))) + (movw rd (ldb (byte 16 0) v)) + (unless (zerop (ldb (byte 16 16) v)) (movt rd (ldb (byte 16 16) v)))) + (fixup 8 (lambda (posn) (declare (ignore posn)) + (let ((v (label-address value))) + (movw rd (ldb (byte 16 0) v)) (movt rd (ldb (byte 16 16) v))))))) +(defun mvn-0 (rd) "MVN.W Rd,#0, i.e. Rd = -1." (h32 #xF06F (ash (reg rd) 8))) +(defun mul (rd rn rm) (h32 (logior #xFB00 (reg rn)) (logior #xF000 (ash (reg rd) 8) (reg rm)))) +(defun mls (rd rn rm ra) "Rd = Ra - Rn*Rm" (h32 (logior #xFB00 (reg rn)) (logior (ash (reg ra) 12) (ash (reg rd) 8) #x10 (reg rm)))) +(defun sdiv (rd rn rm) (h32 (logior #xFB90 (reg rn)) (logior #xF0F0 (ash (reg rd) 8) (reg rm)))) +(defun udiv (rd rn rm) (h32 (logior #xFBB0 (reg rn)) (logior #xF0F0 (ash (reg rd) 8) (reg rm)))) +(defun smull (lo hi rn rm) (h32 (logior #xFB80 (reg rn)) (logior (ash (reg lo) 12) (ash (reg hi) 8) (reg rm)))) +(defun umull (lo hi rn rm) (h32 (logior #xFBA0 (reg rn)) (logior (ash (reg lo) 12) (ash (reg hi) 8) (reg rm)))) +(defun clz (rd rm) (h32 (logior #xFAB0 (reg rm)) (logior #xF080 (ash (reg rd) 8) (reg rm)))) + +;;; ---------- branches ---------- + +(defun branch-patch (target encode) + (fixup 4 (lambda (posn) (funcall encode (- (sb-assem:label-position target) (+ posn 4)))))) +(defun enc-b-t4 (off link) + (assert (and (evenp off) (<= (- (ash 1 24)) off (1- (ash 1 24)))) () "branch out of range") + (let* ((s (ldb (byte 1 24) off)) (i1 (ldb (byte 1 23) off)) (i2 (ldb (byte 1 22) off)) + (j1 (logxor 1 i1 s)) (j2 (logxor 1 i2 s))) + (h32 (logior #xF000 (ash s 10) (ldb (byte 10 12) off)) + (logior (if link #xD000 #x9000) (ash j1 13) (ash j2 11) (ldb (byte 11 1) off))))) +(defun enc-bcond-t3 (c off) + (assert (and (evenp off) (<= (- (ash 1 20)) off (1- (ash 1 20)))) () "conditional branch out of range") + (h32 (logior #xF000 (ash (ldb (byte 1 20) off) 10) (ash (cnd c) 6) (ldb (byte 6 12) off)) + (logior #x8000 (ash (ldb (byte 1 18) off) 13) (ash (ldb (byte 1 19) off) 11) (ldb (byte 11 1) off)))) +(defun b (target) (branch-patch target (lambda (off) (enc-b-t4 off nil)))) +(defun bl (target) (branch-patch target (lambda (off) (enc-b-t4 off t)))) +(defun bcc (c target) (branch-patch target (lambda (off) (enc-bcond-t3 c off)))) +;;; ---------- FPv4-SP (single-precision VFP) ---------- + +(defun sreg (s) (let ((n (parse-integer (symbol-name s) :start 1))) (assert (<= 0 n 31)) n)) +(defun vfp-dnm (op1 op2 sd sn sm) + "Three-register VFP data processing: OP1/OP2 are the fixed bits of hw1/hw2." + (let ((d (sreg sd)) (n (sreg sn)) (m (sreg sm))) + (h32 (logior op1 (ash (ldb (byte 1 0) d) 6) (ash n -1)) + (logior op2 (ash (ash d -1) 12) (ash (ldb (byte 1 0) n) 7) (ash (ldb (byte 1 0) m) 5) (ash m -1))))) +(defun vadd (sd sn sm) (vfp-dnm #xEE30 #x0A00 sd sn sm)) +(defun vsub (sd sn sm) (vfp-dnm #xEE30 #x0A40 sd sn sm)) +(defun vmul (sd sn sm) (vfp-dnm #xEE20 #x0A00 sd sn sm)) +(defun vdiv (sd sn sm) (vfp-dnm #xEE80 #x0A00 sd sn sm)) +(defun vfp-dm (op1 op2 sd sm) + (let ((d (sreg sd)) (m (sreg sm))) + (h32 (logior op1 (ash (ldb (byte 1 0) d) 6)) + (logior op2 (ash (ash d -1) 12) (ash (ldb (byte 1 0) m) 5) (ash m -1))))) +(defun vcvt-f32-s32 (sd sm) (vfp-dm #xEEB8 #x0AC0 sd sm)) +(defun vcvt-s32-f32 (sd sm) "Round toward zero." (vfp-dm #xEEBD #x0AC0 sd sm)) +(defun vsqrt (sd sm) (vfp-dm #xEEB1 #x0AC0 sd sm)) +(defun vcmp (sd sm) (vfp-dm #xEEB4 #x0A40 sd sm)) +(defun vmrs-apsr () "VMRS APSR_nzcv, FPSCR" (h32 #xEEF1 #xFA10)) +(defun vmov-s-r (sn rt) "VMOV Sn, Rt" + (let ((n (sreg sn))) (h32 (logior #xEE00 (ash n -1)) (logior (ash (reg rt) 12) #x0A10 (ash (ldb (byte 1 0) n) 7))))) +(defun vmov-r-s (rt sn) "VMOV Rt, Sn" + (let ((n (sreg sn))) (h32 (logior #xEE10 (ash n -1)) (logior (ash (reg rt) 12) #x0A10 (ash (ldb (byte 1 0) n) 7))))) diff --git a/build-firmware.sh b/build-firmware.sh new file mode 100755 index 0000000..4d21cf8 --- /dev/null +++ b/build-firmware.sh @@ -0,0 +1,9 @@ +#!/bin/sh +# Build the kernel image for the STM32F446 from source: SBCL runs the Thumb-2 assembler +# (asm.lisp) and the metacompiler (kernel.lisp, kernel.fs) and writes kernel-f446.bin. +# No third-party Forth. The image runs on QEMU netduinoplus2, the closest QEMU board +# to the F446 (console: USART2 = QEMU's second -serial); a real board takes it with +# st-flash write kernel-f446.bin 0x8000000 +set -e +HERE=$(cd "$(dirname "$0")" && pwd) +nice "${SBCL:-sbcl}" --script "$HERE/kernel.lisp" "$HERE/kernel-f446.bin" diff --git a/demo.sh b/demo.sh new file mode 100755 index 0000000..212e8aa --- /dev/null +++ b/demo.sh @@ -0,0 +1,13 @@ +#!/bin/sh +# Scripted proof of the layers: the host compiles Lisp to Forth words, loads the Scheme +# through the Forth console, and checks its answers. Every serial exchange has a timeout. +HERE=$(cd "$(dirname "$0")" && pwd) +CORE=${FORTHLISP_CORE:-$HERE}; [ -f "$CORE/host.lisp" ] || CORE=$HERE/../forthlisp # core repo checkout +IMG=$HERE/kernel-f446.bin +PORT=${PORT:-4445} +[ -f "$IMG" ] || "$HERE/build-firmware.sh" >/dev/null +"${QEMU:-qemu-system-arm}" -M netduinoplus2 -kernel "$IMG" -display none -monitor none \ + -serial null -serial tcp:127.0.0.1:$PORT,server,nowait 2>/dev/null & +QPID=$! +trap 'kill $QPID 2>/dev/null' EXIT HUP INT TERM +PORT=$PORT ${TIMEOUT:-timeout} 300 "${SBCL:-sbcl}" --script "$CORE/host.lisp" demo diff --git a/docs/forth-cheatsheet.txt b/docs/forth-cheatsheet.txt new file mode 100644 index 0000000..84e863b --- /dev/null +++ b/docs/forth-cheatsheet.txt @@ -0,0 +1,46 @@ +FORTH CHEAT SHEET (our own kernel, STM32F446 on QEMU netduinoplus2) +===================================================================== +Forth reads words left to right. Numbers go on the stack. Words +eat from the stack and push results. ".s" shows the stack. +Editing: Backspace and Delete both erase the last character. + +STACK + 1 2 3 .s show stack -> 1 2 3 + . u. print and drop top 5 . -> 5 + dup drop swap over rot -rot nip tuck pick ?dup 2dup 2drop depth + >r r> r@ rdrop move items to/from the return stack + +ARITHMETIC (32-bit integers) + + - * / mod /mod u/mod m* um* 17 5 /mod . . -> 3 2 + negate abs min max 1+ 1- 2+ 2- 2* 2/ cells cell+ + hex decimal hex FF decimal . -> 255 also $FF #10 %101 + +COMPARE AND LOGIC (true = -1, false = 0) + = <> < > <= >= u< u> 0= 0<> 0< 0> + and or xor invert bic lshift rshift arshift + +DEFINE WORDS + : sq ( n -- n*n ) dup * ; 7 sq . -> 49 + ( ... ) comment \ comment to end of line words lists every word + immediate recurse literal [ ] ' ['] [char] execute + +CONTROL FLOW (inside : ... ;) + : sign dup 0< if ." neg" else ." pos" then drop ; + : count10 10 0 do i . loop ; -> 0 1 2 ... 9 + : evens 10 0 do i . 2 +loop ; -> 0 2 4 6 8 + : down begin dup . 1- dup 0= until drop ; 5 down -> 5 4 3 2 1 + begin ... while ... repeat begin ... again ?do leave unloop i j + +VARIABLES AND MEMORY + 42 variable x initial value comes FIRST x @ . -> 42 + 7 x ! 5 x +! 42 constant answer 16 buffer: buf + @ ! c@ c! h@ h! +! bis! bic! cbis! cbic! move fill compare count + here allot , c, align unused type emit key key? cr space + s" text" type ." text" (s" also works at the prompt) + +TRY THESE + : fib ( n -- f ) 0 1 rot 0 ?do over + swap loop drop ; 10 fib . -> 55 + : stars 0 ?do 42 emit loop ; 5 stars -> ***** + : fact ( n -- n! ) 1 swap 1+ 1 ?do i * loop ; 6 fact . -> 720 + +QUIT: Ctrl-C stops QEMU. Words you define live in RAM and are lost. diff --git a/forth-tests.txt b/forth-tests.txt new file mode 100644 index 0000000..1d1d95b --- /dev/null +++ b/forth-tests.txt @@ -0,0 +1,74 @@ +\ forth-tests.txt -- layer 3 tests: kernel words over the serial console (host.lisp ktest). +\ Each line: INPUT ==> what the kernel prints after the echo, before " ok." (trimmed). +\ Lines without ==> must just answer ok. Runs on a freshly booted kernel, before lisp.fs. +1 2 + . ==> 3 +7 3 - . ==> 4 +6 7 * . ==> 42 +17 5 / . 17 5 mod . ==> 3 2 +-17 5 / . -17 5 mod . ==> -3 -2 +17 5 /mod . . ==> 3 2 +-7 abs . 5 negate . ==> 7 -5 +1 2 swap . . ==> 1 2 +1 2 over . . . ==> 1 2 1 +1 2 3 rot . . . ==> 1 3 2 +1 2 3 -rot . . . ==> 2 1 3 +1 2 nip . 1 2 tuck . . . ==> 2 2 1 2 +1 2 3 2 pick . . . . ==> 1 3 2 1 +0 ?dup . 5 ?dup . . ==> 0 5 5 +1 2 2dup . . . . ==> 2 1 2 1 +1 2 3 2drop . ==> 1 +depth . 1 2 depth . 2drop ==> 0 2 +3 4 = . 4 4 = . 3 4 <> . ==> 0 -1 -1 +-1 0 < . 1 0 > . -1 0 u< . ==> -1 -1 0 +3 3 <= . 2 3 >= . ==> -1 0 +0 0= . 5 0<> . -5 0< . ==> -1 -1 -1 +3 5 min . 3 5 max . ==> 3 5 +1 4 lshift . 256 4 rshift . -16 2 arshift . ==> 16 16 -4 +12 10 and . 12 10 or . 12 10 xor . 12 4 bic . ==> 8 14 6 8 +0 invert . 5 1+ . 5 1- . 5 2* . -6 2/ . ==> -1 6 4 10 -3 +3 cells . 4 cell+ . ==> 12 8 +100000 100000 m* . . ==> 2 1410065408 +hex ff . decimal $ff . #10 . %101 . ==> FF 255 10 5 +10 base ! -42 . ==> -42 +5 u. -1 u. ==> 5 4294967295 +65 emit 66 emit ==> AB +: sq dup * ; 7 sq . ==> 49 +: fact dup 2 < if drop 1 else dup 1- recurse * then ; 10 fact . ==> 3628800 +: cnt 0 swap 0 do 1+ loop ; 1000 cnt . ==> 1000 +: evens 10 0 do i . 2 +loop ; evens ==> 0 2 4 6 8 +: nest 3 0 do 2 0 do j . i . loop loop ; nest ==> 0 0 0 1 1 0 1 1 2 0 2 1 +: none 0 0 ?do 99 . loop ; none ==> +: lv 10 0 do i 3 = if leave then i . loop ; lv ==> 0 1 2 +: bw begin dup . 1- dup 0= until drop ; 3 bw ==> 3 2 1 +: wr begin dup 0> while dup . 1- repeat drop ; 3 wr ==> 3 2 1 +: hi ." hello" ; hi ==> hello +: sl s" abc" type ; sl ==> abc +: ch [char] A emit ; ch ==> A +: li [ 6 7 * ] literal . ; li ==> 42 +42 constant answer answer . ==> 42 +7 variable v v @ . 5 v +! v @ . ==> 7 12 +16 buffer: buf buf 16 65 fill buf 3 type ==> AAA +create? ==> create? not found. +s" abc" s" abc" compare . s" abc" s" abd" compare . ==> -1 0 +pad? ==> pad? not found. +1 2 3 sp@ 8 + sp! . ==> 1 +' sq 3 swap execute . ==> 9 +: im 42 ; immediate : use im ; . ==> 42 +1 2 >r . r> . ==> 1 2 +5 >r r@ . rdrop ==> 5 +1 2 \ comment 3 +. . ==> 2 1 +1 ( comment ) 2 + . ==> 3 +256 here ! here @ . here c@ . ==> 256 0 +-1 here ! 5 here c! here @ . ==> -251 +here 4 + here 2 move ==> +undefined-word ==> undefined-word not found. +drop ==> Stack underflow +1 2x+ ==> 2x+ not found. +3 s>f 4 s>f f+ f>s . ==> 7 +7 s>f 2 s>f f- f>s . 7 s>f 2 s>f f* f>s . ==> 5 14 +1 s>f 3 s>f f/ hex u. decimal ==> 3EAAAAAB +-7 s>f f>s . 7 s>f 2 s>f f/ f>s . ==> -7 3 +16 s>f fsqrt f>s . ==> 4 +1 s>f 2 s>f f< . 2 s>f 1 s>f f< . 2 s>f 2 s>f f= . ==> -1 0 -1 +: sq2 1 ; : sq2 2 ; sq2 . ==> Redefine sq2. 2 diff --git a/kernel-tests.txt b/kernel-tests.txt new file mode 100644 index 0000000..019204e --- /dev/null +++ b/kernel-tests.txt @@ -0,0 +1 @@ +kernel tests: 71 passed, 0 failed, 71 total diff --git a/kernel.fs b/kernel.fs new file mode 100644 index 0000000..132c014 --- /dev/null +++ b/kernel.fs @@ -0,0 +1,135 @@ +\ kernel.fs -- the high-level half of the Forth kernel. kernel.lisp metacompiles this file +\ into flash: each : definition becomes a header plus a list of execution tokens. Control +\ words (if, begin, do, ...) and ['] [char] ." s" recurse are resolved by the metacompiler +\ here; the immediate words of the same names below compile code at run time on the chip. +\ Console protocol and word set follow Mecrisp-Stellaris, so lisp.fs loads unchanged. + +: true -1 ; +: false 0 ; +: bl 32 ; +: here dp @ ; +: allot dp +! ; +: , here ! 4 allot ; +: c, here c! 1 allot ; +: aligned 3 + -4 and ; +: align here aligned dp ! ; +: unused dict-limit here - ; +: hex 16 base ! ; +: decimal 10 base ! ; +: within ( n lo hi -- f ) over - >r - r> u< ; +: /string ( a n k -- a+k n-k ) rot over + -rot - ; + +\ ---- output ---- +: cr 10 emit ; +: space bl emit ; +: type ( a n -- ) 0 ?do dup c@ emit 1+ loop drop ; +: <# padend hld ! ; +: hold ( c -- ) -1 hld +! hld @ c! ; +: digit ( n -- c ) dup 9 > if 7 + then 48 + ; +: # ( lo hi -- lo' hi ) >r base @ u/mod swap digit hold r> ; +: #s ( lo hi -- 0 hi ) begin # over 0= until ; +: #> ( lo hi -- a n ) 2drop hld @ padend over - ; +: sign ( n -- ) 0< if 45 hold then ; +: u. 0 <# #s #> type space ; +: . dup abs 0 <# #s rot sign #> type space ; +: .s depth begin dup 0> while dup pick . 1- repeat drop ; +: words latest @ begin dup while dup 5 + count type space @ repeat drop cr ; + +\ ---- input ---- +: accept ( addr max -- len ) >r 0 + begin key dup 13 = over 10 = or 0= while + dup 8 = over 127 = or + if drop dup if 1- 8 emit space 8 emit then + else dup 9 = if drop 32 then + over r@ < if dup emit 2 pick 2 pick + c! 1+ else drop then + then + repeat drop rdrop nip space ; +: query tib 512 accept #tib ! 0 >in ! ; +: token ( -- addr len ) + tib >in @ + tib #tib @ + swap + begin 2dup > if dup c@ 33 < else 0 then while 1+ repeat + dup begin 2 pick over > if dup c@ 32 > else 0 then while 1+ repeat + rot over > if dup 1+ else dup then tib - >in ! over - ; +: parse ( c -- addr len ) >r tib >in @ + tib #tib @ + over + begin 2dup > if dup c@ r@ <> else 0 then while 1+ repeat rdrop + tuck > if dup 1+ else dup then tib - >in ! over - ; + +\ ---- dictionary ---- +: upc ( c -- C ) dup 97 123 within if 32 - then ; +: name= ( a1 n1 a2 n2 -- f ) rot over <> if 2drop drop 0 exit then + 0 ?do over i + c@ upc over i + c@ upc <> if 2drop 0 unloop exit then loop 2drop -1 ; +: >xt ( header -- xt ) 5 + count + aligned ; +: find ( addr len -- xt 1|-1 | addr len 0 ) + latest @ begin dup while + dup 4 + c@ 64 and 0= if + >r 2dup r@ 5 + count name= if 2drop r@ >xt r> 4 + c@ 128 and if 1 else -1 then exit then r> + then @ + repeat ; +: header ( addr len -- ) 2dup find if drop ." Redefine " 2dup type ." . " else 2drop then + align here latest @ , latest ! 0 c, dup c, here swap dup allot move align ; +: hide latest @ 4 + dup c@ 64 or swap c! ; +: reveal latest @ 4 + dup c@ 64 invert and swap c! ; +: immediate latest @ 4 + dup c@ 128 or swap c! ; + +\ ---- numbers ---- +: digit? ( c -- n true | false ) upc 48 - dup 9 > if 7 - dup 10 < if drop 0 exit then then + dup base @ u< if -1 else drop 0 then ; +: number ( addr len -- n true | false ) + base @ >r 0 nneg ! + over c@ 36 = if 16 base ! 1 /string else + over c@ 35 = if 10 base ! 1 /string else + over c@ 37 = if 2 base ! 1 /string then then then + over c@ 45 = if -1 nneg ! 1 /string then + dup 0= if 2drop r> base ! 0 exit then + 0 -rot begin dup while + over c@ digit? 0= if 2drop drop r> base ! 0 exit then + >r rot base @ * r> + -rot 1 /string + repeat 2drop + nneg @ if negate then r> base ! -1 ; + +\ ---- outer interpreter ---- +: abort sp0 sp! quit ; +: notfound ( addr len -- ) space type ." not found." cr abort ; +: ?stack depth 0< if ." Stack underflow" cr abort then ; +: interpret + begin token dup while + find ?dup if + state @ if 0< if , else execute then else drop execute then + else + 2dup number if nip nip state @ if ['] lit , , then else notfound then + then ?stack + repeat 2drop ; +: quit rp0 rp! 0 state ! begin query interpret ." ok." cr again ; +: cold cr ." lisp-forth-lisp Forth kernel for STM32F446 (own Thumb-2 build)" cr quit ; + +\ ---- compiler ---- +: [ 0 state ! ; immediate +: ] -1 state ! ; +: : token header docol , hide ] ; +: ; ['] exit , reveal [ ; immediate +: ' token find dup 0= if drop notfound then drop ; +: ['] ' ['] lit , , ; immediate +: literal ['] lit , , ; immediate +: [char] token drop c@ ['] lit , , ; immediate +: char token drop c@ ; +: recurse latest @ >xt , ; immediate +: ( 41 parse 2drop ; immediate +: \ #tib @ >in ! ; immediate +: (s",) 34 parse ['] (s") , dup c, here swap dup allot move align ; +: s" state @ if (s",) else 34 parse then ; immediate \ interpreting: the string stays in the input line +: ." (s",) ['] type , ; immediate +: variable ( x "name" -- ) token header dovar , , ; +: constant ( x "name" -- ) token header docon , , ; +: buffer: ( n "name" -- ) token header dovar , allot align ; +: if ['] 0branch , here 0 , ; immediate +: then here swap ! ; immediate +: else ['] branch , here 0 , swap here swap ! ; immediate +: begin here ; immediate +: until ['] 0branch , , ; immediate +: again ['] branch , , ; immediate +: while ['] 0branch , here 0 , swap ; immediate +: repeat ['] branch , , here swap ! ; immediate +: do ['] (do) , here 0 , here ; immediate +: ?do ['] (?do) , here 0 , here ; immediate +: loop ['] (loop) , , here swap ! ; immediate +: +loop ['] (+loop) , , here swap ! ; immediate diff --git a/kernel.lisp b/kernel.lisp new file mode 100644 index 0000000..4bc4843 --- /dev/null +++ b/kernel.lisp @@ -0,0 +1,348 @@ +;;;; kernel.lisp -- layer 2 builds layer 3: the Forth kernel image for the STM32F446. +;;;; +;;;; Indirect-threaded. r4 = IP, r5 = data stack pointer (full descending, holds the second +;;;; item), r6 = TOS, r7 = W (current xt), sp = return stack. NEXT: ldr r7,[r4],#4; +;;;; ldr r0,[r7]; bx r0. Header: link, flags (80 immediate, 40 hidden), length, name, +;;;; pad to 4, code field, body. Primitives are `defcode` templates (a name plus a Thumb-2 +;;;; body, NEXT appended); the high-level kernel is metacompiled from kernel.fs. +;;;; Usage: sbcl --script kernel.lisp OUT.bin + +(load (merge-pathnames "asm.lisp" *load-truename*)) +(in-package :thumb) + +;;; ---------- memory map ---------- +(defconstant +sysvars+ #x20000000) ; state base latest dp >in #tib hld nneg +(defconstant +tib+ #x20000040) ; 512-byte input buffer +(defconstant +padend+ #x200002C0) ; pictured numeric output grows down from here +(defconstant +ram-dict+ #x20000300) ; first free RAM for the user dictionary +(defconstant +dstop+ #x2001EFE0) ; data stack: 4 KiB below this +(defconstant +rstop+ #x2001FFE0) ; return stack: 4 KiB below this (QEMU: keep off the last 32 bytes) +(defconstant +dict-limit+ #x2001DEE0) ; dictionary stops 256 bytes above the data stack +(defconstant +usart2+ #x40004400) +(defparameter *sysvars* '("state" "base" "latest" "dp" ">in" "#tib" "hld" "nneg")) + +;;; ---------- dictionary ---------- +(defvar *xts* (make-hash-table :test 'equal)) +(defvar *defined* (make-hash-table :test 'equal)) +(defvar *last-link* nil) +(defun xt (name) (or (gethash name *xts*) (setf (gethash name *xts*) (label)))) +(defun byte8 (b) (sb-assem:emit-byte *seg* (ldb (byte 8 0) b))) + +(defun header (name &optional (flags 0)) + "Lay down a header; return NAME's xt label, marked at the code field." + (when (gethash name *defined*) (error "~a defined twice" name)) + (align4) + (let ((link (mark (label)))) + (if *last-link* (abs32 *last-link*) (w32 0)) + (setf *last-link* link) + (byte8 flags) (byte8 (length name)) + (loop for c across name do (byte8 (char-code c))) + (align4) + (setf (gethash name *defined*) t) + (mark (xt name)))) + +(defvar *docol* (label)) (defvar *dovar* (label)) (defvar *docon* (label)) +(defun next () (ldr :w :ip 4 :post) (ldr :r0 :w) (bx :r0)) +(defun dpush (r) (str :tos :psp -4 :pre) (unless (eql r :tos) (mov :tos r))) +(defun dpop (r) (ldr r :psp 4 :post)) + +(defmacro defcode (name (&key (next t) (flags 0)) &body body) + `(let ((code (label))) + (header ,name ,flags) + (abs32 code 1) + (mark code) + ,@body + ,@(when next '((next))))) +(defun defconst (name value &optional (addend 0)) + "A constant: an integer, or a label's address plus ADDEND." + (header name) (abs32 *docon* 1) + (if (integerp value) (w32 value) (abs32 value addend))) + +;;; ---------- primitives ---------- +(defun binop (fn) (dpop :r0) (funcall fn :tos :r0 :tos)) +(defun flag (c) "TOS = -1 if condition C, else 0 (flags already set)." (movw :tos 0) (it c) (mvn-0 :tos)) +(defun cmp2 (c) (dpop :r0) (cmp-reg :r0 :tos) (flag c)) +(defun cmp0 (c) (cmp-imm8 :tos 0) (flag c)) +(defun store-or (addr value) (li :r1 addr) (ldr :r0 :r1) (li :r2 value) (orr-reg :r0 :r0 :r2) (str :r0 :r1)) + +(defun primitives () + (defcode "exit" () (pop1 :ip)) + (defcode "lit" () (dpush :tos) (ldr :tos :ip 4 :post)) + (defcode "branch" () (ldr :ip :ip)) + (defcode "0branch" () (mov :r0 :tos) (dpop :tos) (ldr :r1 :ip 4 :post) (cmp-imm8 :r0 0) (it :eq) (mov :ip :r1)) + (defcode "execute" (:next nil) (mov :w :tos) (dpop :tos) (ldr :r0 :w) (bx :r0)) + (defcode "(do)" () (ldr :r0 :ip 4 :post) (push1 :r0) (dpop :r1) (push1 :r1) (push1 :tos) (dpop :tos)) + (defcode "(?do)" () + (let ((go (label)) (done (label))) + (ldr :r0 :ip 4 :post) (dpop :r1) (cmp-reg :r1 :tos) (bcc :ne go) + (mov :ip :r0) (dpop :tos) (b done) + (mark go) (push1 :r0) (push1 :r1) (push1 :tos) (dpop :tos) + (mark done))) + (defcode "(loop)" () + (let ((out (label)) (done (label))) + (ldr :r0 :sp) (addw :r0 :r0 1) (ldr :r1 :sp 4) (cmp-reg :r0 :r1) (bcc :eq out) + (str :r0 :sp) (ldr :ip :ip) (b done) + (mark out) (addw :sp :sp 12) (addw :ip :ip 4) + (mark done))) + (defcode "(+loop)" () + (let ((out (label)) (done (label))) + (ldr :r2 :sp) (ldr :r1 :sp 4) (sub-reg :r0 :r2 :r1) (add-reg :r3 :r0 :tos) (add-reg :r2 :r2 :tos) + (dpop :tos) (eor-reg :r0 :r0 :r3) (cmp-imm8 :r0 0) (bcc :lt out) + (str :r2 :sp) (ldr :ip :ip) (b done) + (mark out) (addw :sp :sp 12) (addw :ip :ip 4) + (mark done))) + (defcode "i" () (dpush :tos) (ldr :tos :sp)) + (defcode "j" () (dpush :tos) (ldr :tos :sp 12)) + (defcode "unloop" () (addw :sp :sp 12)) + (defcode "leave" () (ldr :ip :sp 8) (addw :sp :sp 12)) + (defcode "(s\")" () + (ldrb :r0 :ip) (addw :r1 :ip 1) (str :tos :psp -4 :pre) (str :r1 :psp -4 :pre) (mov :tos :r0) + (add-reg :ip :r1 :r0) (addw :ip :ip 3) (movw :r2 3) (bic-reg :ip :ip :r2)) + ;; stack + (defcode "dup" () (dpush :tos)) + (defcode "drop" () (dpop :tos)) + (defcode "swap" () (ldr :r0 :psp) (str :tos :psp) (mov :tos :r0)) + (defcode "over" () (ldr :r0 :psp) (dpush :r0)) + (defcode "rot" () (ldr :r0 :psp) (ldr :r1 :psp 4) (str :r0 :psp 4) (str :tos :psp) (mov :tos :r1)) + (defcode "-rot" () (ldr :r0 :psp) (ldr :r1 :psp 4) (str :tos :psp 4) (str :r1 :psp) (mov :tos :r0)) + (defcode "nip" () (addw :psp :psp 4)) + (defcode "tuck" () (ldr :r0 :psp) (str :tos :psp) (str :r0 :psp -4 :pre)) + (defcode "pick" () (add-reg :r0 :psp :tos :lsl 2) (ldr :tos :r0)) + (defcode "?dup" () (cmp-imm8 :tos 0) (it :ne) (str :tos :psp -4 :pre)) + (defcode "2dup" () (ldr :r0 :psp) (str :tos :psp -4 :pre) (str :r0 :psp -4 :pre)) + (defcode "2drop" () (addw :psp :psp 4) (dpop :tos)) + (defcode ">r" () (push1 :tos) (dpop :tos)) + (defcode "r>" () (dpush :tos) (pop1 :tos)) + (defcode "r@" () (dpush :tos) (ldr :tos :sp)) + (defcode "rdrop" () (addw :sp :sp 4)) + (defcode "depth" () (li :r0 +dstop+) (sub-reg :r0 :r0 :psp) (mov-shift :r0 :r0 :asr 2) (dpush :r0)) + (defcode "sp@" () (dpush :tos) (mov :tos :psp)) + (defcode "sp!" () (addw :psp :tos 4) (ldr :tos :tos)) + (defcode "rp@" () (dpush :tos) (mov :tos :sp)) + (defcode "rp!" () (mov :sp :tos) (dpop :tos)) + ;; arithmetic and logic + (defcode "+" () (binop #'add-reg)) + (defcode "-" () (binop #'sub-reg)) + (defcode "*" () (binop #'mul)) + (defcode "/" () (binop #'sdiv)) + (defcode "mod" () (dpop :r0) (sdiv :r1 :r0 :tos) (mls :tos :r1 :tos :r0)) + (defcode "/mod" () (ldr :r0 :psp) (sdiv :r1 :r0 :tos) (mls :r2 :r1 :tos :r0) (str :r2 :psp) (mov :tos :r1)) + (defcode "u/mod" () (ldr :r0 :psp) (udiv :r1 :r0 :tos) (mls :r2 :r1 :tos :r0) (str :r2 :psp) (mov :tos :r1)) + (defcode "m*" () (ldr :r0 :psp) (smull :r1 :r2 :r0 :tos) (str :r1 :psp) (mov :tos :r2)) + (defcode "um*" () (ldr :r0 :psp) (umull :r1 :r2 :r0 :tos) (str :r1 :psp) (mov :tos :r2)) + (defcode "negate" () (movw :r0 0) (sub-reg :tos :r0 :tos)) + (defcode "abs" () (mov-shift :r0 :tos :asr 31) (eor-reg :tos :tos :r0) (sub-reg :tos :tos :r0)) + (defcode "and" () (binop #'and-reg)) + (defcode "or" () (binop #'orr-reg)) + (defcode "xor" () (binop #'eor-reg)) + (defcode "bic" () (dpop :r0) (bic-reg :tos :r0 :tos)) + (defcode "invert" () (mvn-reg :tos :tos)) + (defcode "lshift" () (dpop :r0) (lsl-reg :tos :r0 :tos)) + (defcode "rshift" () (dpop :r0) (lsr-reg :tos :r0 :tos)) + (defcode "arshift" () (dpop :r0) (asr-reg :tos :r0 :tos)) + (defcode "1+" () (addw :tos :tos 1)) + (defcode "1-" () (subw :tos :tos 1)) + (defcode "2+" () (addw :tos :tos 2)) + (defcode "2-" () (subw :tos :tos 2)) + (defcode "2*" () (mov-shift :tos :tos :lsl 1)) + (defcode "2/" () (mov-shift :tos :tos :asr 1)) + (defcode "cells" () (mov-shift :tos :tos :lsl 2)) + (defcode "cell+" () (addw :tos :tos 4)) + (defcode "min" () (dpop :r0) (cmp-reg :r0 :tos) (it :lt) (mov :tos :r0)) + (defcode "max" () (dpop :r0) (cmp-reg :r0 :tos) (it :gt) (mov :tos :r0)) + (defcode "=" () (cmp2 :eq)) (defcode "<>" () (cmp2 :ne)) + (defcode "<" () (cmp2 :lt)) (defcode ">" () (cmp2 :gt)) + (defcode "<=" () (cmp2 :le)) (defcode ">=" () (cmp2 :ge)) + (defcode "u<" () (cmp2 :lo)) (defcode "u>" () (cmp2 :hi)) + (defcode "0=" () (cmp0 :eq)) (defcode "0<>" () (cmp0 :ne)) + (defcode "0<" () (cmp0 :lt)) (defcode "0>" () (cmp0 :gt)) + ;; memory + (defcode "@" () (ldr :tos :tos)) + (defcode "!" () (dpop :r0) (str :r0 :tos) (dpop :tos)) + (defcode "c@" () (ldrb :tos :tos)) + (defcode "c!" () (dpop :r0) (strb :r0 :tos) (dpop :tos)) + (defcode "h@" () (ldrh :tos :tos)) + (defcode "h!" () (dpop :r0) (strh :r0 :tos) (dpop :tos)) + (defcode "+!" () (dpop :r0) (ldr :r1 :tos) (add-reg :r1 :r1 :r0) (str :r1 :tos) (dpop :tos)) + (defcode "bis!" () (dpop :r0) (ldr :r1 :tos) (orr-reg :r1 :r1 :r0) (str :r1 :tos) (dpop :tos)) + (defcode "bic!" () (dpop :r0) (ldr :r1 :tos) (bic-reg :r1 :r1 :r0) (str :r1 :tos) (dpop :tos)) + (defcode "cbis!" () (dpop :r0) (ldrb :r1 :tos) (orr-reg :r1 :r1 :r0) (strb :r1 :tos) (dpop :tos)) + (defcode "cbic!" () (dpop :r0) (ldrb :r1 :tos) (bic-reg :r1 :r1 :r0) (strb :r1 :tos) (dpop :tos)) + (defcode "move" () ; ( src dst n ) overlap-safe + (let ((back (label)) (fl (label)) (bl2 (label)) (done (label))) + (mov :r2 :tos) (dpop :r1) (dpop :r0) (dpop :tos) + (cmp-reg :r0 :r1) (bcc :lo back) + (mark fl) (cmp-imm8 :r2 0) (bcc :eq done) + (ldrb :r3 :r0 1 :post) (strb :r3 :r1 1 :post) (subw :r2 :r2 1) (b fl) + (mark back) (add-reg :r0 :r0 :r2) (add-reg :r1 :r1 :r2) + (mark bl2) (cmp-imm8 :r2 0) (bcc :eq done) + (ldrb :r3 :r0 -1 :pre) (strb :r3 :r1 -1 :pre) (subw :r2 :r2 1) (b bl2) + (mark done))) + (defcode "fill" () ; ( addr n c ) + (let ((lp (label)) (done (label))) + (mov :r1 :tos) (dpop :r2) (dpop :r0) (dpop :tos) + (mark lp) (cmp-imm8 :r2 0) (bcc :eq done) + (strb :r1 :r0 1 :post) (subw :r2 :r2 1) (b lp) + (mark done))) + (defcode "compare" () ; ( a1 n1 a2 n2 -- flag ) true if equal bytes + (let ((lp (label)) (no (label)) (done (label))) + (mov :r3 :tos) (dpop :r2) (dpop :r1) (dpop :r0) (movw :tos 0) + (cmp-reg :r1 :r3) (bcc :ne done) + (mark lp) (cmp-imm8 :r1 0) (bcc :eq no) + (ldrb :r3 :r0 1 :post) (ldrb :r12 :r2 1 :post) (cmp-reg :r3 :r12) (bcc :ne done) + (subw :r1 :r1 1) (b lp) + (mark no) (mvn-0 :tos) + (mark done))) + (defcode "count" () (ldrb :r0 :tos 1 :post) (dpush :r0)) + ;; single-precision floats on the M4F FPU; a float is its IEEE-754 bit pattern in one cell + (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)) + (fun (op) (vmov-s-r :s0 :tos) (funcall op :s0 :s0) (vmov-r-s :tos :s0)) + (fcmp (c) (dpop :r0) (vmov-s-r :s0 :r0) (vmov-s-r :s1 :tos) (vcmp :s0 :s1) (vmrs-apsr) (flag c))) + (defcode "f+" () (fbin #'vadd)) + (defcode "f-" () (fbin #'vsub)) + (defcode "f*" () (fbin #'vmul)) + (defcode "f/" () (fbin #'vdiv)) + (defcode "s>f" () (fun #'vcvt-f32-s32)) + (defcode "f>s" () (fun #'vcvt-s32-f32)) + (defcode "fsqrt" () (fun #'vsqrt)) + (defcode "f<" () (fcmp :mi)) + (defcode "f=" () (fcmp :eq))) + ;; console: USART2, polled + (defcode "emit" () + (let ((wait (label))) + (li :r1 +usart2+) (movw :r2 #x80) + (mark wait) (ldr :r0 :r1) (tst-reg :r0 :r2) (bcc :eq wait) + (str :tos :r1 4) (dpop :tos))) + (defcode "key" () + (let ((wait (label))) + (li :r1 +usart2+) (movw :r2 #x20) + (mark wait) (ldr :r0 :r1) (tst-reg :r0 :r2) (bcc :eq wait) + (dpush :tos) (ldr :tos :r1 4) (movw :r2 255) (and-reg :tos :tos :r2))) + (defcode "key?" () (li :r1 +usart2+) (ldr :r0 :r1) (movw :r2 #x20) (dpush :tos) (tst-reg :r0 :r2) (flag :ne))) + +(defun runtime-code () + "Code fields shared by all colon words, variables and constants." + (mark *docol*) (push1 :ip) (addw :ip :w 4) (next) + (mark *dovar*) (dpush :tos) (addw :tos :w 4) (next) + (mark *docon*) (dpush :tos) (ldr :tos :w 4) (next)) + +(defun reset-code (reset fault cold-thread) + (mark reset) + (store-or #xE000ED88 #x00F00000) ; CPACR: enable the FPU (CP10, CP11) + (store-or #x40023830 1) ; RCC AHB1ENR: GPIOA + (store-or #x40023840 (ash 1 17)) ; RCC APB1ENR: USART2 + (store-or #x40020000 #xA0) ; GPIOA MODER: PA2, PA3 alternate function + (store-or #x40020020 #x7700) ; GPIOA AFRL: AF7 = USART2 + (li :r1 (+ +usart2+ 8)) (movw :r0 #x8B) (str :r0 :r1) ; BRR: 115200 baud at 16 MHz HSI + (li :r1 (+ +usart2+ 12)) (movw :r0 #x200C) (str :r0 :r1) ; CR1: UE TE RE + (li :r1 +sysvars+) (movw :r0 0) (str :r0 :r1 0) ; state + (movw :r0 10) (str :r0 :r1 4) ; base + (li :r0 *last-link*) (str :r0 :r1 8) ; latest + (li :r0 +ram-dict+) (str :r0 :r1 12) ; dp + (li :psp +dstop+) (movw :tos 0) + (li :ip cold-thread) (next) + (mark fault) ; print FAULT, then system reset + (let ((msg (label)) (lp (label)) (wait (label)) (done (label))) + (li :r3 msg) (li :r1 +usart2+) (movw :r2 #x80) + (mark lp) (ldrb :r0 :r3 1 :post) (cmp-imm8 :r0 0) (bcc :eq done) + (mark wait) (ldr :r12 :r1) (tst-reg :r12 :r2) (bcc :eq wait) (str :r0 :r1 4) (b lp) + (mark done) (li :r0 #xE000ED0C) (li :r1 #x05FA0004) (str :r1 :r0) (b done) + (mark msg) (loop for c across (format nil "~c~%FAULT: reset~%" #\Return) do (byte8 (char-code c))) (byte8 0) + (align4))) + +;;; ---------- metacompiler for kernel.fs ---------- +(defun tokenize (text) + "Whitespace tokens; \\ and ( ) comments dropped; the text after .\" s\" .( becomes (:string ...)." + (let ((toks '()) (i 0) (n (length text))) + (flet ((ws (c) (member c '(#\Space #\Tab #\Newline #\Return))) + (upto (ch) (let ((e (or (position ch text :start i) n))) (prog1 (subseq text i e) (setf i (min n (1+ e))))))) + (loop + (loop while (and (< i n) (ws (char text i))) do (incf i)) + (when (>= i n) (return)) + (let* ((e (or (position-if #'ws text :start i) n)) (tok (subseq text i e))) + (setf i e) + (cond ((equal (first toks) ":") (push tok toks)) ; a name, even if it looks special + ((string= tok "\\") (upto #\Newline)) + ((string= tok "(") (upto #\))) + ((member tok '(".\"" "s\"") :test #'string=) + (incf i) (push tok toks) (push (list :string (upto #\")) toks)) + (t (push tok toks))))) + (nreverse toks)))) + +(defun parse-num (tok) + (let* ((neg (and (> (length tok) 1) (char= (char tok 0) #\-))) (s (if neg (subseq tok 1) tok)) + (base 10)) + (when (and (> (length s) 1) (char= (char s 0) #\$)) (setf base 16 s (subseq s 1))) + (let ((v (ignore-errors (parse-integer s :radix base)))) + (and v (if neg (- v) v))))) + +(defun cell (name) (abs32 (xt name))) +(defun lit (v) (cell "lit") (if (integerp v) (w32 v) (abs32 v))) + +(defun compile-def (name body) + "BODY: tokens between the name and ;. Control structures resolve to labels here." + (let ((cs '())) + (loop while body do + (let ((tok (pop body))) + (cond + ((consp tok) (error "stray string in ~a" name)) + ((string= tok "if") (cell "0branch") (let ((l (label))) (abs32 l) (push l cs))) + ((string= tok "else") (cell "branch") (let ((l (label))) (abs32 l) (mark (pop cs)) (push l cs))) + ((string= tok "then") (mark (pop cs))) + ((string= tok "begin") (push (mark (label)) cs)) + ((string= tok "until") (cell "0branch") (abs32 (pop cs))) + ((string= tok "again") (cell "branch") (abs32 (pop cs))) + ((string= tok "while") (cell "0branch") (let ((l (label)) (dest (pop cs))) (abs32 l) (push l cs) (push dest cs))) + ((string= tok "repeat") (cell "branch") (abs32 (pop cs)) (mark (pop cs))) + ((member tok '("do" "?do") :test #'string=) + (cell (if (string= tok "do") "(do)" "(?do)")) + (let ((leave (label))) (abs32 leave) (push leave cs) (push (mark (label)) cs))) + ((member tok '("loop" "+loop") :test #'string=) + (cell (if (string= tok "loop") "(loop)" "(+loop)")) (abs32 (pop cs)) (mark (pop cs))) + ((string= tok "recurse") (cell name)) + ((string= tok "[']") (lit (xt (pop body)))) + ((string= tok "[char]") (lit (char-code (char (pop body) 0)))) + ((member tok '(".\"" "s\"") :test #'string=) + (let ((s (second (pop body)))) + (cell "(s\")") (byte8 (length s)) (loop for c across s do (byte8 (char-code c))) (align4) + (when (string= tok ".\"") (cell "type")))) + ((parse-num tok) (lit (parse-num tok))) + (t (cell tok))))) + (when cs (error "unbalanced control structure in ~a" name)) + (cell "exit"))) + +(defun metacompile (path) + (let ((toks (with-open-file (s path) (let ((str (make-string (file-length s)))) (tokenize (subseq str 0 (read-sequence str s))))))) + (loop while toks do + (let ((tok (pop toks))) + (unless (equal tok ":") (error "kernel.fs: expected : at ~s" tok)) + (let* ((name (pop toks)) (end (position ";" toks :test #'equal)) (body (subseq toks 0 end)) + (imm (equal (nth (1+ end) toks) "immediate"))) + (setf toks (nthcdr (+ end (if imm 2 1)) toks)) + (header name (if imm #x80 0)) + (abs32 *docol* 1) + (compile-def name body)))))) + +;;; ---------- image ---------- +(defun build (out) + (new-segment) + (let ((reset (label)) (fault (label)) (cold-thread (label))) + (w32 +rstop+) (abs32 reset 1) + (dotimes (i 14) (abs32 fault 1)) + (runtime-code) + (primitives) + (loop for name in *sysvars* for i from 0 do (defconst name (+ +sysvars+ (* 4 i)))) + (defconst "tib" +tib+) (defconst "padend" +padend+) (defconst "sp0" (- +dstop+ 4)) + (defconst "rp0" +rstop+) (defconst "dict-limit" +dict-limit+) + (defconst "docol" *docol* 1) (defconst "dovar" *dovar* 1) (defconst "docon" *docon* 1) + (metacompile (merge-pathnames "kernel.fs" *load-truename*)) + (align4) (mark cold-thread) (cell "cold") + (reset-code reset fault cold-thread)) + (let ((undefined (loop for k being the hash-keys of *xts* unless (gethash k *defined*) collect k))) + (when undefined (error "undefined words: ~{~a~^ ~}" undefined))) + (let ((bytes (segment-bytes))) + (with-open-file (s out :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) + (write-sequence bytes s)) + (format t "kernel image: ~d bytes, ~d words~%" (length bytes) (hash-table-count *defined*)))) + +(build (or (second sb-ext:*posix-argv*) "kernel.bin")) \ No newline at end of file diff --git a/stm32-forth b/stm32-forth new file mode 100755 index 0000000..8153a14 --- /dev/null +++ b/stm32-forth @@ -0,0 +1,15 @@ +#!/bin/sh +# stm32-forth -- boot the Forth kernel for the STM32F446 in QEMU (netduinoplus2) and give its prompt. +# Usage: stm32-forth interactive prompt on this terminal; ctrl-c quits +# PORT=4444 stm32-forth serve the console on 127.0.0.1:PORT instead +# printf '1 2 + .\n' | stm32-forth scripted (add a timeout yourself) +# QEMU (default qemu-system-arm) and SBCL (default sbcl) come from PATH unless set. +HERE=$(cd "$(dirname "$0")" && pwd) +IMG=$HERE/kernel-f446.bin +[ -f "$IMG" ] || "$HERE/build-firmware.sh" >/dev/null +if [ -n "$PORT" ]; then + exec "${QEMU:-qemu-system-arm}" -M netduinoplus2 -kernel "$IMG" -display none -monitor none \ + -serial null -serial tcp:127.0.0.1:$PORT,server,nowait +fi +exec "${QEMU:-qemu-system-arm}" -M netduinoplus2 -kernel "$IMG" -display none -monitor none \ + -serial null -serial stdio 2>/dev/null diff --git a/stm32-lisp b/stm32-lisp new file mode 100755 index 0000000..40c43c5 --- /dev/null +++ b/stm32-lisp @@ -0,0 +1,20 @@ +#!/bin/sh +# stm32-lisp -- boot the Forth kernel for the STM32F446 in QEMU (netduinoplus2; 128 KiB RAM and +# 512 KiB flash used), load the Scheme through the host, then attach its REPL. +# Quit with ctrl-c; (forth) returns to the Forth prompt. PORT picks the TCP port (default 4444). +# Tools come from PATH unless set: QEMU (qemu-system-arm), SBCL (sbcl), NC (nc), STTY (stty). +set -e +HERE=$(cd "$(dirname "$0")" && pwd) +CORE=${FORTHLISP_CORE:-$HERE}; [ -f "$CORE/host.lisp" ] || CORE=$HERE/../forthlisp # core repo checkout +IMG=$HERE/kernel-f446.bin +PORT=${PORT:-4444} +[ -f "$IMG" ] || "$HERE/build-firmware.sh" >/dev/null +"${QEMU:-qemu-system-arm}" -M netduinoplus2 -kernel "$IMG" -display none -monitor none \ + -serial null -serial tcp:127.0.0.1:$PORT,server,nowait 2>/dev/null & +QPID=$! +trap 'kill $QPID 2>/dev/null; ${STTY:-stty} sane 2>/dev/null' EXIT HUP INT TERM +PORT=$PORT "${SBCL:-sbcl}" --script "$CORE/host.lisp" load +echo +echo "target Lisp ready: type an expression, (forth) returns to Forth, ctrl-c quits" +${STTY:-stty} -echo -icanon 2>/dev/null || true # the chip echoes; no tty when piped +${NC:-nc} 127.0.0.1 $PORT diff --git a/test.sh b/test.sh new file mode 100755 index 0000000..ceb91c2 --- /dev/null +++ b/test.sh @@ -0,0 +1,30 @@ +#!/bin/sh +# test.sh -- run the test layers in order, each on a freshly booted chip: +# 1-2 assembler encodings vs GNU as (asm-tests.txt) +# 3 kernel words over the serial console (kernel-tests.txt) +# 4 the Scheme regression suite (conformance.txt in the core) +# 4 SUITE=1: chibi-scheme's R7RS suite (tests/r7rs/results.txt in the core; about 10 minutes) +# Tools come from PATH unless set: SBCL, QEMU, ARM_AS, ARM_OBJCOPY. PORT is the first TCP port. +HERE=$(cd "$(dirname "$0")" && pwd) +CORE=${FORTHLISP_CORE:-$HERE}; [ -f "$CORE/host.lisp" ] || CORE=$HERE/../forthlisp # core repo checkout +SBCL=${SBCL:-sbcl} +PORT=${PORT:-4480} +rc=0 +"$SBCL" --script "$HERE/asm-test.lisp" > "$HERE/asm-tests.txt" 2>&1 || rc=1 +tail -1 "$HERE/asm-tests.txt" +"$HERE/build-firmware.sh" || exit 1 +onchip() { # onchip OUTFILE host.lisp-args... + out=$1; shift + "${QEMU:-qemu-system-arm}" -M netduinoplus2 -kernel "$HERE/kernel-f446.bin" -display none \ + -monitor none -serial null -serial tcp:127.0.0.1:$PORT,server,nowait 2>/dev/null & + qp=$! + PORT=$PORT "$SBCL" --script "$CORE/host.lisp" "$@" > /tmp/forthlisp-test-$PORT.log 2>&1 || rc=1 + kill $qp 2>/dev/null + grep -E "^FAIL|tests: |conformance: |r7rs suite: |^FAILED" /tmp/forthlisp-test-$PORT.log > "$out" + tail -1 "$out" + PORT=$((PORT + 1)) +} +onchip "$HERE/kernel-tests.txt" ktest "$HERE/forth-tests.txt" +onchip "$CORE/conformance.txt" test +[ -n "$SUITE" ] && onchip /tmp/forthlisp-suite-summary.txt suite +exit $rc diff --git a/transcript.txt b/transcript.txt new file mode 100644 index 0000000..258ccec --- /dev/null +++ b/transcript.txt @@ -0,0 +1,65 @@ + +=== Layer 1: host Lisp compiles Lisp to Forth and runs it on the chip === + ok. +[compiled] : sq dup over * nip ; +: sq dup over * nip ; ok. +[compiled] : fact dup 2 < if 1 else dup over 1 - recurse * then nip ; +: fact dup 2 < if 1 else dup over 1 - recurse * then nip ; ok. +7 sq . 49 ok. +10 fact . 3628800 ok. + +=== Layer 2: load the Forth Lisp (core lisp.fs + prims compiled from prims.lisp) === +unused . 35672 ok. + 35672 ok. + +=== Layer 3: Lisp (host) -> Forth (chip) -> Lisp (chip) === +lisp +> (+ 1 2) +3 +> (+ 1 2) => 3 +(define (sq x) (* x x)) +sq +> (define (sq x) (* x x)) => sq +(sq 7) +49 +> (sq 7) => 49 +(define (fact n) (if (< n 2) 1 (* n (fact (- n 1))))) +fact +> (define (fact n) (if (< n 2) 1 (* n (fact (- n 1))))) => fact +(fact 7) +5040 +> (fact 7) => 5040 +(cons 1 (cons 2 '())) +(1 2) +> (cons 1 (cons 2 '())) => (1 2) +(car '(a b c)) +a +> (car '(a b c)) => a +(define (my-map f l) (if (null? l) '() (cons (f (car l)) (my-map f (cdr l))))) +my-map +> (define (my-map f l) (if (null? l) '() (cons (f (car l)) (my-map f (cdr l))))) => my-map +(my-map sq '(1 2 3 4)) +(1 4 9 16) +> (my-map sq '(1 2 3 4)) => (1 4 9 16) +((lambda (x y) (- x y)) 10 3) +7 +> ((lambda (x y) (- x y)) 10 3) => 7 +(map fact '(1 2 3 4 5)) +(1 2 6 24 120) +> (map fact '(1 2 3 4 5)) => (1 2 6 24 120) +(let loop ((i 0)) (if (< i 10000) (loop (+ i 1)) i)) +10000 +> (let loop ((i 0)) (if (< i 10000) (loop (+ i 1)) i)) => 10000 +(eq? (car '(a)) 'a) +#t +> (eq? (car '(a)) 'a) => #t +(< 2 1) +#f +> (< 2 1) => #f +(forth) + ok. +(forth) => back at the Forth prompt +unused . 35672 ok. + 35672 ok. + +SUCCESS: all three layers answered as expected.