# HG changeset patch # User Steve Losh # Date 1614907544 18000 # Node ID 37b7eecfdf6ec460a604d9d6215dc8857ebd233a # Parent 87674bc4c2203de2dac80461a392ba8abb3022d8 Add conditionals diff -r 87674bc4c220 -r 37b7eecfdf6e iacc.lisp --- a/iacc.lisp Wed Mar 03 21:33:32 2021 -0500 +++ b/iacc.lisp Thu Mar 04 20:25:44 2021 -0500 @@ -18,13 +18,20 @@ ;;;; Types -------------------------------------------------------------------- +(deftype specific-list (&rest args) + (if (null args) + 'null + `(cons ,(first args) (specific-list ,@(rest args))))) + (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)) +(deftype conditional-expression () '(specific-list (eql if) * * *)) +(deftype expression () '(or immediate primitive-expression conditional-expression)) +(deftype program () 'expression) ;;;; Immediates --------------------------------------------------------------- @@ -34,16 +41,21 @@ ;; ;; Immediates: ;; xxxxxxxx…0000 1111 character -;; xxxxxxxx…0010 1111 false -;; xxxxxxxx…0110 1111 true -;; xxxxxxxx…0011 1111 nil +;; xxxxxxxx…0010 1111 nil +;; xxxxxxxx…0001 1111 false +;; xxxxxxxx…0011 1111 true +(defconstant +false+ #b00011111) +(defconstant +true+ #b00111111) +(defconstant +nil+ #b00101111) +(defconstant +char+ #b00001111) + (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))) + (character (logior (ash (char-code object) 8) +char+)) + ((eql :false) +false+) + ((eql :true) +true+) + (null +nil+))) ;;;; Basic Emitters ----------------------------------------------------------- @@ -65,10 +77,30 @@ :unless (zerop chunk) :do (emit " movk x0, 0x~4,'0X, lsl #~D" chunk pos)))) + +(defun emit-if (expr) + (destructuring-bind (condition consequent alternative) (rest expr) + (alexandria:with-gensyms (else endif) + (losh:if-let ((pce (predicate-comparison-emitter condition))) + ;; Instead of doing the check, converting to a boolean, then checking + ;; if the boolean is false, we can fuse the predicate into the if to + ;; avoid all that unnecessary booleanization. + (progn (apply pce (rest condition)) + (emit " bne ~A" else)) + (progn (emit-expr condition) + (emit " cmp x0, ~D ~30T// if" +false+) + (emit " beq ~A" else))) + (emit-expr consequent) + (emit " b ~A" endif) + (emit "~A:" else) + (emit-expr alternative) + (emit "~A:" endif)))) + (defun emit-expr (expr) (etypecase expr (immediate (emit-immediate expr)) - (primitive-expression (emit-primitive expr)))) + (primitive-expression (emit-primitive expr)) + (conditional-expression (emit-if expr)))) (defun emit-program (p) (check-type p program) @@ -86,7 +118,15 @@ (setf (get ',name 'primitive) t (get ',name 'arg-count) ,(length arglist) (get ',name 'emitter) #',function-name) - ',function-name))) + ',name))) + +(defmacro define-predicate (name arglist &body body) + `(progn (define-primitive ,name ,arglist + ,@body + (emit-booleanize)) + (setf (get ',name 'predicate-comparison-emitter) + (lambda ,arglist ,@body)) + ',name)) (defun primitivep (symbol) (and (typep symbol 'symbol) (get symbol 'primitive))) @@ -97,6 +137,10 @@ (defun primitive-emitter (symbol) (get symbol 'emitter)) +(defun predicate-comparison-emitter (expr) + (when (typep expr '(cons symbol *)) + (get (car expr) 'predicate-comparison-emitter))) + (defun emit-primitive (expr) (destructuring-bind (primitive &rest args) expr (assert (= (primitive-arg-count primitive) (length args)) () @@ -105,10 +149,24 @@ (apply (primitive-emitter primitive) args))) +(defun emit-booleanize (&optional (cond "eq")) + "Turn x0 into a boolean, assuming we just did a `cmp` operation." + (emit " cset x0, ~A ~30T// ~40Tbooleanize" cond) + (emit " lsl x0, x0, 5") + (emit " orr x0, x0, ~D" #b00011111)) + (define-primitive fxadd1 (arg) (emit-expr arg) (emit " add x0, x0, ~D ~30T// fxadd1" (immediate-rep 1))) +(define-primitive fxsub1 (arg) + (emit-expr arg) + (emit " sub x0, x0, ~D ~30T// fxsub1" (immediate-rep 1))) + +(define-predicate fxzero? (arg) + (emit-expr arg) + (emit " cmp x0, 0x00 ~30T// fxzero?")) ; Zero is 0, plus tags bits of 0. So just 0. + (define-primitive char->fixnum (arg) (emit-expr arg) (emit " lsr x0, x0, #6 ~30T// char->fixnum")) @@ -118,79 +176,31 @@ (emit " lsl x0, x0, #6 ~30T// fixnum->char") (emit " orr x0, x0, 0x0F")) -(define-primitive fxsub1 (arg) + +(define-predicate null? (arg) (emit-expr arg) - (emit " sub x0, x0, ~D ~30T// fxsub1" (immediate-rep 1))) + (emit " cmp x0, ~D ~30T// null?" +nil+)) -(define-primitive fxzero? (arg) - (alexandria:with-gensyms (false) - ;; false #b00101111 - ;; true #b01101111 - (emit-expr arg) - (emit " cmp x0, 0x00 ~30T// fxzero?") ; Zero is 0, plus tags bits of 0. So just 0. - (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 null? (arg) - (alexandria:with-gensyms (false) - ;; false #b00101111 - ;; true #b01101111 - (emit-expr arg) - (emit " cmp x0, ~D ~30T// null?" #b00111111) - (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-predicate fixnum? (arg) + (emit-expr arg) + (emit " and x0, x0, ~D ~30T// fixnum?" #b11) ; mask off all but the tag bits + (emit " cmp x0, ~D" #b00)) ; check the remaining tag bits -(define-primitive fixnum? (arg) - (alexandria:with-gensyms (false) - ;; false #b00101111 - ;; true #b01101111 - (emit-expr arg) - (emit " and x0, x0, ~D ~30T// fixnum?" #b11) ; mask off all but the tag bits - (emit " cmp x0, ~D" #b00) ; 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-predicate boolean? (arg) + (emit-expr arg) + ;; xxxxxxxx…0001 1111 false + ;; xxxxxxxx…0011 1111 true + (emit " bic x0, x0, ~D ~30T// boolean?" #b00100000) ; turn true into false + (emit " cmp x0, ~D" #b00011111)) ; check for 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-predicate char? (arg) + (emit-expr arg) + (emit " and x0, x0, ~D ~30T// char?" #b11111111) ; mask off all but the tag bits + (emit " cmp x0, ~D" #b00001111)) ; check the remaining tag bits -(define-primitive char? (arg) - (alexandria:with-gensyms (false) - ;; false #b00101111 - ;; true #b01101111 - (emit-expr arg) - (emit " and x0, x0, ~D ~30T// char?" #b11111111) ; mask off all but the tag bits - (emit " cmp x0, ~D" #b00001111) ; 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 not (arg) - (alexandria:with-gensyms (false) - ;; false #b00101111 - ;; true #b01101111 - (emit-expr arg) - (emit " cmp x0, ~D ~30T// not" #b00101111) - (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-predicate not (arg) + (emit-expr arg) + (emit " cmp x0, ~D ~30T// not" +false+)) (define-primitive fxlognot (arg) (emit-expr arg) diff -r 87674bc4c220 -r 37b7eecfdf6e runtime.c --- a/runtime.c Wed Mar 03 21:33:32 2021 -0500 +++ b/runtime.c Thu Mar 04 20:25:44 2021 -0500 @@ -2,8 +2,8 @@ #include // Bools -#define bool_f 0x2F -#define bool_t 0x6F +#define bool_f 0x1F +#define bool_t 0x3F // Fixnums #define fx_mask 0x03 @@ -16,7 +16,7 @@ #define ch_shift 8 // Nil -#define nil 0x3F +#define nil 0x2F typedef uint64_t ptr; diff -r 87674bc4c220 -r 37b7eecfdf6e sync --- a/sync Wed Mar 03 21:33:32 2021 -0500 +++ b/sync Thu Mar 04 20:25:44 2021 -0500 @@ -2,4 +2,4 @@ set -eu -rsync -av ./ pine:src/iacc/ --exclude='.hg' +rsync -av ./ pine:src/iacc/ --exclude='.hg' --exclude='*.fasl' diff -r 87674bc4c220 -r 37b7eecfdf6e test.lisp --- a/test.lisp Wed Mar 03 21:33:32 2021 -0500 +++ b/test.lisp Thu Mar 04 20:25:44 2021 -0500 @@ -4,7 +4,8 @@ (defpackage :iacc/test (:use :cl :losh) - (:use :iacc)) + (:use :iacc) + (:export horrifying-repl)) (in-package :iacc/test) @@ -13,9 +14,19 @@ (losh:sh '("make" "prog")) (string-trim '(#\newline) (losh:sh "./prog" :result-type 'string))) +(defun repl () + (loop :for program = (progn (write-string "> ") + (force-output) + (read)) + :until (equal program 'q) + :do (write-line (run program)))) + +(defun reload () + (load (compile-file "test.lisp"))) + (defmacro define-test (name &body body) - `(1am:test ,(intern (concatenate 'string (symbol-name 'test-) (symbol-name name))) + `(1am:test ,(intern (concatenate 'string (symbol-name 'test/) (symbol-name name))) (let ((*package* ,*package*)) ,@body))) @@ -125,6 +136,30 @@ (check '(not :false) "#t") (check '(not #\A) "#f")) +(define-test if + (check '(if :true 1 2) "1") + (check '(if :false 1 2) "2") + (check '(if nil 1 2) "1")) + +(define-test if/predicate-fusion + (check '(if (null? nil) 1 2) "1") + (check '(if (null? 1) 1 2) "2") + (check '(if (char? nil) 1 2) "2") + (check '(if (char? #\A) 1 2) "1") + (check '(if (boolean? :true) 1 2) "1") + (check '(if (boolean? :false) 1 2) "1") + (check '(if (boolean? nil) 1 2) "2") + (check '(if (boolean? 999) 1 2) "2") + (check '(if (fixnum? 0) 1 2) "1") + (check '(if (fixnum? #\x) 1 2) "2") + (check '(if (fxzero? 0) 1 2) "1") + (check '(if (fxzero? 99) 1 2) "2") + (check '(if (not :false) 1 2) "1") + (check '(if (not :true) 1 2) "2") + (check '(if (not nil) 1 2) "2") + (check '(if (not (fixnum? 0)) 1 2) "2") + (check '(if (not (fixnum? #\x)) 1 2) "1")) + (define-test primitives/simple-combos (check '(fxzero? (fxsub1 (fxadd1 0))) "#t") (check '(boolean? (fixnum? 1)) "#t")