iacc.lisp @ 37b7eecfdf6e

;;;; Preamble -----------------------------------------------------------------
(ql:quickload '(:losh :alexandria))

(defpackage :iacc
  (:use :cl)
  (:export :compile-program
    :fxadd1 :fxsub1 :fxzero? :fxlognot
    :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 primitive-expression () '(cons primitive *))
(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 -----------------------------------------------------------
(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 (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))
    (conditional-expression (emit-if 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)
       ',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)))

(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 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 ~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"))

(define-primitive fixnum->char (arg)
  (emit-expr arg)
  (emit "    lsl x0, x0, #6 ~30T// fixnum->char")
  (emit "    orr x0, x0, 0x0F"))


(define-predicate null? (arg)
  (emit-expr arg)
  (emit "    cmp x0, ~D ~30T// null?" +nil+))

(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-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-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-predicate not (arg)
  (emit-expr arg)
  (emit "    cmp x0, ~D ~30T// not" +false+))

(define-primitive fxlognot (arg)
  (emit-expr arg)
  (emit "    mvn x0, x0 ~30T// fxlognot")
  (emit "    and x0, x0, ~D" (lognot #b11)))


;;;; Toplevel -----------------------------------------------------------------
(defun compile-program (program)
  (with-open-file (*standard-output* "prog.s" :direction :output :if-exists :supersede)
    (emit-program program)))