de18bb93f9ec

Initial commit
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 02 Mar 2021 21:42:58 -0500
parents
children 87674bc4c220
branches/tags (none)
files .hgignore Makefile README.markdown iacc.lisp runtime.c sync test test.lisp

Changes

--- /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
--- /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
+
--- /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 <https://raw.githubusercontent.com/namin/inc/master/docs/tutorial.pdf>, but
+using Common Lisp as the implementation language and ARM64 as the target.
--- /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)))
--- /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 <stdio.h>
+#include <stdint.h>
+
+// 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("#<unknown #x%016lx>", x);
+    }
+
+    printf("\n");
+}
+
+int main(int argc, char** argv) {
+    print_ptr(scheme_entry());
+    return 0;
+}
+
+
+
--- /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'
--- /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
--- /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"))
+