iacc.lisp @ 87674bc4c220

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


;;;; Immediates ---------------------------------------------------------------
;; Tagging scheme:
;; xxxxxxxx…xxxxxx00 fixnum
;; xxxxxxxx…xxxx1111 other immediate
;;
;; Immediates:
;; xxxxxxxx…0000 1111 character
;; xxxxxxxx…0010 1111 false
;; xxxxxxxx…0110 1111 true
;; xxxxxxxx…0011 1111 nil
(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)))


;;;; 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-expr (expr)
  (etypecase expr
    (immediate (emit-immediate expr))
    (primitive-expression (emit-primitive 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)
       ',function-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 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)))


(define-primitive fxadd1 (arg)
  (emit-expr arg)
  (emit "    add x0, x0, ~D ~30T// fxadd1" (immediate-rep 1)))

(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-primitive fxsub1 (arg)
  (emit-expr arg)
  (emit "    sub x0, x0, ~D ~30T// fxsub1" (immediate-rep 1)))

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