# HG changeset patch # User Steve Losh # Date 1614739378 18000 # Node ID de18bb93f9ec3a923d87d8b6e5e2aa29d8f69d39 Initial commit diff -r 000000000000 -r de18bb93f9ec .hgignore --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/.hgignore Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,7 @@ +syntax: glob + +scratch.lisp +*.png +*.svg +docs/build +prog.s diff -r 000000000000 -r de18bb93f9ec Makefile --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Makefile Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,3 @@ +prog: prog.s runtime.c + gcc runtime.c prog.s -o prog + diff -r 000000000000 -r de18bb93f9ec README.markdown --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/README.markdown Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,2 @@ +Going through , but +using Common Lisp as the implementation language and ARM64 as the target. diff -r 000000000000 -r de18bb93f9ec iacc.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/iacc.lisp Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,156 @@ +;;;; Preamble ----------------------------------------------------------------- +(ql:quickload '(:losh :alexandria)) + +(defpackage :iacc + (:use :cl) + (:export :compile-program + :fxadd1 :fxsub1 :fxzero? + :fixnum? :char? :null? boolean? + :char->fixnum :fixnum->char + ) + (:shadow :fixnum :character :boolean)) + +(in-package :iacc) + +;;;; Utils -------------------------------------------------------------------- +(defun todo () + (error "Not implemented yet.")) + + +;;;; Types -------------------------------------------------------------------- +(deftype fixnum () '(signed-byte 62)) +(deftype character () 'cl:base-char) +(deftype boolean () '(member :true :false)) +(deftype immediate () '(or fixnum character boolean null)) +(deftype primitive () '(satisfies primitivep)) +(deftype primitive-expression () '(cons primitive *)) +(deftype program () '(or immediate primitive-expression)) + + +;;;; Immediates --------------------------------------------------------------- +;; Tagging scheme: +;; xxxxxxxx…xxxxxx00 fixnum +;; xxxxxxxx…xxxx1111 other immediate +;; +;; Immediates: +;; xxxxxxxx…0000 1111 character +;; xxxxxxxx…0010 1111 false +;; xxxxxxxx…0110 1111 true +;; xxxxxxxx…0011 1111 nil +(defun immediate-rep (object) + (etypecase object + (fixnum (ash object 2)) + (character (logior (ash (char-code object) 8) #b00001111)) + ((eql :false) #b00101111) + ((eql :true) #b01101111) + (null #b00111111))) + + +;;;; Basic Emitters ----------------------------------------------------------- +(defun emit (string &rest args) + (apply #'format *standard-output* string args) + (terpri *standard-output*)) + +(defun emit-function-header (name) + (emit " .global ~A" name) + (emit " .type ~A, %function" name) + (emit "~A:" name)) + +(defun emit-immediate (expr) + (emit " mov x0, ~D" (immediate-rep expr))) + +(defun emit-expr (expr) + (etypecase expr + (immediate (emit-immediate expr)) + (primitive-expression (emit-primitive expr)))) + +(defun emit-program (p) + (check-type p program) + (emit " .text") + (emit-function-header "scheme_entry") + (emit-expr p) + (emit " ret")) + + +;;;; Primitives --------------------------------------------------------------- +(defmacro define-primitive (name arglist &body body) + (let ((function-name (alexandria:symbolicate 'emit-primitive/ name))) + `(progn + (defun ,function-name ,arglist ,@body) + (setf (get ',name 'primitive) t + (get ',name 'arg-count) ,(length arglist) + (get ',name 'emitter) #',function-name) + ',function-name))) + +(defun primitivep (symbol) + (and (typep symbol 'symbol) (get symbol 'primitive))) + +(defun primitive-arg-count + (symbol) (get symbol 'arg-count)) + +(defun primitive-emitter (symbol) + (get symbol 'emitter)) + +(defun emit-primitive (expr) + (destructuring-bind (primitive &rest args) expr + (assert (= (primitive-arg-count primitive) (length args)) () + "Bad primitive expression ~S, wanted ~D arg~:P but got ~D." + expr (primitive-arg-count primitive) (length args)) + (apply (primitive-emitter primitive) args))) + + +(define-primitive fxadd1 (arg) + (emit-expr arg) + (emit " add x0, x0, ~D ~30T// fxadd1" (immediate-rep 1))) + +(define-primitive char->fixnum (arg) + (emit-expr arg) + (emit " lsr x0, x0, #6 ~30T// char->fixnum")) + +(define-primitive fixnum->char (arg) + (emit-expr arg) + (emit " lsl x0, x0, #6 ~30T// fixnum->char") + (emit " orr x0, x0, 0x0F")) + +(define-primitive fxsub1 (arg) + (emit-expr arg) + (emit " sub x0, x0, ~D ~30T// fxsub1" (immediate-rep 1))) + +(define-primitive fxzero? (arg) (TODO)) + +(define-primitive null? (arg) (TODO)) + +(define-primitive fixnum? (arg) + (alexandria:with-gensyms (false) + ;; false #b00101111 + ;; true #b01101111 + (emit-expr arg) + (emit " and x0, x0, 0x03 ~30T// fixnum?") ; mask off all but the tag bits + (emit " cmp x0, 0x00") ; check the remaining tag bits + (emit " mov x0, ~D" #b00101111) ; start with false + (emit " bne ~A" false) + (emit " orr x0, x0, ~D" #b01000000) ; make it true + (emit "~A:" false))) + +(define-primitive boolean? (arg) + (alexandria:with-gensyms (false) + ;; false #b00101111 + ;; true #b01101111 + ;; ^ only bit 6 is different + (emit-expr arg) + (emit " bic x0, x0, ~D ~30T// boolean?" #b01000000) ; turn true into false + (emit " cmp x0, ~D" #b00101111) ; check for false + (emit " mov x0, ~D" #b00101111) ; false + (emit " bne ~A" false) + (emit " orr x0, x0, ~D" #b01000000) ; make it true + (emit "~A:" false))) + +(define-primitive char? (arg) (TODO)) + +(define-primitive not (arg) (TODO)) + + +;;;; Toplevel ----------------------------------------------------------------- +(defun compile-program (program) + (with-open-file (*standard-output* "prog.s" :direction :output :if-exists :supersede) + (emit-program program))) diff -r 000000000000 -r de18bb93f9ec runtime.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/runtime.c Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,47 @@ +#include +#include + +// Bools +#define bool_f 0x2F +#define bool_t 0x6F + +// Fixnums +#define fx_mask 0x03 +#define fx_tag 0x00 +#define fx_shift 2 + +// Characters +#define ch_mask 0xFF +#define ch_tag 0x0F +#define ch_shift 8 + +// Nil +#define nil 0x3F + +typedef uint64_t ptr; + +static void print_ptr(ptr x) { + if ((x & fx_mask) == fx_tag) { + printf("%ld", ((int64_t)x >> fx_shift)); + } else if ((x & ch_mask) == ch_tag) { + printf("#\\%c", ((int)x >> ch_shift)); + } else if (x == bool_f) { + printf("#f"); + } else if (x == bool_t) { + printf("#t"); + } else if (x == nil) { + printf("()"); + } else { + printf("#", x); + } + + printf("\n"); +} + +int main(int argc, char** argv) { + print_ptr(scheme_entry()); + return 0; +} + + + diff -r 000000000000 -r de18bb93f9ec sync --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/sync Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +set -eu + +rsync -av ./ pine:src/iacc/ --exclude='.hg' diff -r 000000000000 -r de18bb93f9ec test --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,5 @@ +#!/usr/bin/env bash + +set -euo pipefail + +rlwrap sbcl --load "test.lisp" --eval "(1am:run)" --quit diff -r 000000000000 -r de18bb93f9ec test.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test.lisp Tue Mar 02 21:42:58 2021 -0500 @@ -0,0 +1,88 @@ +(ql:quickload '(:1am :losh :alexandria)) + +(load (compile-file "iacc.lisp")) + +(defpackage :iacc/test + (:use :cl :losh) + (:use :iacc)) + +(in-package :iacc/test) + +(defun run (program) + (iacc:compile-program program) + (losh:sh '("make" "prog")) + (string-trim '(#\newline) (losh:sh "./prog" :result-type 'string))) + + +(defmacro define-test (name &body body) + `(1am:test ,(intern (concatenate 'string (symbol-name 'test-) (symbol-name name))) + (let ((*package* ,*package*)) + ,@body))) + +(defmacro check (program expected) + `(1am:is (string= ,expected (run ,program)))) + +(define-test fixnums + (check 0 "0") + (check 1 "1") + (check -1 "-1") + (check 10 "10") + (check -10 "-10") + (check 2736 "2736") + (check -2736 "-2736") + (check 536870911 "536870911") + (check -536870912 "-536870912")) + +(define-test booleans + (check :true "#t") + (check :false "#f")) + +(define-test null + (check nil "()")) + +(define-test characters + (check #\a "#\\a") + (check #\A "#\\A") + (check #\space "#\\ ")) + +(define-test primitives/fxadd1 + (check '(fxadd1 0) "1") + (check '(fxadd1 99) "100") + (check '(fxadd1 (fxadd1 202)) "204") + (check '(fxadd1 (fxadd1 -6)) "-4")) + +(define-test primitives/fxsub1 + (check '(fxsub1 1) "0") + (check '(fxsub1 0) "-1") + (check '(fxsub1 99) "98") + (check '(fxsub1 (fxsub1 202)) "200") + (check '(fxsub1 (fxadd1 -6)) "-6")) + +(define-test primitives/char-fixnum-conversion + (check '(char->fixnum #\A) "65") + (check '(fixnum->char 65) "#\\A") + (check '(fixnum->char (fxadd1 (char->fixnum #\A))) "#\\B")) + +(define-test primitives/fixnum? + (check '(fixnum? 1) "#t") + (check '(fixnum? 0) "#t") + (check '(fixnum? -1) "#t") + (check '(fixnum? nil) "#f") + (check '(fixnum? :true) "#f") + (check '(fixnum? :false) "#f") + (check '(fixnum? #\A) "#f")) + +(define-test primitives/boolean? + (check '(boolean? 1) "#f") + (check '(boolean? 0) "#f") + (check '(boolean? -1) "#f") + (check '(boolean? nil) "#f") + (check '(boolean? :true) "#t") + (check '(boolean? :false) "#t") + (check '(boolean? #\A) "#f")) + +(define-test primitives/simple-combos + (check '(boolean? (fixnum? 1)) "#t") + (check '(boolean? (boolean? 1)) "#t") + (check '(fixnum? (char->fixnum #\A)) "#t")) +