37b7eecfdf6e

Add conditionals
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Thu, 04 Mar 2021 20:25:44 -0500
parents 87674bc4c220
children 01ba812a486a
branches/tags (none)
files iacc.lisp runtime.c sync test.lisp

Changes

--- 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)
--- 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 <stdint.h>
 
 // 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;
 
--- 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'
--- 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")