| author |
Steve Losh <steve@stevelosh.com> |
| date |
Wed, 10 Mar 2021 22:01:41 -0500 |
| parents |
37b7eecfdf6e |
| children |
(none) |
;;;; Preamble -----------------------------------------------------------------
(ql:quickload '(:losh :alexandria))
(defpackage :iacc
(:use :cl)
(:export :compile-program
:fxadd1 :fxsub1 :fxzero? :fxlognot
:fx+ :fx- :fx* :fxlogand :fxlogor
:fx= :fx< :fx<= :fx> :fx>=
:char= :char< :char<= :char> :char>=
:fixnum? :char? :null? boolean?
:char->fixnum :fixnum->char
)
(:shadow :fixnum :character :boolean))
(in-package :iacc)
;;;; Utils --------------------------------------------------------------------
(defun todo ()
(error "Not implemented yet."))
;;;; 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 unary-primitive-expression () '(specific-list primitive *))
(deftype binary-primitive-expression () '(specific-list primitive * *))
(deftype primitive-expression ()
'(or unary-primitive-expression binary-primitive-expression))
(deftype conditional-expression ()
'(specific-list (eql if) * * *))
(deftype expression ()
'(or immediate primitive-expression conditional-expression))
(deftype program () 'expression)
;;;; Immediates ---------------------------------------------------------------
;; Tagging scheme:
;; xxxxxxxx…xxxxxx00 fixnum
;; xxxxxxxx…xxxx1111 other immediate
;;
;; Immediates:
;; xxxxxxxx…0000 1111 character
;; 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) +char+))
((eql :false) +false+)
((eql :true) +true+)
(null +nil+)))
;;;; Basic Emitters -----------------------------------------------------------
(defparameter *stack-index* 0)
(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)
;; TODO: Optimize if it can be moved easily.
(let ((bits (immediate-rep expr)))
(emit " mov x0, ~D" (ldb (byte 16 0) bits))
(loop :for pos :from 16 :to 48 :by 16
:for chunk = (ldb (byte 16 pos) bits)
: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 (then endif)
(losh:if-let ((pce (predicate-comparison-emitter condition))
(cond (predicate-cond 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 " b~A ~A ~40T// if" cond then))
(progn (emit-expr condition)
(emit " cmp x0, ~D ~40T// if" +false+)
(emit " bne ~A" then)))
(emit-expr alternative)
(emit " b ~A" endif)
(emit "~A:" then)
(emit-expr consequent)
(emit "~A:" endif))))
(defun emit-expr (expr)
(etypecase expr
(immediate (emit-immediate expr))
(primitive-expression (emit-primitive expr))
(conditional-expression (emit-if expr))))
(defun emit-program (p)
(check-type p program)
(emit " .text")
(emit-function-header "L_scheme_entry")
(let ((*stack-index* 16))
(emit-expr p))
(emit " ret")
(emit-function-header "scheme_entry")
(emit " stp x29, x30, [sp, #-16]! ~40T// Save link register")
(emit " mov x2, sp ~40T// Save C stack pointer")
(emit " mov sp, x0 ~40T// Switch to Lisp stack")
(emit " bl L_scheme_entry")
(emit " mov sp, x2 ~40T// Restore C stack pointer")
(emit " ldp x29, x30, [sp], #16 ~40T// Restore link register")
(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)
',name)))
(defmacro define-predicate (name-and-options arglist &body body)
(destructuring-bind (name &key (cond "eq"))
(alexandria:ensure-list name-and-options)
`(progn (define-primitive ,name ,arglist
,@body
(emit-booleanize ,cond))
(setf (get ',name 'predicate-comparison-emitter)
(lambda ,arglist ,@body)
(get ',name 'predicate-cond)
,cond)
',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 predicate-comparison-emitter (expr)
(when (typep expr '(cons symbol *))
(get (car expr) 'predicate-comparison-emitter)))
(defun predicate-cond (expr)
(when (typep expr '(cons symbol *))
(get (car expr) 'predicate-cond)))
(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)))
(defun emit-booleanize (&optional (cond "eq"))
"Turn x0 into a boolean, assuming we just did a `cmp` operation."
(emit " cset x0, ~A ~40T// booleanize" cond)
(emit " lsl x0, x0, 5")
(emit " orr x0, x0, ~D" #b00011111))
(define-primitive fxadd1 (arg)
(emit-expr arg)
(emit " add x0, x0, ~D ~40T// fxadd1" (immediate-rep 1)))
(define-primitive fxsub1 (arg)
(emit-expr arg)
(emit " sub x0, x0, ~D ~40T// fxsub1" (immediate-rep 1)))
(define-predicate fxzero? (arg)
(emit-expr arg)
(emit " cmp x0, 0x00 ~40T// 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 ~40T// char->fixnum"))
(define-primitive fixnum->char (arg)
(emit-expr arg)
(emit " lsl x0, x0, #6 ~40T// fixnum->char")
(emit " orr x0, x0, 0x0F"))
(define-predicate null? (arg)
(emit-expr arg)
(emit " cmp x0, ~D ~40T// null?" +nil+))
(define-predicate fixnum? (arg)
(emit-expr arg)
(emit " and x0, x0, ~D ~40T// fixnum?" #b11) ; mask off all but the tag bits
(emit " cmp x0, ~D" #b00)) ; check the remaining tag bits
(define-predicate boolean? (arg)
(emit-expr arg)
;; xxxxxxxx…0001 1111 false
;; xxxxxxxx…0011 1111 true
(emit " bic x0, x0, ~D ~40T// boolean?" #b00100000) ; turn true into false
(emit " cmp x0, ~D" #b00011111)) ; check for false
(define-predicate char? (arg)
(emit-expr arg)
(emit " and x0, x0, ~D ~40T// char?" #b11111111) ; mask off all but the tag bits
(emit " cmp x0, ~D" #b00001111)) ; check the remaining tag bits
(define-predicate not (arg)
(emit-expr arg)
(emit " cmp x0, ~D ~40T// not" +false+))
(define-primitive fxlognot (arg)
(emit-expr arg)
(emit " mvn x0, x0 ~40T// fxlognot")
(emit " and x0, x0, ~D" (lognot #b11)))
(defmacro with-stack-saved ((reg1 &optional (reg2 "xzr")) &body body)
"Save the two registers to the stack, perform `body`, then restore.
Each register can be a string, in which case the value will be saved from and
restored to that register. It can also be a list of `(from to)` to allow
restoring to a different register than the source.
"
(destructuring-bind (reg1-from &optional (reg1-to reg1-from))
(alexandria:ensure-list reg1)
(destructuring-bind (reg2-from &optional (reg2-to reg2-from))
(alexandria:ensure-list reg2)
(alexandria:once-only (reg1-from reg1-to reg2-from reg2-to)
`(progn
(emit " stp ~A, ~A, [sp, #-~D]" ,reg1-from ,reg2-from *stack-index*)
(let ((*stack-index* (+ *stack-index* 16)))
,@body)
(emit " ldp ~A, ~A, [sp, #-~D]" ,reg1-to ,reg2-to *stack-index*))))))
(define-primitive fx+ (a b)
(emit-expr a)
(with-stack-saved (("x0" "x1"))
(emit-expr b))
(emit " add x0, x1, x0 ~40T// fx+"))
(define-primitive fx- (a b)
(emit-expr a)
(with-stack-saved (("x0" "x1"))
(emit-expr b))
(emit " sub x0, x1, x0 ~40T// fx-"))
(define-primitive fx* (a b)
(emit-expr a)
(with-stack-saved (("x0" "x1"))
(emit-expr b))
(emit " asr x0, x0, #2 ~40T// fx*")
(emit " mul x0, x1, x0"))
(define-primitive fxlogand (a b)
(emit-expr a)
(with-stack-saved (("x0" "x1"))
(emit-expr b))
(emit " and x0, x1, x0 ~40T// fxlogand"))
(define-primitive fxlogor (a b)
(emit-expr a)
(with-stack-saved (("x0" "x1"))
(emit-expr b))
(emit " orr x0, x1, x0 ~40T// fxlogor"))
(macrolet ((define-primitive-binary-predicate (name cond)
`(define-predicate (,name :cond ,cond) (a b)
(emit-expr a)
(with-stack-saved (("x0" "x1"))
(emit-expr b))
(emit " cmp x1, x0 ~40T// ~A" ,(string-downcase name)))))
(define-primitive-binary-predicate fx= "eq")
(define-primitive-binary-predicate fx< "lt")
(define-primitive-binary-predicate fx<= "le")
(define-primitive-binary-predicate fx> "gt")
(define-primitive-binary-predicate fx>= "ge")
;; If we assume both have the same tag bits of character, we can just compare
;; them directly without bothering to strip off the tag.
(define-primitive-binary-predicate char= "eq")
(define-primitive-binary-predicate char< "lt")
(define-primitive-binary-predicate char<= "le")
(define-primitive-binary-predicate char> "gt")
(define-primitive-binary-predicate char>= "ge"))
;;;; Toplevel -----------------------------------------------------------------
(defun compile-program (program)
(with-open-file (*standard-output* "prog.s" :direction :output :if-exists :supersede)
(emit-program program)))