├── README.md └── lisp-arm-compiler.lisp /README.md: -------------------------------------------------------------------------------- 1 | # Lisp ARM Compiler 2 | This is a simple experimental Lisp compiler, written in Lisp, that will compile a Lisp function into ARM Thumb-1 machine code. 3 | 4 | It is designed for use with my [ARM Thumb assembler written in Lisp](https://github.com/technoblogy/lisp-arm-assembler). 5 | 6 | For more information see [A Lisp compiler for ARM written in Lisp](http://www.ulisp.com/show?4W2I). 7 | -------------------------------------------------------------------------------- /lisp-arm-compiler.lisp: -------------------------------------------------------------------------------- 1 | ; Lisp compiler to ARM Thumb Assembler - Version 2a - 23rd August 2024 2 | ; 3 | 4 | ; Compile a lisp function 5 | 6 | (defun compile (name) 7 | (if (eq (car (eval name)) 'lambda) 8 | (eval (comp (cons 'defun (cons name (cdr (eval name)))))) 9 | (error "Not a Lisp function"))) 10 | 11 | ; The main compile routine - returns compiled code for x, prefixed by type :integer or :boolean 12 | ; Leaves result in r0 13 | 14 | (defun comp (x &optional env) 15 | (cond 16 | ((null x) (type-code :boolean '(($mov 'r0 0)))) 17 | ((eq x t) (type-code :boolean '(($mov 'r0 1)))) 18 | ((symbolp x) (comp-symbol x env)) 19 | ((atom x) (type-code :integer (list (list '$mov ''r0 x)))) 20 | (t (let ((fn (first x)) (args (rest x))) 21 | (case fn 22 | (defun (setq *label-num* 0) 23 | (setq env (mapcar #'(lambda (x y) (cons x y)) (second args) *locals*)) 24 | (comp-defun (first args) (second args) (cddr args) env)) 25 | (progn (comp-progn args env)) 26 | (if (comp-if (first args) (second args) (third args) env)) 27 | (setq (comp-setq args env)) 28 | (t (comp-funcall fn args env))))))) 29 | 30 | ; Utilities 31 | 32 | ; Like mapcon but not destructive 33 | 34 | (defun mappend (fn lst) 35 | (apply #'append (mapcar fn lst))) 36 | 37 | ; The type is prefixed onto the list of assembler code instructions 38 | 39 | (defun type-code (type code) (cons type code)) 40 | 41 | (defun code-type (type-code) (car type-code)) 42 | 43 | (defun code (type-code) (cdr type-code)) 44 | 45 | (defun checktype (fn type check) 46 | (unless (or (null type) (null check) (eq type check)) 47 | (error "Argument to '~a' must be ~a not ~a" fn check type))) 48 | 49 | ; Allocate registers 50 | 51 | (defvar *params* '(r0 r1 r2 r3)) 52 | 53 | (defvar *locals* '(r4 r5 r6 r7)) 54 | 55 | ; Generate a label 56 | 57 | (defvar *label-num* 0) 58 | 59 | (defun gen-label () 60 | (read-from-string (format nil "lab~d" (incf *label-num*)))) 61 | 62 | ; Subfunctions 63 | 64 | (defun comp-symbol (x env) 65 | (let ((reg (cdr (assoc x env)))) 66 | (type-code nil (list (list '$mov ''r0 (list 'quote reg)))))) 67 | 68 | (defun comp-setq (args env) 69 | (let ((value (comp (second args) env)) 70 | (reg (cdr (assoc (first args) env)))) 71 | (type-code 72 | (code-type value) 73 | (append (code value) (list (list '$mov (list 'quote reg) ''r0)))))) 74 | 75 | (defun comp-defun (name args body env) 76 | (let ((used (subseq *locals* 0 (length args)))) 77 | (append 78 | (list 'defcode name args) 79 | (list name (list '$push (list 'quote (cons 'lr (reverse used))))) 80 | (apply #'append 81 | (mapcar #'(lambda (x y) (list (list '$mov (list 'quote x) (list 'quote y)))) 82 | used *params*)) 83 | (code (comp-progn body env)) 84 | (list (list '$pop (list 'quote (append used (list 'pc)))))))) 85 | 86 | (defun comp-progn (exps env) 87 | (let* ((len (1- (length exps))) 88 | (nlast (subseq exps 0 len)) 89 | (last1 (nth len exps)) 90 | (start (mappend #'(lambda (x) (append (code (comp x env)))) nlast)) 91 | (end (comp last1 env))) 92 | (type-code (code-type end) (append start (code end))))) 93 | 94 | (defun comp-if (pred then else env) 95 | (let ((lab1 (gen-label)) 96 | (lab2 (gen-label)) 97 | (test (comp pred env))) 98 | (checktype 'if (car test) :boolean) 99 | (type-code :integer 100 | (append 101 | (code test) (list '($cmp 'r0 0) (list '$beq lab1)) 102 | (code (comp then env)) (list (list '$b lab2) lab1) 103 | (code (comp else env)) (list lab2))))) 104 | 105 | (defun comp-funcall (f args env) 106 | (let ((test (assoc f '((> . $bgt) (>= . $bge) (= . $beq) 107 | (<= . $ble) (< . $blt) (/= . $bne)))) 108 | (logical (assoc f '((and . $and) (or . $orr)))) 109 | (arith1 (assoc f '((1+ . $add) (1- . $sub)))) 110 | (arith+- (assoc f '((+ . $add) (- . $sub)))) 111 | (arith2 (assoc f '((* . $mul) (logand . $and) (logior . $orr) (logxor . $eor))))) 112 | (cond 113 | (test 114 | (let ((label (gen-label))) 115 | (type-code :boolean 116 | (append 117 | (comp-args f args 2 :integer env) 118 | (list '($pop '(r1)) '($mov 'r2 1) '($cmp 'r1 'r0) 119 | (list (cdr test) label) '($mov 'r2 0) label '($mov 'r0 'r2)))))) 120 | (logical 121 | (type-code :boolean 122 | (append 123 | (comp-args f args 2 :boolean env) 124 | (list '($pop '(r1)) (list (cdr logical) ''r0 ''r1))))) 125 | (arith1 126 | (type-code :integer 127 | (append 128 | (comp-args f args 1 :integer env) 129 | (list (list (cdr arith1) ''r0 1))))) 130 | (arith+- 131 | (type-code :integer 132 | (append 133 | (comp-args f args 2 :integer env) 134 | (list '($pop '(r1)) (list (cdr arith+-) ''r0 ''r1 ''r0))))) 135 | (arith2 136 | (type-code :integer 137 | (append 138 | (comp-args f args 2 :integer env) 139 | (list '($pop '(r1)) (list (cdr arith2) ''r0 ''r1))))) 140 | ((member f '(car cdr)) 141 | (type-code :integer 142 | (append 143 | (comp-args f args 1 :integer env) 144 | (if (eq f 'cdr) (list '($ldr 'r0 '(r0 4))) 145 | (list '($ldr 'r0 '(r0 0)) '($ldr 'r0 '(r0 4))))))) 146 | (t ; function call 147 | (type-code :integer 148 | (append 149 | (comp-args f args nil :integer env) 150 | (when (> (length args) 1) 151 | (append 152 | (list (list '$mov (list 'quote (nth (1- (length args)) *params*)) ''r0)) 153 | (mappend 154 | #'(lambda (x) (list (list '$pop (list 'quote (list x))))) 155 | (reverse (subseq *params* 0 (1- (length args))))))) 156 | (list (list '$bl f)))))))) 157 | 158 | (defun comp-args (fn args n type env) 159 | (unless (or (null n) (= (length args) n)) 160 | (error "Incorrect number of arguments to '~a'" fn)) 161 | (let ((n (length args))) 162 | (mappend #'(lambda (y) 163 | (let ((c (comp y env))) 164 | (decf n) 165 | (checktype fn type (code-type c)) 166 | (if (zerop n) (code c) (append (code c) '(($push '(r0))))))) 167 | args))) --------------------------------------------------------------------------------