--- 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)