├── .gitignore ├── pic-test.asd ├── LICENSE ├── pic.asd ├── expample └── led.lisp ├── t └── pic.lisp ├── README.markdown └── src └── pic.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /pic-test.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of pic project. 3 | Copyright (c) 2015 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage pic-test-asd 8 | (:use :cl :asdf)) 9 | (in-package :pic-test-asd) 10 | 11 | (defsystem pic-test 12 | :author "Masayuki Takagi" 13 | :license "MIT" 14 | :depends-on (:pic 15 | :prove) 16 | :components ((:module "t" 17 | :components 18 | ((:file "pic")))) 19 | :perform (load-op :after (op c) (asdf:clear-system c))) 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Masayuki Takagi 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /pic.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of pic project. 3 | Copyright (c) 2015 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage pic-asd 8 | (:use :cl :asdf)) 9 | (in-package :pic-asd) 10 | 11 | (defsystem pic 12 | :version "0.1" 13 | :author "Masayuki Takagi" 14 | :license "MIT" 15 | :depends-on (:alexandria :cl-pattern) 16 | :components ((:module "src" 17 | :components 18 | ((:file "pic")))) 19 | :description "A native compiler for 8-bit PIC micro controllers witten in Common Lisp." 20 | :long-description 21 | #.(with-open-file (stream (merge-pathnames 22 | #p"README.markdown" 23 | (or *load-pathname* *compile-file-pathname*)) 24 | :if-does-not-exist nil 25 | :direction :input) 26 | (when stream 27 | (let ((seq (make-array (file-length stream) 28 | :element-type 'character 29 | :fill-pointer t))) 30 | (setf (fill-pointer seq) (read-sequence seq stream)) 31 | seq))) 32 | :in-order-to ((test-op (load-op pic-test)))) 33 | -------------------------------------------------------------------------------- /expample/led.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of pic project. 3 | Copyright (c) 2015 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :pic) 7 | 8 | ;;; 9 | ;;; LED example 10 | ;;; 11 | 12 | (defpic mdelay1 () 13 | (loop #xf8 ; 0xF8 is a magic number to delay 14 | (nop))) ; for 1 msec 15 | 16 | (defpicmacro mdelay (n) 17 | (check-type n (unsigned-byte 16)) 18 | (multiple-value-bind (q r) (truncate n 256) 19 | (cond 20 | ((and (> q 0) (> r 0)) `(progn 21 | (loop ,q (loop 0 (mdelay1))) 22 | (loop ,r (mdelay1)))) 23 | ((> q 0) `(loop ,q (loop 0 (mdelay1)))) 24 | ((> r 0) `(loop ,r (mdelay1))) 25 | (t '(nop))))) 26 | 27 | (defpic init () 28 | (progn 29 | (setreg :gpio #x0) ; clera GP0-5 30 | (setreg :cmcon0 #x07) ; disable comparator 31 | (setbank1) ; switch to bank 1 32 | (setreg :trisio #x08) ; only GP3 is input mode 33 | (setreg :ansel #x00) ; disable analog IO 34 | (setreg :ioc #x00) ; disable interruption 35 | (setbank0) ; switch to bank 0 36 | (setreg :intcon #x00))) ; disable interruption 37 | 38 | (defpic main () 39 | (progn 40 | (setreg :gpio #x20) ; set GP5 to high 41 | (mdelay 50) ; delay for 50 msec 42 | (setreg :gpio #x00) ; set GP5 to low 43 | (mdelay 950) ; delay for 950 msec 44 | (main))) ; repeat 45 | -------------------------------------------------------------------------------- /t/pic.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of pic project. 3 | Copyright (c) 2015 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage pic-test 8 | (:use :cl 9 | :pic 10 | :prove)) 11 | (in-package :pic-test) 12 | 13 | (plan nil) 14 | 15 | 16 | ;;; 17 | ;;; K-normalization 18 | ;;; 19 | 20 | (is (pic::k-normal (pic::empty-k-normal-environment) '(pic::with-args (x y) 21 | (- x y))) 22 | '(pic::with-args (x y) 23 | (let ((pic::tmpa x)) 24 | (let ((pic::tmpb y)) 25 | (- pic::tmpa pic::tmpb)))) 26 | "K-normalization for WITH-ARGS form.") 27 | 28 | 29 | ;;; 30 | ;;; Immediates optimization 31 | ;;; 32 | 33 | (is (pic::immediates (pic::empty-immediates-environment) '(let ((x (pic::set 1))) 34 | (pic::mov x))) 35 | `(pic::set 1)) 36 | 37 | 38 | ;;; 39 | ;;; Register assignment 40 | ;;; 41 | 42 | (is (pic::register-environment-input-register 'x '((pic::call foo x))) 43 | :I0) 44 | 45 | (is (pic::register-environment-input-register 'x '((pic::call foo x x))) 46 | nil) 47 | 48 | (is (pic::register-environment-input-register 'x '((let ((y (pic::mov x))) 49 | (pic::call foo x)))) 50 | :I0) 51 | 52 | (is (pic::register-environment-input-register 'x '((let ((y (pic::call foo x))) 53 | (pic::mov x)))) 54 | nil) 55 | 56 | (is (pic::register-environment-input-register 'x '((pic::ifeq x x 57 | (pic::call foo x) 58 | (pic::call bar x)))) 59 | :I0) 60 | 61 | (is (pic::register-environment-input-register 'x '((pic::ifeq x x 62 | (pic::call foo x) 63 | (pic::call bar y x)))) 64 | nil) 65 | 66 | (is (pic::register-environment-input-register 'x '((pic::ifeq x x 67 | (let ((y (pic::call foo x))) 68 | (pic::mov x)) 69 | (pic::call bar x)))) 70 | nil) 71 | 72 | (is (pic::register-environment-input-register 'x '((pic::ifeq x x 73 | (pic::call foo x) 74 | (pic::mov x)))) 75 | :I0) 76 | 77 | (is (pic::register-environment-input-register 'x '((loop 5 78 | (pic::call foo x)))) 79 | nil 80 | "Variables used for function call parameters in LOOP instructions are not assigned to input registers.") 81 | 82 | (let ((form '(let ((tmp0 (set 1))) 83 | (loop tmp0 84 | (let ((tmp1 (set 1))) 85 | (loop tmp1 86 | (let ((tmp2 (set 1))) 87 | (loop tmp2 88 | (let ((tmp3 (set 1))) 89 | (loop tmp3 90 | (let ((tmp4 (set 1))) 91 | (loop tmp4 92 | (let ((tmp5 (set 1))) 93 | (loop tmp5 94 | (let ((tmp6 (set 1))) 95 | (loop tmp6 96 | (let ((tmp7 (set 1))) 97 | (loop tmp7 98 | (let ((tmp8 (set 1))) 99 | tmp8))))))))))))))))))) 100 | (is-error (pic::assign (pic::empty-register-environment) nil form) 101 | 'simple-error 102 | "LOOP instructions keep couter registers in their scope.")) 103 | 104 | 105 | (finalize) 106 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # PIC - PIC Is a Compiler for 8-bit PIC micro controllers 2 | 3 | A native compiler for 8-bit PIC micro controllers written in Common Lisp. The host language is a pretty small subset of ML-like language and the target language is 8-bit PIC micro controller assembly. Common Lisp is the compiler language. 4 | 5 | ## Usage 6 | 7 | Following is an example of LED blinking with PIC12F683 micro controller. `init` function is one of the compiler's special functions, where the micro controller's SFR(Special Function Registers) are initialized. Following `main` function is also the compiler's special function and program's main routine is executed here. 8 | 9 | `mdelay1` function and `mdelay` macro are for delaying. Note that since 8-bit PIC handles only 8-bit unsigned integers, nested loops are needed for delaying more than 255 msec (950 msec here). `progn` and `loop` are predefined macros for the compiler. 10 | 11 | (defpic init () 12 | (progn 13 | (setreg :gpio #x0) ; clera GP0-5 14 | (setreg :cmcon0 #x07) ; disable comparator 15 | (setbank1) ; switch to bank 1 16 | (setreg :trisio #x08) ; only GP3 is outputinputmode 17 | (setreg :ansel #x00) ; disable analog IO 18 | (setreg :ioc #x00) ; disable interruption 19 | (setbank0) ; switch to bank 0 20 | (setreg :intcon #x00))) ; disable interruption 21 | 22 | (defpic main () 23 | (progn 24 | (setreg :gpio #x20) ; set GP5 to high 25 | (mdelay 50) ; delay for 50 msec 26 | (setreg :gpio #x00) ; set GP5 to low 27 | (mdelay 950) ; delay for 950 msec 28 | (main))) ; repeat 29 | 30 | (defpic mdelay1 () 31 | (loop #xf8 ; 0xF8 is a magic number to delay 32 | 0)) ; for 1 msec 33 | 34 | (defpicmacro mdelay (n) 35 | (unless (<= 0 n 65535) 36 | (error "The value ~S is invalid." n)) 37 | (multiple-value-bind (q r) (truncate n 256) 38 | (if (= q 0) 39 | `(loop ,r (mdelay1)) 40 | `(loop ,q (loop ,r (mdelay1)))))) 41 | 42 | Then `pic-compile` function compiles and outputs the complete assembly for the PIC functions to standard output. The output assembly is expected to be assembled with Microchip's MPASM assembler. 43 | 44 | PIC> (pic-compile) 45 | INCLUDE"p12f683.inc" 46 | list p=12f683 47 | 48 | __CONFIG _CP_OFF & _CPD_OFF & _WDT_OFF & _BOD_ON & _IESO_OFF& _PWRTE_ON & _INTOSCIO & _MCLRE_OFF 49 | 50 | CBLOCK 020h 51 | L0,L1,L2,L3,L4,L5,L6,L7 ; local registers 52 | I0,I1,I2,I3,I4,I5,I6,I7 ; input registers 53 | NULL ; null registers 54 | SP,STMP,STK ; stack registers 55 | ENDC 56 | 57 | ORG 0 58 | GOTO MAIN 59 | ... 60 | END 61 | ; No value 62 | 63 | ## Installation 64 | 65 | Since PIC is not available on Quicklisp distribution yet, please use its local-projects feature. 66 | 67 | $ ~/quicklisp/local-projects 68 | $ git clone git://github.com/takagi/pic.git 69 | 70 | Then `(ql:quickload :pic)` from `REPL` to load it. I will request PIC to Quicklisp soon. 71 | 72 | ## API 73 | 74 | ### [Macro] defpic 75 | 76 | DEFPIC name arguments expression 77 | 78 | Defines a PIC function. At least, `main` special function must be defined. `pic-disassemble` shows the compiled assembly of a PIC function. 79 | 80 | ### [Macro] defpicmacro 81 | 82 | DEFPICMACRO name arguments form 83 | 84 | Defines a PIC macro. `pic-macroexpand` returns an expansion for a PIC macro form. 85 | 86 | ### [Function] pic-compile 87 | 88 | PIC-COMPILE 89 | 90 | Compiles and outputs the complete assembly for PIC functions defined with `defpic` macro to `*standard-output*`. The output assembly is expected to be assembled with Microchip's MPASM assembler. 91 | 92 | ### [Function] pic-disassemble 93 | 94 | PIC-DISASSEMBLE name 95 | 96 | Shows the compiled assembly of a function specified with `name`. 97 | 98 | ### [Function] pic-macroexpand, pic-macroexpand1 99 | 100 | PIC-MACROEXPAND form => expansion, expanded-p 101 | 102 | PIC-MACROEXPAND1 form => expansion, expanded-p 103 | 104 | Returns a macro expansion of `form`. If `form` is a macro form, then `pic-macroexpand1` expands the macro form call once. `pic-macroexpand` repeatedly expands `form` until it is no longer a macro form. If `form` is a macro form, then the `expansion` is a macro expansion and `expanded-p` is `t`. Otherwise, the `expansion` is the given `form` and `expanded-p` is `nil`. 105 | 106 | ### [Function] pic-clear 107 | 108 | PIC-CLEAR 109 | 110 | Clears all defined PIC functions. PIC macros are not cleared, which individually do not affect compiled assembly. 111 | 112 | ## Language 113 | 114 | ### Data 115 | 116 | The compiler has only unsigned 8-bit integer as its data structure. 117 | 118 | ### Syntax 119 | 120 | The compiler has the following syntax. 121 | 122 | * literal 123 | * arithmetic operations 124 | * conditional branches 125 | * variable bindings 126 | * variable reference 127 | * local function definitions 128 | * function applications 129 | * loop 130 | * writing to registers 131 | 132 | #### Literal 133 | 134 | 42 135 | 136 | Literal for 8-bit unsigned integers is only allowed for now. 137 | 138 | #### Arithmetic operations 139 | 140 | (- 2 1) 141 | 142 | Subtraction for two 8-bit unsigned integers is only allowed for now. 143 | 144 | #### Conditional branches 145 | 146 | (if (= x 0) 147 | 42 148 | 0) 149 | 150 | Equality testing for 8-bit unsigned integers is only allowed for now. 151 | 152 | #### Variable bindings and its reference 153 | 154 | (let ((x 42)) 155 | (let ((y 1)) 156 | (- x y))) 157 | 158 | Binds an expression to a variable and reference it. Only one variable is bound for each `let` form for now. 159 | 160 | 161 | #### Local function definitions 162 | 163 | (let ((foo (x) (+ x 42))) 164 | (foo 100)) 165 | 166 | Locally defines a function. It can be called recursively. Making closures and having free variables are not allowed for now. 167 | 168 | 169 | #### Function applications 170 | 171 | (foo 42) 172 | 173 | Calls a function which is defined with `defpic` macro or a local function definition. Tail calls are compiled into `GOTO` instruction, not `CALL` instruction. 174 | 175 | #### Loop 176 | 177 | (loop 42 (do-something)) 178 | 179 | Releatedly executes the body part for the specified times. 180 | 181 | #### Writing to registers 182 | 183 | (setreg :gpio #x20) 184 | 185 | Writes a value into the micro controller's SFR (Special Function Registers). This is an only syntax that causes side effects. 186 | 187 | ### Macro 188 | 189 | The compiler has the macro feature as well as Common Lisp does. Its macros are defined with `defpicmacro` Common Lisp macro. The following PIC macros are predefined. 190 | 191 | #### [PIC-Macro] progn 192 | 193 | PROGN expression* 194 | 195 | Sequentially evaluates the given expressions. Actually they are expanded into a series of let bindings, where temporal assignments should be removed properly in optimization. 196 | 197 | (progn 198 | (setreg :gpio #x00) 199 | (setreg :gpio #x01) 200 | (setreg :gpio #x02) 201 | (setreg :gpio #x04)) 202 | 203 | ==> 204 | 205 | (let ((tmp (setreg :gpio #x00))) 206 | (let ((tmp (setreg :gpio #x01))) 207 | (let ((tmp (setreg :gpio #x02))) 208 | (setreg :gpio #x03)))) 209 | 210 | #### [PIC-Macro] nop 211 | 212 | NOP 213 | 214 | Consumes a instruction cycle. 215 | 216 | (nop) ==> (setreg :null #x00) 217 | 218 | #### [PIC-Macro] setbank0 219 | 220 | SETBANK0 221 | 222 | Sets the current bank to bank 0. 223 | 224 | (setbank0) ==> (setreg :status #x00) 225 | 226 | #### [PIC-Macro] setbank1 227 | 228 | SETBANK1 229 | 230 | Sets the current bank to bank 1. 231 | 232 | (setbank1) ==> (setreg :status #x20) 233 | 234 | ### Special functions 235 | 236 | The compiler has the following special functions. Required to be defined is only `main`. `init` and `intr` are optional. 237 | 238 | * `init` 239 | * `main` 240 | * `intr` 241 | 242 | Just after the micro controller is powered, `init` special function is called. Then, `main` special function is called soon after `init` special function has returned. `intr` special function is called when an interruption occurs. 243 | 244 | ### [PIC-Function] init 245 | 246 | INIT 247 | 248 | Optional. `init` is called soon after the micro controller is powered. It must have no arguments. Expected is that some initializing operations are done in `init` special function. 249 | 250 | (defpic init () 251 | (setbank1) 252 | (setreg :trisio #x08) ; set pin 4 only to output mode 253 | (setbank0) 254 | (setreg :gpio #x00)) ; set GPIO to low 255 | 256 | ### [PIC-Function] main 257 | 258 | MAIN 259 | 260 | Required. `main` is called next to `init` special function. It must have no arguments. Expected is that main operations are done in `main` special function. Often it ends with a recursive call to itself to make infinite loop. 261 | 262 | (defpic main () 263 | (do-main-operations) 264 | (main)) ; call itself to repeat the main operations 265 | 266 | ### [PIC-Function] intr 267 | 268 | INTR 269 | 270 | Optional. `intr` is called when an interruption occurs. It must have no arguments. Expected is that some operations to accept interruptions are done in `intr` special function. It naturally returns with `RETFIE` instruction to the address where the interruption has occured. 271 | 272 | (defpic intr () 273 | (do-some-interruption-operations)) 274 | 275 | ## Design 276 | 277 | ### Overview 278 | 279 | The host language is a pretty small subset of ML-like language and the target language is 8-bit PIC micro controller assembly. Common Lisp is the compiler language. Overall design of the compiler is based on [MinCaml](http://esumii.github.io/min-caml/). 280 | 281 | ### Calling convention 282 | 283 | The compiler uses the following 'pseudo-registers' allocated in a particular part in the data memory for function calling. 284 | 285 | * input pseudo-registers `I0-I7` 286 | * local pseudo-registers `L0-L7` 287 | 288 | On calling a function, its parameters are stored to be passed in the input pseudo-registers. Return values are stored in W register. Functions can use the local pseudo-registers freely for themselves. To avoid destroying the values in a caller function's 'alive' local pseudo-registers, they are saved in the software stack before calling. After returning from the callee function, they are restored. Here 'alive' means the registers are used after returning from the callee function. About the software stack, see the next section. 289 | 290 | ### Software stack 291 | 292 | The compiler uses a software stack for saving the values in local pseudo-registers. The term 'software stack' means distinguishing it from the micro controller's hardware stack. It begins from the address `STK` upwords and the stack pointer is stored in the address `SP`. For pushing a content in W register on top of the stack, `_PUSH_STACK` assembler macro does the work. Conversely, `_POP_STACK` assembler macro pops back a value on top of the stack into W register. Currently, saving values in local pseudo-registers is the only usage of the software stack. 293 | 294 | ### Why no closures? 295 | 296 | To adopt closures, calling to indirect address is required. However 8-bit PIC assembly's `CALL` instruction accepts only immediates for its destination address. Although calling to indirect address is possible with writing an address directly into the program counter, it is accompanied by the following instricates: 297 | 298 | * managing not only `PCL` but `PCLATH` 299 | * calculating the return address 300 | * managing return address manually without the hardware stack 301 | * considering `PCL` carry out 302 | 303 | Because of them, closures are not adopted for now. 304 | 305 | ## Slide 306 | 307 | * [Lisp Meet Up #25, 8-bit PIC マイコン用ネイティブコンパイラの作成](http://www.slideshare.net/masayukitakagi/2015-0225-45131616) 308 | 309 | ## See also 310 | 311 | * [MinCaml](http://esumii.github.io/min-caml/) 312 | 313 | ## Author 314 | 315 | * Masayuki Takagi (kamonama@gmail.com) 316 | 317 | ## Copyright 318 | 319 | Copyright (c) 2015 Masayuki Takagi (kamonama@gmail.com) 320 | 321 | # License 322 | 323 | Licensed under the MIT License. 324 | -------------------------------------------------------------------------------- /src/pic.lisp: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of pic project. 3 | Copyright (c) 2015 Masayuki Takagi (kamonama@gmail.com) 4 | |# 5 | 6 | (in-package :cl-user) 7 | (defpackage pic 8 | (:use :cl) 9 | (:export ;; Programming Interfaces 10 | :defpic 11 | :defpicmacro 12 | :pic-compile 13 | :pic-disassemble 14 | :pic-macroexpand 15 | :pic-macroexpand1 16 | :pic-clear 17 | ;; Syntax 18 | :setreg 19 | ;; Special Functions 20 | :init 21 | :main 22 | :intr 23 | ;; Macros 24 | :progn 25 | :loop 26 | :setbank0 27 | :setbank1) 28 | (:import-from :alexandria 29 | :symbolicate 30 | :make-keyword 31 | :hash-table-keys)) 32 | (in-package :pic) 33 | 34 | 35 | ;;; 36 | ;;; Utilities 37 | ;;; 38 | 39 | (defun singlep (object) 40 | (and (consp object) 41 | (null (cdr object)))) 42 | 43 | (defun flatten-list (x) 44 | (labels ((rec (x acc) 45 | (cond ((null x) acc) 46 | ((atom x) (cons x acc)) 47 | (t (rec (car x) (rec (cdr x) acc)))))) 48 | (rec x nil))) 49 | 50 | (defun compile-token (token) 51 | (cond 52 | ((pic-symbol-p token) 53 | (let ((token1 (substitute #\_ #\- (symbol-name token)))) 54 | (if (keywordp token) 55 | token1 56 | (format nil "_~A" token1)))) 57 | ((pic-int-p token) (format nil "~3,'0Xh" token)) 58 | (t (error "The value ~S is an invalid token." token)))) 59 | 60 | (defun make-unique-symbol (object) 61 | (gensym (princ-to-string object))) 62 | 63 | 64 | ;;; 65 | ;;; Data structure 66 | ;;; 67 | 68 | (defun pic-symbol-p (object) 69 | (and object 70 | (symbolp object))) 71 | 72 | (defun pic-reg-p (object) 73 | (and (pic-symbol-p object) 74 | (keywordp object))) 75 | 76 | (defun pic-int-p (object) 77 | (and (integerp object) 78 | (<= 0 object 255))) 79 | 80 | 81 | ;;; 82 | ;;; Syntax 83 | ;;; 84 | 85 | (defun literal-p (object) 86 | (pic-int-p object)) 87 | 88 | (defun reference-p (object) 89 | (pic-symbol-p object)) 90 | 91 | (defun sub-p (object) 92 | (cl-pattern:match object 93 | (('- . _) t) 94 | (_ nil))) 95 | 96 | (defun sub-expr1 (form) 97 | (cl-pattern:match form 98 | (('- expr1 _) expr1) 99 | (('- . _) (error "The form ~S is malformed." form)) 100 | (_ (error "The value ~S is an invalid form." form)))) 101 | 102 | (defun sub-expr2 (form) 103 | (cl-pattern:match form 104 | (('- _ expr2) expr2) 105 | (('- . _) (error "The form ~S is malformed." form)) 106 | (_ (error "The value ~S is an invalid form." form)))) 107 | 108 | (defun ifeq-p (object) 109 | (cl-pattern:match object 110 | (('if . _) t) 111 | (_ nil))) 112 | 113 | (defun ifeq-lhs (form) 114 | (cl-pattern:match form 115 | (('if ('= lhs _) _ _) lhs) 116 | (('if . _) (error "The form ~S is malformed." form)) 117 | (_ (error "The value ~S is an invalid form." form)))) 118 | 119 | (defun ifeq-rhs (form) 120 | (cl-pattern:match form 121 | (('if ('= _ rhs) _ _) rhs) 122 | (('if . _) (error "The form ~S is malformed." form)) 123 | (_ (error "The value ~S is an invalid form." form)))) 124 | 125 | (defun ifeq-then (form) 126 | (cl-pattern:match form 127 | (('if ('= _ _) then _) then) 128 | (('if . _) (error "The form ~S is malformed." form)) 129 | (_ (error "The value ~S is an invalid form." form)))) 130 | 131 | (defun ifeq-else (form) 132 | (cl-pattern:match form 133 | (('if ('= _ _) _ else) else) 134 | (('if . _) (error "The form ~S is malformed." form)) 135 | (_ (error "The value ~S is an invalid form." form)))) 136 | 137 | (defun let-p (object) 138 | (cl-pattern:match object 139 | (('let ((_ _)) _) t) 140 | (_ nil))) 141 | 142 | (defun let-var (form) 143 | (cl-pattern:match form 144 | (('let ((var _)) _) 145 | (if (pic-symbol-p var) 146 | var 147 | (error "The form ~S is malformed." form))) 148 | (('let . _) (error "The form ~S is malformed." form)) 149 | (_ (error "The value ~S is an invalid form." form)))) 150 | 151 | (defun let-expr (form) 152 | (cl-pattern:match form 153 | (('let ((_ expr)) _) expr) 154 | (('let . _) (error "The form ~S is malformed." form)) 155 | (_ (error "The value ~S is an invalid form." form)))) 156 | 157 | (defun let-body (form) 158 | (cl-pattern:match form 159 | (('let ((_ _)) body) body) 160 | (('let . _) (error "The form ~S is malformed." form)) 161 | (_ (error "The value ~S is an invalid form." form)))) 162 | 163 | (defun letrec-p (object) 164 | (cl-pattern:match object 165 | (('let ((_ _ _)) _) t) 166 | (_ nil))) 167 | 168 | (defun letrec-name (form) 169 | (cl-pattern:match form 170 | (('let ((name _ _)) _) 171 | (if (pic-symbol-p name) 172 | name 173 | (error "The form ~S is malformed." form))) 174 | (('let . _) (error "The form ~S is malformed." form)) 175 | (_ (error "The value ~S is an invalid form." form)))) 176 | 177 | (defun letrec-args (form) 178 | (cl-pattern:match form 179 | (('let ((_ args _)) _) 180 | (if (every #'pic-symbol-p args) 181 | args 182 | (error "The form ~S is malformed." form))) 183 | (('let . _) (error "The form ~S is malformed." form)) 184 | (_ (error "The value ~S is an invalid form." form)))) 185 | 186 | (defun letrec-expr (form) 187 | (cl-pattern:match form 188 | (('let ((_ _ expr)) _) expr) 189 | (('let . _) (error "The form ~S is malformed." form)) 190 | (_ (error "The value ~S is an invalid form." form)))) 191 | 192 | (defun letrec-body (form) 193 | (cl-pattern:match form 194 | (('let ((_ _ _)) body) body) 195 | (('let . _) (error "The form ~S is malformed." form)) 196 | (_ (error "The value ~S is an invalid form." form)))) 197 | 198 | (defun with-args-p (object) 199 | (cl-pattern:match object 200 | (('with-args . _) t) 201 | (_ nil))) 202 | 203 | (defun with-args-args (form) 204 | (cl-pattern:match form 205 | (('with-args args _) args) 206 | (('with-args . _) (error "The form ~S is malformed." form)) 207 | (_ (error "The value ~S is an invalid form." form)))) 208 | 209 | (defun with-args-body (form) 210 | (cl-pattern:match form 211 | (('with-args _ body) body) 212 | (('with-args . _) (error "The form ~S is malformed." form)) 213 | (_ (error "The value ~S is an invalid form." form)))) 214 | 215 | (defun loop-p (object) 216 | (cl-pattern:match object 217 | (('loop . _) t) 218 | (_ nil))) 219 | 220 | (defun loop-times (form) 221 | (cl-pattern:match form 222 | (('loop times _) times) 223 | (('loop . _) (error "The form ~S is malformed." form)) 224 | (_ (error "The value ~S is an invalid form." form)))) 225 | 226 | (defun loop-body (form) 227 | (cl-pattern:match form 228 | (('loop _ body) body) 229 | (('loop . _) (error "The form ~S is malformed." form)) 230 | (_ (error "The value ~S is an invalid form." form)))) 231 | 232 | (defun setreg-p (object) 233 | (cl-pattern:match object 234 | (('setreg . _) t) 235 | (_ nil))) 236 | 237 | (defun setreg-reg (form) 238 | (cl-pattern:match form 239 | (('setreg reg _) 240 | (if (pic-reg-p reg) 241 | reg 242 | (error "The form ~S is malformed." form))) 243 | (('setreg . _) (error "The form ~S is malformed." form)) 244 | (_ (error "The value ~S is an invalid form." form)))) 245 | 246 | (defun setreg-expr (form) 247 | (cl-pattern:match form 248 | (('setreg _ expr) expr) 249 | (('setreg . _) (error "The form ~S is malformed." form)) 250 | (_ (error "The value ~S is an invalid form." form)))) 251 | 252 | (defun apply-p (object) 253 | (cl-pattern:match object 254 | ((name . _) (pic-symbol-p name)) 255 | (_ nil))) 256 | 257 | (defun apply-operator (form) 258 | (unless (apply-p form) 259 | (error "The value ~S is an invalid form." form)) 260 | (car form)) 261 | 262 | (defun apply-operands (form) 263 | (unless (apply-p form) 264 | (error "The value ~S is an invalid form." form)) 265 | (cdr form)) 266 | 267 | (defun macro-p (form) 268 | (cl-pattern:match form 269 | ((name . _) (and (symbolp name) 270 | (get name 'pic-macro) 271 | t)) 272 | (_ nil))) 273 | 274 | (defun macro-name (form) 275 | (unless (macro-p form) 276 | (error "The value ~S is an invalid.form." form)) 277 | (car form)) 278 | 279 | (defun macro-operands (form) 280 | (unless (macro-p form) 281 | (error "The value ~S is an invalid.form." form)) 282 | (cdr form)) 283 | 284 | (defun macro-expander (form) 285 | (unless (macro-p form) 286 | (error "The value ~S is an invalid.form." form)) 287 | (get (macro-name form) 'pic-macro)) 288 | 289 | 290 | ;;; 291 | ;;; Virtual Machine Instructions 292 | ;;; 293 | 294 | (defun let-inst-p (object) 295 | (cl-pattern:match object 296 | (('let ((_ _)) _) t) 297 | (_ nil))) 298 | 299 | (defun let-inst-var (form) 300 | (cl-pattern:match form 301 | (('let ((var _)) _) var) 302 | (('let . _) (error "The form ~S is malformed." form)) 303 | (_ (error "The value ~S is an invalid form." form)))) 304 | 305 | (defun let-inst-expr (form) 306 | (cl-pattern:match form 307 | (('let ((_ expr)) _) expr) 308 | (('let . _) (error "The form ~S is malformed." form)) 309 | (_ (error "The value ~S is an invalid form." form)))) 310 | 311 | (defun let-inst-body (form) 312 | (cl-pattern:match form 313 | (('let ((_ _)) body) body) 314 | (('let . _) (error "The form ~S is malformed." form)) 315 | (_ (error "The value ~S is an invalid form." form)))) 316 | 317 | (defun letrec-inst-p (object) 318 | (cl-pattern:match object 319 | (('let ((_ _ _)) _) t) 320 | (_ nil))) 321 | 322 | (defun letrec-inst-name (form) 323 | (cl-pattern:match form 324 | (('let ((name _ _)) _) name) 325 | (('let . _) (error "The form ~S is malformed." form)) 326 | (_ (error "The value ~S is an invalid form." form)))) 327 | 328 | (defun letrec-inst-args (form) 329 | (cl-pattern:match form 330 | (('let ((_ args _)) _) args) 331 | (('let . _) (error "The form ~S is malformed." form)) 332 | (_ (error "The value ~S is an invalid form." form)))) 333 | 334 | (defun letrec-inst-expr (form) 335 | (cl-pattern:match form 336 | (('let ((_ _ expr)) _) expr) 337 | (('let . _) (error "The form ~S is malformed." form)) 338 | (_ (error "The value ~S is an invalid form." form)))) 339 | 340 | (defun letrec-inst-body (form) 341 | (cl-pattern:match form 342 | (('let ((_ _ _)) body) body) 343 | (('let . _) (error "The form ~S is malformed." form)) 344 | (_ (error "The value ~S is an invalid form." form)))) 345 | 346 | (defun set-inst-p (object) 347 | (cl-pattern:match object 348 | (('set . _) t) 349 | (_ nil))) 350 | 351 | (defun set-inst-literal (form) 352 | (cl-pattern:match form 353 | (('set literal) literal) 354 | (('set . _) (error "The form ~S is malformed." form)) 355 | (_ (error "The value ~S is an invalid form." form)))) 356 | 357 | (defun mov-inst-p (object) 358 | (cl-pattern:match object 359 | (('mov . _) t) 360 | (_ nil))) 361 | 362 | (defun mov-inst-reg (form) 363 | (cl-pattern:match form 364 | (('mov reg) reg) 365 | (('mov . _) (error "The form ~S is malformed." form)) 366 | (_ (error "The value ~S is an invalid form." form)))) 367 | 368 | (defun sub-inst-p (object) 369 | (cl-pattern:match object 370 | (('sub . _) t) 371 | (_ nil))) 372 | 373 | (defun sub-inst-expr1 (form) 374 | (cl-pattern:match form 375 | (('sub expr1 _) expr1) 376 | (('sub . _) (error "The form ~S is malformed." form)) 377 | (_ (error "The value ~S is an invalid form." form)))) 378 | 379 | (defun sub-inst-expr2 (form) 380 | (cl-pattern:match form 381 | (('sub _ expr2) expr2) 382 | (('sub . _) (error "The form ~S is malformed." form)) 383 | (_ (error "The value ~S is an invalid form." form)))) 384 | 385 | (defun ifeq-inst-p (object) 386 | (cl-pattern:match object 387 | (('ifeq . _) t) 388 | (_ nil))) 389 | 390 | (defun ifeq-inst-lhs (form) 391 | (cl-pattern:match form 392 | (('ifeq lhs _ _ _) lhs) 393 | (('ifeq . _) (error "The form ~S is malformed." form)) 394 | (_ (error "The value ~S is an invalid form." form)))) 395 | 396 | (defun ifeq-inst-rhs (form) 397 | (cl-pattern:match form 398 | (('ifeq _ rhs _ _) rhs) 399 | (('ifeq . _) (error "The form ~S is malformed." form)) 400 | (_ (error "The value ~S is an invalid form." form)))) 401 | 402 | (defun ifeq-inst-then (form) 403 | (cl-pattern:match form 404 | (('ifeq _ _ then _) then) 405 | (('ifeq . _) (error "The form ~S is malformed." form)) 406 | (_ (error "The value ~S is an invalid form." form)))) 407 | 408 | (defun ifeq-inst-else (form) 409 | (cl-pattern:match form 410 | (('ifeq _ _ _ else) else) 411 | (('ifeq . _) (error "The form ~S is malformed." form)) 412 | (_ (error "The value ~S is an invalid form." form)))) 413 | 414 | (defun loop-inst-p (object) 415 | (loop-p object)) 416 | 417 | (defun loop-inst-var (form) 418 | (loop-times form)) 419 | 420 | (defun loop-inst-body (form) 421 | (loop-body form)) 422 | 423 | (defun call-inst-p (object) 424 | (cl-pattern:match object 425 | (('call . _) t) 426 | (_ nil))) 427 | 428 | (defun call-inst-name (form) 429 | (cl-pattern:match form 430 | (('call name . _) name) 431 | (('call . _) (error "The form ~S is malformed." form)) 432 | (_ (error "The value ~S is an invalid form." form)))) 433 | 434 | (defun call-inst-operands (form) 435 | (cl-pattern:match form 436 | (('call _ . operands) operands) 437 | (('call . _) (error "The form ~S is malformed." form)) 438 | (_ (error "The value ~S is an invalid form." form)))) 439 | 440 | (defun with-save-inst-p (object) 441 | (cl-pattern:match object 442 | (('with-save . _) t) 443 | (_ nil))) 444 | 445 | (defun with-save-inst-regs (form) 446 | (cl-pattern:match form 447 | (('with-save regs _) regs) 448 | (('with-save . _) (error "The form ~S is malformed." form)) 449 | (_ (error "The value ~S is an invalid form." form)))) 450 | 451 | (defun with-save-inst-expr (form) 452 | (cl-pattern:match form 453 | (('with-save _ expr) expr) 454 | (('with-save . _) (error "The form ~S is malformed." form)) 455 | (_ (error "The value ~S is an invalid form." form)))) 456 | 457 | (defun restore-inst-p (object) 458 | (cl-pattern:match object 459 | (('restore . _) t) 460 | (_ nil))) 461 | 462 | (defun restore-inst-regs (form) 463 | (cl-pattern:match form 464 | (('restore . regs) regs) 465 | (_ (error "The value ~S is an invalid form." form)))) 466 | 467 | (defun setreg-inst-p (object) 468 | (cl-pattern:match object 469 | (('setreg . _) t) 470 | (_ nil))) 471 | 472 | (defun setreg-inst-reg (form) 473 | (cl-pattern:match form 474 | (('setreg reg _) reg) 475 | (('setreg . _) (error "The form ~S is malformed." form)) 476 | (_ (error "The value ~S is an invalid form." form)))) 477 | 478 | (defun setreg-inst-expr (form) 479 | (cl-pattern:match form 480 | (('setreg _ expr) expr) 481 | (('setreg . _) (error "The form ~S is malformed." form)) 482 | (_ (error "The value ~S is an invalid form." form)))) 483 | 484 | 485 | ;;; 486 | ;;; Macro expansion 487 | ;;; 488 | 489 | (defun expand (form) 490 | (cond 491 | ((macro-p form) (expand-macro form)) 492 | ; ((literal-p form) (expand-literal form)) 493 | ; ((reference-p form) (expand-reference form)) 494 | ((sub-p form) (expand-sub form)) 495 | ((ifeq-p form) (expand-ifeq form)) 496 | ((let-p form) (expand-let form)) 497 | ((letrec-p form) (expand-letrec form)) 498 | ((with-args-p form) (expand-with-args form)) 499 | ((loop-p form) (expand-loop form)) 500 | ((setreg-p form) (expand-setreg form)) 501 | ((apply-p form) (expand-apply form)) 502 | (t (expand-default form)))) 503 | 504 | (defun expand-macro (form) 505 | (let ((expander (macro-expander form)) 506 | (operands (macro-operands form))) 507 | (let ((operands1 (mapcar #'expand operands))) 508 | (expand (apply expander operands1))))) 509 | 510 | (defun expand-default (form) 511 | form) 512 | 513 | (defun expand-literal (form) 514 | form) 515 | 516 | (defun expand-reference (form) 517 | form) 518 | 519 | (defun expand-sub (form) 520 | (let ((expr1 (sub-expr1 form)) 521 | (expr2 (sub-expr2 form))) 522 | (let ((expr1% (expand expr1)) 523 | (expr2% (expand expr2))) 524 | `(- ,expr1% ,expr2%)))) 525 | 526 | (defun expand-ifeq (form) 527 | (let ((lhs (ifeq-lhs form)) 528 | (rhs (ifeq-rhs form)) 529 | (then (ifeq-then form)) 530 | (else (ifeq-else form))) 531 | (let ((lhs1 (expand lhs)) 532 | (rhs1 (expand rhs)) 533 | (then1 (expand then)) 534 | (else1 (expand else))) 535 | `(if (= ,lhs1 ,rhs1) ,then1 ,else1)))) 536 | 537 | (defun expand-let (form) 538 | (let ((var (let-var form)) 539 | (expr (let-expr form)) 540 | (body (let-body form))) 541 | (let ((expr1 (expand expr)) 542 | (body1 (expand body))) 543 | `(let ((,var ,expr1)) 544 | ,body1)))) 545 | 546 | (defun expand-letrec (form) 547 | (let ((name (letrec-name form)) 548 | (args (letrec-args form)) 549 | (expr (letrec-expr form)) 550 | (body (letrec-body form))) 551 | (let ((expr1 (expand expr)) 552 | (body1 (expand body))) 553 | `(let ((,name ,args ,expr1)) 554 | ,body1)))) 555 | 556 | (defun expand-with-args (form) 557 | (let ((args (with-args-args form)) 558 | (body (with-args-body form))) 559 | (let ((body1 (expand body))) 560 | `(with-args ,args 561 | ,body1)))) 562 | 563 | (defun expand-loop (form) 564 | (let ((times (loop-times form)) 565 | (body (loop-body form))) 566 | (let ((times1 (expand times)) 567 | (body1 (expand body))) 568 | `(loop ,times1 569 | ,body1)))) 570 | 571 | (defun expand-setreg (form) 572 | (let ((reg (setreg-reg form)) 573 | (expr (setreg-expr form))) 574 | (let ((expr1 (expand expr))) 575 | `(setreg ,reg ,expr1)))) 576 | 577 | (defun expand-apply (form) 578 | (let ((operator (apply-operator form)) 579 | (operands (apply-operands form))) 580 | (let ((operands1 (mapcar #'expand operands))) 581 | `(,operator ,@operands1)))) 582 | 583 | 584 | ;;; 585 | ;;; K-normalization 586 | ;;; 587 | 588 | (defun empty-k-normal-environment () 589 | nil) 590 | 591 | (defun k-normal-environment-add (var env) 592 | (cons var env)) 593 | 594 | (defun k-normal-environment-add-list (vars env) 595 | (if vars 596 | (destructuring-bind (var . rest) vars 597 | (k-normal-environment-add-list rest 598 | (k-normal-environment-add var env))) 599 | env)) 600 | 601 | (defun k-normal-environment-exists-p (var env) 602 | (and (member var env) 603 | t)) 604 | 605 | (defun k-normal (env form) 606 | (cond 607 | ((literal-p form) (k-normal-literal form)) 608 | ((reference-p form) (k-normal-reference env form)) 609 | ((sub-p form) (k-normal-sub env form)) 610 | ((ifeq-p form) (k-normal-ifeq env form)) 611 | ((let-p form) (k-normal-let env form)) 612 | ((letrec-p form) (k-normal-letrec env form)) 613 | ((with-args-p form) (k-normal-with-args env form)) 614 | ((loop-p form) (k-normal-loop env form)) 615 | ((setreg-p form) (k-normal-setreg env form)) 616 | ((apply-p form) (k-normal-apply env form)) 617 | (t (error "The value ~S is an invalid form." form)))) 618 | 619 | (defun k-normal-literal (form) 620 | form) 621 | 622 | (defun k-normal-reference (env form) 623 | (if (k-normal-environment-exists-p form env) 624 | form 625 | (error "The variable ~S not found." form))) 626 | 627 | (defun k-normal-sub (env form) 628 | (let ((expr1 (sub-expr1 form)) 629 | (expr2 (sub-expr2 form))) 630 | (let ((expr1% (k-normal env expr1)) 631 | (expr2% (k-normal env expr2))) 632 | `(let ((tmpa ,expr1%)) 633 | (let ((tmpb ,expr2%)) 634 | (- tmpa tmpb)))))) 635 | 636 | (defun k-normal-ifeq (env form) 637 | (let ((lhs (ifeq-lhs form)) 638 | (rhs (ifeq-rhs form)) 639 | (then (ifeq-then form)) 640 | (else (ifeq-else form))) 641 | (let ((lhs1 (k-normal env lhs)) 642 | (rhs1 (k-normal env rhs)) 643 | (then1 (k-normal env then)) 644 | (else1 (k-normal env else))) 645 | `(let ((tmpa ,lhs1)) 646 | (let ((tmpb ,rhs1)) 647 | (if (= tmpa tmpb) 648 | ,then1 649 | ,else1)))))) 650 | 651 | (defun k-normal-let (env form) 652 | (let ((var (let-var form)) 653 | (expr (let-expr form)) 654 | (body (let-body form))) 655 | (let ((env1 (k-normal-environment-add var env))) 656 | (let ((expr1 (k-normal env expr)) 657 | (body1 (k-normal env1 body))) 658 | `(let ((,var ,expr1)) 659 | ,body1))))) 660 | 661 | (defun k-normal-letrec (env form) 662 | (let ((name (letrec-name form)) 663 | (args (letrec-args form)) 664 | (expr (letrec-expr form)) 665 | (body (letrec-body form))) 666 | (let ((env1 (k-normal-environment-add-list args 667 | (empty-k-normal-environment)))) 668 | (let ((expr1 (k-normal env1 expr)) 669 | (body1 (k-normal env body))) 670 | `(let ((,name ,args ,expr1)) 671 | ,body1))))) 672 | 673 | (defun k-normal-with-args (env form) 674 | (let ((args (with-args-args form)) 675 | (body (with-args-body form))) 676 | (let* ((env1 (k-normal-environment-add-list args env)) 677 | (body1 (k-normal env1 body))) 678 | `(with-args ,args ,body1)))) 679 | 680 | (defun k-normal-loop (env form) 681 | (let ((times (loop-times form)) 682 | (body (loop-body form))) 683 | (let ((times1 (k-normal env times)) 684 | (body1 (k-normal env body))) 685 | `(let ((tmp ,times1)) 686 | (loop tmp 687 | ,body1))))) 688 | 689 | (defun k-normal-setreg (env form) 690 | (let ((reg (setreg-reg form)) 691 | (expr (setreg-expr form))) 692 | (let ((expr1 (k-normal env expr))) 693 | `(let ((tmp ,expr1)) 694 | (setreg ,reg tmp))))) 695 | 696 | (defun k-normal-apply (env form) 697 | (let ((operator (apply-operator form)) 698 | (operands (apply-operands form))) 699 | (k-normal-apply% env operator operands 0 nil))) 700 | 701 | (defun k-normal-apply% (env operator operands i tmps) 702 | (if operands 703 | (let ((operand (car operands)) 704 | (rest (cdr operands))) 705 | (let ((operand1 (k-normal env operand))) 706 | (let* ((tmp (tmp-var i)) 707 | (tmps (cons tmp tmps))) 708 | `(let ((,tmp ,operand1)) 709 | ,(k-normal-apply% env operator rest (1+ i) tmps))))) 710 | `(,operator ,@(nreverse tmps)))) 711 | 712 | (defun tmp-var (i) 713 | (symbolicate "TMP" (code-char (+ 65 i)))) 714 | 715 | 716 | ;;; 717 | ;;; Alpha-conversion for variables 718 | ;;; 719 | 720 | (defun empty-alpha1-environment () 721 | nil) 722 | 723 | (defun alpha1-environment-add (var env) 724 | (acons var (make-unique-symbol var) env)) 725 | 726 | (defun alpha1-environment-add-list (vars env) 727 | (if vars 728 | (destructuring-bind (var . rest) vars 729 | (alpha1-environment-add-list rest 730 | (alpha1-environment-add var env))) 731 | env)) 732 | 733 | (defun alpha1-environment-lookup (var env) 734 | (or (cdr (assoc var env)) 735 | var)) 736 | 737 | (defun alpha1 (env form) 738 | (cond 739 | ((literal-p form) (alpha1-literal form)) 740 | ((reference-p form) (alpha1-reference env form)) 741 | ((sub-p form) (alpha1-sub env form)) 742 | ((ifeq-p form) (alpha1-ifeq env form)) 743 | ((let-p form) (alpha1-let env form)) 744 | ((letrec-p form) (alpha1-letrec env form)) 745 | ((with-args-p form) (alpha1-with-args env form)) 746 | ((loop-p form) (alpha1-loop env form)) 747 | ((setreg-p form) (alpha1-setreg env form)) 748 | ((apply-p form) (alpha1-apply env form)) 749 | (t (error "The value ~S is an invalid form." form)))) 750 | 751 | (defun alpha1-literal (form) 752 | form) 753 | 754 | (defun alpha1-reference (env form) 755 | (alpha1-environment-lookup form env)) 756 | 757 | (defun alpha1-sub (env form) 758 | (let ((expr1 (sub-expr1 form)) 759 | (expr2 (sub-expr2 form))) 760 | (let ((expr1% (alpha1 env expr1)) 761 | (expr2% (alpha1 env expr2))) 762 | `(- ,expr1% ,expr2%)))) 763 | 764 | (defun alpha1-ifeq (env form) 765 | (let ((lhs (ifeq-lhs form)) 766 | (rhs (ifeq-rhs form)) 767 | (then (ifeq-then form)) 768 | (else (ifeq-else form))) 769 | (let ((lhs1 (alpha1 env lhs)) 770 | (rhs1 (alpha1 env rhs)) 771 | (then1 (alpha1 env then)) 772 | (else1 (alpha1 env else))) 773 | `(if (= ,lhs1 ,rhs1) ,then1 ,else1)))) 774 | 775 | (defun alpha1-let (env form) 776 | (let ((var (let-var form)) 777 | (expr (let-expr form)) 778 | (body (let-body form))) 779 | (let ((expr1 (alpha1 env expr))) 780 | (let* ((env1 (alpha1-environment-add var env)) 781 | (var1 (alpha1-environment-lookup var env1)) 782 | (body1 (alpha1 env1 body))) 783 | `(let ((,var1 ,expr1)) 784 | ,body1))))) 785 | 786 | (defun alpha1-letrec (env form) 787 | (let ((name (letrec-name form)) 788 | (args (letrec-args form)) 789 | (expr (letrec-expr form)) 790 | (body (letrec-body form))) 791 | (let* ((env0 (alpha1-environment-add-list args 792 | (empty-alpha1-environment))) 793 | (args1 (mapcar #'(lambda (arg) 794 | (alpha1-environment-lookup arg env0)) 795 | args)) 796 | (expr1 (alpha1 env0 expr))) 797 | (let ((body1 (alpha1 env body))) 798 | `(let ((,name ,args1 ,expr1)) 799 | ,body1))))) 800 | 801 | (defun alpha1-with-args (env form) 802 | (let ((args (with-args-args form)) 803 | (body (with-args-body form))) 804 | (let* ((env1 (alpha1-environment-add-list args env)) 805 | (args1 (mapcar #'(lambda (arg) 806 | (alpha1-environment-lookup arg env1)) 807 | args))) 808 | (let ((body1 (alpha1 env1 body))) 809 | `(with-args ,args1 ,body1))))) 810 | 811 | (defun alpha1-loop (env form) 812 | (let ((times (loop-times form)) 813 | (body (loop-body form))) 814 | (let ((times1 (alpha1 env times)) 815 | (body1 (alpha1 env body))) 816 | `(loop ,times1 817 | ,body1)))) 818 | 819 | (defun alpha1-setreg (env form) 820 | (let ((reg (setreg-reg form)) 821 | (expr (setreg-expr form))) 822 | (let ((expr1 (alpha1 env expr))) 823 | `(setreg ,reg ,expr1)))) 824 | 825 | (defun alpha1-apply (env form) 826 | (let ((operator (apply-operator form)) 827 | (operands (apply-operands form))) 828 | (let ((operands1 (mapcar #'(lambda (operand) 829 | (alpha1 env operand)) 830 | operands))) 831 | `(,operator ,@operands1)))) 832 | 833 | 834 | ;;; 835 | ;;; Alpha-conversion for functions 836 | ;;; 837 | 838 | (defun empty-alpha2-environment () 839 | nil) 840 | 841 | (defun alpha2-environment-add (name env) 842 | (acons name (make-unique-symbol name) env)) 843 | 844 | (defun alpha2-environment-lookup (name env) 845 | (or (cdr (assoc name env)) 846 | name)) 847 | 848 | (defun alpha2 (env form) 849 | (cond 850 | ((literal-p form) (alpha2-literal form)) 851 | ((reference-p form) (alpha2-reference form)) 852 | ((sub-p form) (alpha2-sub env form)) 853 | ((ifeq-p form) (alpha2-ifeq env form)) 854 | ((let-p form) (alpha2-let env form)) 855 | ((letrec-p form) (alpha2-letrec env form)) 856 | ((with-args-p form) (alpha2-with-args env form)) 857 | ((loop-p form) (alpha2-loop env form)) 858 | ((setreg-p form) (alpha2-setreg env form)) 859 | ((apply-p form) (alpha2-apply env form)) 860 | (t (error "The value ~S is an invalid form." form)))) 861 | 862 | (defun alpha2-literal (form) 863 | form) 864 | 865 | (defun alpha2-reference (form) 866 | form) 867 | 868 | (defun alpha2-sub (env form) 869 | (let ((expr1 (sub-expr1 form)) 870 | (expr2 (sub-expr2 form))) 871 | (let ((expr1% (alpha2 env expr1)) 872 | (expr2% (alpha2 env expr2))) 873 | `(- ,expr1% ,expr2%)))) 874 | 875 | (defun alpha2-ifeq (env form) 876 | (let ((lhs (ifeq-lhs form)) 877 | (rhs (ifeq-rhs form)) 878 | (then (ifeq-then form)) 879 | (else (ifeq-else form))) 880 | (let ((lhs1 (alpha2 env lhs)) 881 | (rhs1 (alpha2 env rhs)) 882 | (then1 (alpha2 env then)) 883 | (else1 (alpha2 env else))) 884 | `(if (= ,lhs1 ,rhs1) ,then1 ,else1)))) 885 | 886 | (defun alpha2-let (env form) 887 | (let ((var (let-var form)) 888 | (expr (let-expr form)) 889 | (body (let-body form))) 890 | (let ((expr1 (alpha2 env expr)) 891 | (body1 (alpha2 env body))) 892 | `(let ((,var ,expr1)) 893 | ,body1)))) 894 | 895 | (defun alpha2-letrec (env form) 896 | (let ((name (letrec-name form)) 897 | (args (letrec-args form)) 898 | (expr (letrec-expr form)) 899 | (body (letrec-body form))) 900 | (let ((env1 (alpha2-environment-add name env))) 901 | (let ((name1 (alpha2-environment-lookup name env1)) 902 | (expr1 (alpha2 env1 expr)) 903 | (body1 (alpha2 env1 body))) 904 | `(let ((,name1 ,args ,expr1)) 905 | ,body1))))) 906 | 907 | (defun alpha2-with-args (env form) 908 | (let ((args (with-args-args form)) 909 | (body (with-args-body form))) 910 | (let ((body1 (alpha2 env body))) 911 | `(with-args ,args ,body1)))) 912 | 913 | (defun alpha2-loop (env form) 914 | (let ((times (loop-times form)) 915 | (body (loop-body form))) 916 | (let ((times1 (alpha2 env times)) 917 | (body1 (alpha2 env body))) 918 | `(loop ,times1 919 | ,body1)))) 920 | 921 | (defun alpha2-setreg (env form) 922 | (let ((reg (setreg-reg form)) 923 | (expr (setreg-expr form))) 924 | (let ((expr1 (alpha2 env expr))) 925 | `(setreg ,reg ,expr1)))) 926 | 927 | (defun alpha2-apply (env form) 928 | (let ((operator (apply-operator form)) 929 | (operands (apply-operands form))) 930 | (let ((operator1 (alpha2-environment-lookup operator env))) 931 | `(,operator1 ,@operands)))) 932 | 933 | 934 | ;;; 935 | ;;; Beta-reduction 936 | ;;; 937 | 938 | (defun empty-beta-environment () 939 | nil) 940 | 941 | (defun beta-environment-add (var var1 env) 942 | (acons var var1 env)) 943 | 944 | (defun beta-environment-lookup (var env) 945 | (or (cdr (assoc var env)) 946 | var)) 947 | 948 | (defun beta (env form) 949 | (cond 950 | ((literal-p form) (beta-literal form)) 951 | ((reference-p form) (beta-reference env form)) 952 | ((sub-p form) (beta-sub env form)) 953 | ((ifeq-p form) (beta-ifeq env form)) 954 | ((let-p form) (beta-let env form)) 955 | ((letrec-p form) (beta-letrec env form)) 956 | ((with-args-p form) (beta-with-args env form)) 957 | ((loop-p form) (beta-loop env form)) 958 | ((setreg-p form) (beta-setreg env form)) 959 | ((apply-p form) (beta-apply env form)) 960 | (t (error "The value ~S is an invalid form." form)))) 961 | 962 | (defun beta-literal (form) 963 | form) 964 | 965 | (defun beta-reference (env form) 966 | (beta-environment-lookup form env)) 967 | 968 | (defun beta-sub (env form) 969 | (let ((expr1 (sub-expr1 form)) 970 | (expr2 (sub-expr2 form))) 971 | (let ((expr1% (beta env expr1)) 972 | (expr2% (beta env expr2))) 973 | `(- ,expr1% ,expr2%)))) 974 | 975 | (defun beta-ifeq (env form) 976 | (let ((lhs (ifeq-lhs form)) 977 | (rhs (ifeq-rhs form)) 978 | (then (ifeq-then form)) 979 | (else (ifeq-else form))) 980 | (let ((lhs1 (beta env lhs)) 981 | (rhs1 (beta env rhs)) 982 | (then1 (beta env then)) 983 | (else1 (beta env else))) 984 | `(if (= ,lhs1 ,rhs1) ,then1 ,else1)))) 985 | 986 | (defun beta-let (env form) 987 | (let ((var (let-var form)) 988 | (expr (let-expr form)) 989 | (body (let-body form))) 990 | (let ((expr1 (beta env expr))) 991 | (if (reference-p expr1) 992 | (let* ((env1 (beta-environment-add var expr1 env)) 993 | (body1 (beta env1 body))) 994 | body1) 995 | (let ((body1 (beta env body))) 996 | `(let ((,var ,expr1)) 997 | ,body1)))))) 998 | 999 | (defun beta-letrec (env form) 1000 | (let ((name (letrec-name form)) 1001 | (args (letrec-args form)) 1002 | (expr (letrec-expr form)) 1003 | (body (letrec-body form))) 1004 | (let ((expr1 (beta (empty-beta-environment) expr)) 1005 | (body1 (beta env body))) 1006 | `(let ((,name ,args ,expr1)) 1007 | ,body1)))) 1008 | 1009 | (defun beta-with-args (env form) 1010 | (let ((args (with-args-args form)) 1011 | (body (with-args-body form))) 1012 | (let ((body1 (beta env body))) 1013 | `(with-args ,args ,body1)))) 1014 | 1015 | (defun beta-loop (env form) 1016 | (let ((times (loop-times form)) 1017 | (body (loop-body form))) 1018 | (let ((times1 (beta env times)) 1019 | (body1 (beta env body))) 1020 | `(loop ,times1 1021 | ,body1)))) 1022 | 1023 | (defun beta-setreg (env form) 1024 | (let ((reg (setreg-reg form)) 1025 | (expr (setreg-expr form))) 1026 | (let ((expr1 (beta env expr))) 1027 | `(setreg ,reg ,expr1)))) 1028 | 1029 | (defun beta-apply (env form) 1030 | (let ((operator (apply-operator form)) 1031 | (operands (apply-operands form))) 1032 | (let ((operands1 (mapcar #'(lambda (operand) 1033 | (beta env operand)) 1034 | operands))) 1035 | `(,operator ,@operands1)))) 1036 | 1037 | 1038 | ;;; 1039 | ;;; Let flattening 1040 | ;;; 1041 | 1042 | (defun flatten (form) 1043 | (cond 1044 | ((literal-p form) (flatten-literal form)) 1045 | ((reference-p form) (flatten-reference form)) 1046 | ((sub-p form) (flatten-sub form)) 1047 | ((ifeq-p form) (flatten-ifeq form)) 1048 | ((let-p form) (flatten-let form)) 1049 | ((letrec-p form) (flatten-letrec form)) 1050 | ((with-args-p form) (flatten-with-args form)) 1051 | ((loop-p form) (flatten-loop form)) 1052 | ((setreg-p form) (flatten-setreg form)) 1053 | ((apply-p form) (flatten-apply form)) 1054 | (t (error "The value ~S is an invalid form." form)))) 1055 | 1056 | (defun flatten-literal (form) 1057 | form) 1058 | 1059 | (defun flatten-reference (form) 1060 | form) 1061 | 1062 | (defun flatten-sub (form) 1063 | form) 1064 | 1065 | (defun flatten-ifeq (form) 1066 | (let ((lhs (ifeq-lhs form)) 1067 | (rhs (ifeq-rhs form)) 1068 | (then (ifeq-then form)) 1069 | (else (ifeq-else form))) 1070 | (let ((then1 (flatten then)) 1071 | (else1 (flatten else))) 1072 | `(if (= ,lhs ,rhs) ,then1 ,else1)))) 1073 | 1074 | (defun flatten-let (form) 1075 | (let ((var (let-var form)) 1076 | (expr (let-expr form)) 1077 | (body (let-body form))) 1078 | (if (let-p expr) 1079 | (let ((var1 (let-var expr)) 1080 | (expr1 (let-expr expr)) 1081 | (body1 (let-body expr))) 1082 | (flatten `(let ((,var1 ,expr1)) 1083 | (let ((,var ,body1)) 1084 | ,body)))) 1085 | (let ((expr1 (flatten expr)) 1086 | (body1 (flatten body))) 1087 | `(let ((,var ,expr1)) 1088 | ,body1))))) 1089 | 1090 | (defun flatten-letrec (form) 1091 | (let ((name (letrec-name form)) 1092 | (args (letrec-args form)) 1093 | (expr (letrec-expr form)) 1094 | (body (letrec-body form))) 1095 | (let ((expr1 (flatten expr)) 1096 | (body1 (flatten body))) 1097 | `(let ((,name ,args ,expr1)) 1098 | ,body1)))) 1099 | 1100 | (defun flatten-with-args (form) 1101 | (let ((args (with-args-args form)) 1102 | (body (with-args-body form))) 1103 | (let ((body1 (flatten body))) 1104 | `(with-args ,args ,body1)))) 1105 | 1106 | (defun flatten-loop (form) 1107 | (let ((times (loop-times form)) 1108 | (body (loop-body form))) 1109 | (let ((body1 (flatten body))) 1110 | `(loop ,times 1111 | ,body1)))) 1112 | 1113 | (defun flatten-setreg (form) 1114 | form) 1115 | 1116 | (defun flatten-apply (form) 1117 | form) 1118 | 1119 | 1120 | ;;; 1121 | ;;; Inlining 1122 | ;;; 1123 | 1124 | (defun empty-inlined-environment () 1125 | nil) 1126 | 1127 | (defun inlined-environment-add (name args expr env) 1128 | (acons name (list args expr) env)) 1129 | 1130 | (defun inlined-environment-add-fundefs (fundefs env) 1131 | (if fundefs 1132 | (destructuring-bind ((name args body) . rest) fundefs 1133 | (inlined-environment-add-fundefs rest 1134 | (inlined-environment-add name args body env))) 1135 | env)) 1136 | 1137 | (defun inlined-environment-lookup (name env) 1138 | (cdr (assoc name env))) 1139 | 1140 | (defun inlined (fundefs form) 1141 | (let* ((env (inlined-environment-add-fundefs fundefs 1142 | (empty-inlined-environment)))) 1143 | (inlined% env form))) 1144 | 1145 | (defun inlined% (env form) 1146 | (cond 1147 | ((literal-p form) (inlined-literal form)) 1148 | ((reference-p form) (inlined-reference form)) 1149 | ((sub-p form) (inlined-sub env form)) 1150 | ((ifeq-p form) (inlined-ifeq env form)) 1151 | ((let-p form) (inlined-let env form)) 1152 | ((letrec-p form) (inlined-letrec env form)) 1153 | ((with-args-p form) (inlined-with-args env form)) 1154 | ((loop-p form) (inlined-loop env form)) 1155 | ((setreg-p form) (inlined-setreg env form)) 1156 | ((apply-p form) (inlined-apply env form)) 1157 | (t (error "The value ~S is an invalid form." form)))) 1158 | 1159 | (defun inlined-literal (form) 1160 | form) 1161 | 1162 | (defun inlined-reference (form) 1163 | form) 1164 | 1165 | (defun inlined-sub (env form) 1166 | (let ((expr1 (sub-expr1 form)) 1167 | (expr2 (sub-expr2 form))) 1168 | (let ((expr1% (inlined% env expr1)) 1169 | (expr2% (inlined% env expr2))) 1170 | `(- ,expr1% ,expr2%)))) 1171 | 1172 | (defun inlined-ifeq (env form) 1173 | (let ((lhs (ifeq-lhs form)) 1174 | (rhs (ifeq-rhs form)) 1175 | (then (ifeq-then form)) 1176 | (else (ifeq-else form))) 1177 | (let ((lhs1 (inlined% env lhs)) 1178 | (rhs1 (inlined% env rhs)) 1179 | (then1 (inlined% env then)) 1180 | (else1 (inlined% env else))) 1181 | `(if (= ,lhs1 ,rhs1) 1182 | ,then1 1183 | ,else1)))) 1184 | 1185 | (defun inlined-let (env form) 1186 | (let ((var (let-var form)) 1187 | (expr (let-expr form)) 1188 | (body (let-body form))) 1189 | (let ((expr1 (inlined% env expr)) 1190 | (body1 (inlined% env body))) 1191 | `(let ((,var ,expr1)) 1192 | ,body1)))) 1193 | 1194 | (defun inlined-letrec (env form) 1195 | (let ((name (letrec-name form)) 1196 | (args (letrec-args form)) 1197 | (expr (letrec-expr form)) 1198 | (body (letrec-body form))) 1199 | (let ((env1 (inlined-environment-add name args expr env))) 1200 | (let ((expr1 (inlined% env expr)) ; use ENV not inlining self-recursion 1201 | (body1 (inlined% env1 body))) 1202 | `(let ((,name ,args ,expr1)) 1203 | ,body1))))) 1204 | 1205 | (defun inlined-with-args (env form) 1206 | (let ((args (with-args-args form)) 1207 | (body (with-args-body form))) 1208 | (let ((body1 (inlined% env body))) 1209 | `(with-args ,args 1210 | ,body1)))) 1211 | 1212 | (defun inlined-loop (env form) 1213 | (let ((times (loop-times form)) 1214 | (body (loop-body form))) 1215 | (let ((body1 (inlined% env body))) 1216 | `(loop ,times 1217 | ,body1)))) 1218 | 1219 | (defun inlined-setreg (env form) 1220 | (let ((reg (setreg-reg form)) 1221 | (expr (setreg-expr form))) 1222 | (let ((expr1 (inlined% env expr))) 1223 | `(setreg ,reg ,expr1)))) 1224 | 1225 | (defun inlined-apply (env form) 1226 | (let ((operator (apply-operator form)) 1227 | (operands (apply-operands form))) 1228 | (let ((inliner (inlined-environment-lookup operator env))) 1229 | (if inliner 1230 | (destructuring-bind (args body) inliner 1231 | (unless (= (length args) (length operands)) 1232 | (error "Invalid number of arguments: ~S~%" (length operands))) 1233 | (inlined-apply% env args operands body)) 1234 | `(,operator ,@operands))))) 1235 | 1236 | (defun inlined-apply% (env args operands body) 1237 | (if args 1238 | (destructuring-bind (arg . args1) args 1239 | (destructuring-bind (operand . operands1) operands 1240 | (let ((operand1 (inlined% env operand))) 1241 | `(let ((,arg ,operand1)) 1242 | ,(inlined-apply% env args1 operands1 body))))) 1243 | body)) 1244 | 1245 | 1246 | ;;; 1247 | ;;; Dead code elimination 1248 | ;;; 1249 | 1250 | (defun alive-variable-p (var expr) 1251 | (and (member var (flatten-list expr)) 1252 | t)) 1253 | 1254 | (defun alive-function-p (name expr) 1255 | (alive-variable-p name expr)) 1256 | 1257 | (defun side-effect-p (form) 1258 | (cond 1259 | ((literal-p form) nil) 1260 | ((reference-p form) nil) 1261 | ((sub-p form) nil) 1262 | ((ifeq-p form) (side-effect-p-ifeq form)) 1263 | ((let-p form) (side-effect-p-let form)) 1264 | ((letrec-p form) (side-effect-p-letrec form)) 1265 | ((with-args-p form) (side-effect-p-with-args form)) 1266 | ((loop-p form) (side-effect-p-loop form)) 1267 | ((setreg-p form) t) 1268 | ((apply-p form) t) 1269 | (t (error "The value ~S is an invalid form." form)))) 1270 | 1271 | (defun side-effect-p-ifeq (form) 1272 | (let ((then (ifeq-then form)) 1273 | (else (ifeq-else form))) 1274 | (or (side-effect-p then) 1275 | (side-effect-p else)))) 1276 | 1277 | (defun side-effect-p-let (form) 1278 | (let ((expr (let-expr form)) 1279 | (body (let-body form))) 1280 | (or (side-effect-p expr) 1281 | (side-effect-p body)))) 1282 | 1283 | (defun side-effect-p-letrec (form) 1284 | (let ((body (letrec-body form))) 1285 | (side-effect-p body))) 1286 | 1287 | (defun side-effect-p-with-args (form) 1288 | (let ((body (with-args-body form))) 1289 | (side-effect-p body))) 1290 | 1291 | (defun side-effect-p-loop (form) 1292 | (let ((body (loop-body form))) 1293 | (side-effect-p body))) 1294 | 1295 | (defun elim (form) 1296 | (cond 1297 | ((literal-p form) (elim-literal form)) 1298 | ((reference-p form) (elim-reference form)) 1299 | ((sub-p form) (elim-sub form)) 1300 | ((ifeq-p form) (elim-ifeq form)) 1301 | ((let-p form) (elim-let form)) 1302 | ((letrec-p form) (elim-letrec form)) 1303 | ((with-args-p form) (elim-with-args form)) 1304 | ((loop-p form) (elim-loop form)) 1305 | ((setreg-p form) (elim-setreg form)) 1306 | ((apply-p form) (elim-apply form)) 1307 | (t (error "The value ~S is an invalid form." form)))) 1308 | 1309 | (defun elim-literal (form) 1310 | form) 1311 | 1312 | (defun elim-reference (form) 1313 | form) 1314 | 1315 | (defun elim-sub (form) 1316 | form) 1317 | 1318 | (defun elim-ifeq (form) 1319 | (let ((lhs (ifeq-lhs form)) 1320 | (rhs (ifeq-rhs form)) 1321 | (then (ifeq-then form)) 1322 | (else (ifeq-else form))) 1323 | (let ((then1 (elim then)) 1324 | (else1 (elim else))) 1325 | `(if (= ,lhs ,rhs) ,then1 ,else1)))) 1326 | 1327 | (defun elim-let (form) 1328 | (let ((var (let-var form)) 1329 | (expr (let-expr form)) 1330 | (body (let-body form))) 1331 | (let ((expr1 (elim expr)) 1332 | (body1 (elim body))) 1333 | (if (or (side-effect-p expr1) 1334 | (alive-variable-p var body1)) 1335 | `(let ((,var ,expr1)) 1336 | ,body1) 1337 | body1)))) 1338 | 1339 | (defun elim-letrec (form) 1340 | (let ((name (letrec-name form)) 1341 | (args (letrec-args form)) 1342 | (expr (letrec-expr form)) 1343 | (body (letrec-body form))) 1344 | (let ((expr1 (elim expr)) 1345 | (body1 (elim body))) 1346 | (if (alive-function-p name body1) 1347 | `(let ((,name ,args ,expr1)) 1348 | ,body1) 1349 | body1)))) 1350 | 1351 | (defun elim-with-args (form) 1352 | (let ((args (with-args-args form)) 1353 | (body (with-args-body form))) 1354 | (let ((body1 (elim body))) 1355 | `(with-args ,args 1356 | ,body1)))) 1357 | 1358 | (defun elim-loop (form) 1359 | (let ((times (loop-times form)) 1360 | (body (loop-body form))) 1361 | (let ((body1 (elim body))) 1362 | `(loop ,times 1363 | ,body1)))) 1364 | 1365 | (defun elim-setreg (form) 1366 | form) 1367 | 1368 | (defun elim-apply (form) 1369 | form) 1370 | 1371 | 1372 | ;;; 1373 | ;;; Closure conversion 1374 | ;;; 1375 | 1376 | (defun closure (form) 1377 | (multiple-value-bind (form1 fundefs) (closure% form nil) 1378 | (closure-aux form1 fundefs))) 1379 | 1380 | (defun closure-aux (form fundefs) 1381 | (if fundefs 1382 | (let ((fundef (car fundefs)) 1383 | (rest (cdr fundefs))) 1384 | (destructuring-bind (name args expr) fundef 1385 | `(let ((,name ,args ,expr)) 1386 | ,(closure-aux form rest)))) 1387 | form)) 1388 | 1389 | (defun closure% (form fundefs) 1390 | (cond 1391 | ((literal-p form) (closure-literal form fundefs)) 1392 | ((reference-p form) (closure-reference form fundefs)) 1393 | ((sub-p form) (closure-sub form fundefs)) 1394 | ((ifeq-p form) (closure-ifeq form fundefs)) 1395 | ((let-p form) (closure-let form fundefs)) 1396 | ((letrec-p form) (closure-letrec form fundefs)) 1397 | ((with-args-p form) (closure-with-args form fundefs)) 1398 | ((loop-p form) (closure-loop form fundefs)) 1399 | ((setreg-p form) (closure-setreg form fundefs)) 1400 | ((apply-p form) (closure-apply form fundefs)) 1401 | (t (error "The value ~S is an invalid form." form)))) 1402 | 1403 | (defun closure-literal (form fundefs) 1404 | (values form fundefs)) 1405 | 1406 | (defun closure-reference (form fundefs) 1407 | (values form fundefs)) 1408 | 1409 | (defun closure-sub (form fundefs) 1410 | (values form fundefs)) 1411 | 1412 | (defun closure-ifeq (form fundefs) 1413 | (let ((lhs (ifeq-lhs form)) 1414 | (rhs (ifeq-rhs form)) 1415 | (then (ifeq-then form)) 1416 | (else (ifeq-else form))) 1417 | (multiple-value-bind (then1 fundefs1) (closure% then fundefs) 1418 | (multiple-value-bind (else1 fundefs2) (closure% else fundefs1) 1419 | (values `(if (= ,lhs ,rhs) ,then1 ,else1) fundefs2))))) 1420 | 1421 | (defun closure-let (form fundefs) 1422 | (let ((var (let-var form)) 1423 | (expr (let-expr form)) 1424 | (body (let-body form))) 1425 | (multiple-value-bind (expr1 fundefs1) (closure% expr fundefs) 1426 | (multiple-value-bind (body1 fundefs2) (closure% body fundefs1) 1427 | (values `(let ((,var ,expr1)) 1428 | ,body1) 1429 | fundefs2))))) 1430 | 1431 | (defun closure-letrec (form fundefs) 1432 | (let ((name (letrec-name form)) 1433 | (args (letrec-args form)) 1434 | (expr (letrec-expr form)) 1435 | (body (letrec-body form))) 1436 | (multiple-value-bind (expr1 fundefs1) (closure% expr fundefs) 1437 | (let ((fundefs2 (cons (list name args expr1) fundefs1))) 1438 | (multiple-value-bind (body1 fundefs3) (closure% body fundefs2) 1439 | (values body1 fundefs3)))))) 1440 | 1441 | (defun closure-with-args (form fundefs) 1442 | (let ((args (with-args-args form)) 1443 | (body (with-args-body form))) 1444 | (multiple-value-bind (body1 fundefs1) (closure% body fundefs) 1445 | (values `(with-args ,args ,body1) 1446 | fundefs1)))) 1447 | 1448 | (defun closure-loop (form fundefs) 1449 | (let ((times (loop-times form)) 1450 | (body (loop-body form))) 1451 | (multiple-value-bind (body1 fundefs1) (closure% body fundefs) 1452 | (values `(loop ,times ,body1) 1453 | fundefs1)))) 1454 | 1455 | (defun closure-setreg (form fundefs) 1456 | (values form fundefs)) 1457 | 1458 | (defun closure-apply (form fundefs) 1459 | (values form fundefs)) 1460 | 1461 | 1462 | ;;; 1463 | ;;; Virtual machine code generation 1464 | ;;; 1465 | 1466 | (defun virtual (form) 1467 | (cond 1468 | ((literal-p form) (virtual-literal form)) 1469 | ((reference-p form) (virtual-reference form)) 1470 | ((sub-p form) (virtual-sub form)) 1471 | ((ifeq-p form) (virtual-ifeq form)) 1472 | ((let-p form) (virtual-let form)) 1473 | ((letrec-p form) (virtual-letrec form)) 1474 | ((with-args-p form) (virtual-with-args form)) 1475 | ((loop-p form) (virtual-loop form)) 1476 | ((setreg-p form) (virtual-setreg form)) 1477 | ((apply-p form) (virtual-apply form)) 1478 | (t (error "The value ~S is an invalid form." form)))) 1479 | 1480 | (defun virtual-literal (form) 1481 | `(set ,form)) 1482 | 1483 | (defun virtual-reference (form) 1484 | `(mov ,form)) 1485 | 1486 | (defun virtual-sub (form) 1487 | (let ((expr1 (sub-expr1 form)) 1488 | (expr2 (sub-expr2 form))) 1489 | (assert (pic-symbol-p expr1)) 1490 | (assert (pic-symbol-p expr2)) 1491 | `(sub ,expr1 ,expr2))) 1492 | 1493 | (defun virtual-ifeq (form) 1494 | (let ((lhs (ifeq-lhs form)) 1495 | (rhs (ifeq-rhs form)) 1496 | (then (ifeq-then form)) 1497 | (else (ifeq-else form))) 1498 | (assert (pic-symbol-p lhs)) 1499 | (assert (pic-symbol-p rhs)) 1500 | (let ((then1 (virtual then)) 1501 | (else1 (virtual else))) 1502 | `(ifeq ,lhs ,rhs ,then1 ,else1)))) 1503 | 1504 | (defun virtual-let (form) 1505 | (let ((var (let-var form)) 1506 | (expr (let-expr form)) 1507 | (body (let-body form))) 1508 | (let ((expr1 (virtual expr)) 1509 | (body1 (virtual body))) 1510 | `(let ((,var ,expr1)) 1511 | ,body1)))) 1512 | 1513 | (defun virtual-letrec (form) 1514 | (let ((name (letrec-name form)) 1515 | (args (letrec-args form)) 1516 | (expr (letrec-expr form)) 1517 | (body (letrec-body form))) 1518 | (let ((expr1 (virtual expr)) 1519 | (body1 (virtual body))) 1520 | `(let ((,name ,args ,expr1)) 1521 | ,body1)))) 1522 | 1523 | (defun virtual-with-args (form) 1524 | (let ((args (with-args-args form)) 1525 | (body (with-args-body form))) 1526 | (let ((iregs (input-regs (length args)))) 1527 | (virtual-with-args% args iregs body)))) 1528 | 1529 | (defun virtual-loop (form) 1530 | (let ((times (loop-times form)) 1531 | (body (loop-body form))) 1532 | (assert (pic-symbol-p times)) 1533 | (let ((body1 (virtual body))) 1534 | `(loop ,times ,body1)))) 1535 | 1536 | (defun virtual-with-args% (args iregs body) 1537 | (if args 1538 | (destructuring-bind (arg . args1) args 1539 | (destructuring-bind (ireg . iregs1) iregs 1540 | `(let ((,arg (mov ,ireg))) 1541 | ,(virtual-with-args% args1 iregs1 body)))) 1542 | (virtual body))) 1543 | 1544 | (defun virtual-setreg (form) 1545 | (let ((reg (setreg-reg form)) 1546 | (expr (setreg-expr form))) 1547 | (assert (pic-symbol-p expr)) 1548 | `(setreg ,reg ,expr))) 1549 | 1550 | (defun virtual-apply (form) 1551 | (let ((operator (apply-operator form)) 1552 | (operands (apply-operands form))) 1553 | (assert (every #'pic-symbol-p operands)) 1554 | `(call ,operator ,@operands))) 1555 | 1556 | 1557 | ;;; 1558 | ;;; Immediates optimization 1559 | ;;; 1560 | 1561 | (defun empty-immediates-environment () 1562 | nil) 1563 | 1564 | (defun immediates-environment-add (var literal env) 1565 | (acons var literal env)) 1566 | 1567 | (defun immediates-environment-lookup (var env) 1568 | (cdr (assoc var env))) 1569 | 1570 | (defun immediates (env inst) 1571 | (cond 1572 | ((let-inst-p inst) (immediates-let env inst)) 1573 | ((letrec-inst-p inst) (immediates-letrec env inst)) 1574 | ((set-inst-p inst) (immediates-set inst)) 1575 | ((mov-inst-p inst) (immediates-mov env inst)) 1576 | ((sub-inst-p inst) (immediates-sub env inst)) 1577 | ((ifeq-inst-p inst) (immediates-ifeq env inst)) 1578 | ((loop-inst-p inst) (immediates-loop env inst)) 1579 | ((setreg-inst-p inst) (immediates-setreg env inst)) 1580 | ((call-inst-p inst) (immediates-call env inst)) 1581 | (t (error "The value ~S is an invalid instruction." inst)))) 1582 | 1583 | (defun immediates-let (env inst) 1584 | (let ((var (let-inst-var inst)) 1585 | (expr (let-inst-expr inst)) 1586 | (body (let-inst-body inst))) 1587 | (if (set-inst-p expr) 1588 | (let* ((literal (set-inst-literal expr)) 1589 | (env1 (immediates-environment-add var literal env))) 1590 | (let ((body1 (immediates env1 body))) 1591 | (if (alive-variable-p var body1) 1592 | `(let ((,var ,expr)) 1593 | ,body1) 1594 | body1))) 1595 | (let ((expr1 (immediates env expr)) 1596 | (body1 (immediates env body))) 1597 | `(let ((,var ,expr1)) 1598 | ,body1))))) 1599 | 1600 | (defun immediates-letrec (env inst) 1601 | (let ((name (letrec-inst-name inst)) 1602 | (args (letrec-inst-args inst)) 1603 | (expr (letrec-inst-expr inst)) 1604 | (body (letrec-inst-body inst))) 1605 | (let* ((env0 (empty-immediates-environment)) 1606 | (expr1 (immediates env0 expr))) 1607 | (let ((body1 (immediates env body))) 1608 | `(let ((,name ,args ,expr1)) 1609 | ,body1))))) 1610 | 1611 | (defun immediates-set (inst) 1612 | inst) 1613 | 1614 | (defun immediates-mov (env inst) 1615 | (let ((reg (mov-inst-reg inst))) 1616 | (let ((literal (immediates-environment-lookup reg env))) 1617 | (if literal 1618 | `(set ,literal) 1619 | `(mov ,reg))))) 1620 | 1621 | (defun immediates-sub (env inst) 1622 | (let ((expr1 (sub-inst-expr1 inst)) 1623 | (expr2 (sub-inst-expr2 inst))) 1624 | (let ((expr2% (or (immediates-environment-lookup expr2 env) 1625 | expr2))) 1626 | `(sub ,expr1 ,expr2%)))) 1627 | 1628 | (defun immediates-ifeq (env inst) 1629 | (let ((lhs (ifeq-inst-lhs inst)) 1630 | (rhs (ifeq-inst-rhs inst)) 1631 | (then (ifeq-inst-then inst)) 1632 | (else (ifeq-inst-else inst))) 1633 | (let ((rhs1 (or (immediates-environment-lookup rhs env) 1634 | rhs)) 1635 | (then1 (immediates env then)) 1636 | (else1 (immediates env else))) 1637 | `(ifeq ,lhs ,rhs1 ,then1 ,else1)))) 1638 | 1639 | (defun immediates-loop (env inst) 1640 | (let ((var (loop-inst-var inst)) 1641 | (body (loop-inst-body inst))) 1642 | (let ((body1 (immediates env body))) 1643 | `(loop ,var ,body1)))) 1644 | 1645 | (defun immediates-setreg (env inst) 1646 | (let ((reg (setreg-inst-reg inst)) 1647 | (expr (setreg-inst-expr inst))) 1648 | (let ((expr1 (or (immediates-environment-lookup expr env) 1649 | expr))) 1650 | `(setreg ,reg ,expr1)))) 1651 | 1652 | (defun immediates-call (env inst) 1653 | (let ((name (call-inst-name inst)) 1654 | (operands (call-inst-operands inst))) 1655 | (let ((operands1 (mapcar #'(lambda (operand) 1656 | (or (immediates-environment-lookup operand env) 1657 | operand)) 1658 | operands))) 1659 | `(call ,name ,@operands1)))) 1660 | 1661 | 1662 | ;;; 1663 | ;;; Register assignment 1664 | ;;; 1665 | 1666 | (defun input-regs (n) 1667 | (loop for i from 0 below n 1668 | collect 1669 | (make-keyword (format nil "I~A" i)))) 1670 | 1671 | (defun input-reg-p (object) 1672 | (and (pic-reg-p object) 1673 | (member object (input-regs 8)) 1674 | t)) 1675 | 1676 | (defun local-regs (n) 1677 | (loop for i from 0 below n 1678 | collect 1679 | (make-keyword (format nil "L~A" i)))) 1680 | 1681 | (defun local-reg-p (object) 1682 | (and (pic-reg-p object) 1683 | (member object (local-regs 8)) 1684 | t)) 1685 | 1686 | (defun empty-register-environment () 1687 | nil) 1688 | 1689 | (defun register-environment-plist (env) 1690 | (loop for lreg in (local-regs 8) 1691 | append 1692 | (let ((var (caar (member lreg env :key #'cdr)))) 1693 | (list lreg var)))) 1694 | 1695 | (defun register-environment-assign (var cont env) 1696 | (if (register-environment-exists-p var env) 1697 | env 1698 | (let ((reg (register-environment-input-register var cont))) 1699 | (if reg 1700 | (register-environment-assign% reg var env) 1701 | (let ((reg (register-environment-empty-register env))) 1702 | (if reg 1703 | (register-environment-assign% reg var env) 1704 | (let ((reg (register-environment-dead-register cont env))) 1705 | (if reg 1706 | (register-environment-assign% reg var env) 1707 | (error "There is no available register."))))))))) 1708 | 1709 | (defun register-environment-assign% (reg var env) 1710 | (acons var reg 1711 | (remove reg env :key #'cdr))) 1712 | 1713 | (defun register-environment-input-register (var cont) 1714 | (let ((cont1 (car cont))) 1715 | (multiple-value-bind (iregs call-found-p cont-p) 1716 | (register-environment-input-register% var nil cont1) 1717 | (declare (ignore call-found-p)) 1718 | (if (and (singlep iregs) (not cont-p)) 1719 | (car iregs) 1720 | nil)))) 1721 | 1722 | (defun register-environment-input-register% (var cont form) 1723 | (assert (not (letrec-inst-p form))) 1724 | (cond 1725 | ((let-inst-p form) (register-environment-input-register-let var cont form)) 1726 | ((set-inst-p form) (register-environment-input-register-default)) 1727 | ((mov-inst-p form) (register-environment-input-register-default)) 1728 | ((sub-inst-p form) (register-environment-input-register-default)) 1729 | ((ifeq-inst-p form) (register-environment-input-register-ifeq var cont form)) 1730 | ((loop-inst-p form) (register-environment-input-register-loop var cont form)) 1731 | ((setreg-inst-p form) (register-environment-input-register-default)) 1732 | ((call-inst-p form) (register-environment-input-register-call var cont form)) 1733 | (t (error "The value ~S is an invalid form." form)))) 1734 | 1735 | (defun register-environment-input-register-let (var cont form) 1736 | (let ((expr (let-inst-expr form)) 1737 | (body (let-inst-body form))) 1738 | (let ((cont1 (cons body cont))) 1739 | (multiple-value-bind (iregs1 call-found-p1 cont-p1) 1740 | (register-environment-input-register% var cont1 expr) 1741 | (if call-found-p1 1742 | (values iregs1 t cont-p1) 1743 | (register-environment-input-register% var cont body)))))) 1744 | 1745 | (defun register-environment-input-register-ifeq (var cont form) 1746 | (let ((then (ifeq-inst-then form)) 1747 | (else (ifeq-inst-else form))) 1748 | (multiple-value-bind (iregs1 call-found-p1 cont-p1) 1749 | (register-environment-input-register% var cont then) 1750 | (multiple-value-bind (iregs2 call-found-p2 cont-p2) 1751 | (register-environment-input-register% var cont else) 1752 | (values (union iregs1 iregs2) 1753 | (or call-found-p1 call-found-p2) 1754 | (or cont-p1 cont-p2)))))) 1755 | 1756 | (defun register-environment-input-register-loop (var cont form) 1757 | (let ((body (loop-inst-body form))) 1758 | (multiple-value-bind (iregs call-found-p cont-p) 1759 | (register-environment-input-register% var cont body) 1760 | (if iregs 1761 | (values iregs call-found-p t) 1762 | (values iregs call-found-p cont-p))))) 1763 | 1764 | (defun register-environment-input-register-call (var cont form) 1765 | (let ((operands (call-inst-operands form))) 1766 | (let ((iregs (loop for operand in operands 1767 | for ireg in (input-regs (length operands)) 1768 | if (eq var operand) 1769 | collect ireg)) 1770 | (cont-p (and (member var (flatten-list cont)) 1771 | t))) 1772 | (values iregs t cont-p)))) 1773 | 1774 | (defun register-environment-input-register-default () 1775 | (values nil nil nil)) 1776 | 1777 | (defun register-environment-empty-register (env) 1778 | (let ((env1 (register-environment-plist env))) 1779 | (loop for (reg var) on env1 by #'cddr 1780 | if (null var) 1781 | return reg))) 1782 | 1783 | (defun register-environment-dead-register (cont env) 1784 | (let ((env1 (register-environment-plist env))) 1785 | (loop for (reg var) on env1 by #'cddr 1786 | if (not (member var (flatten-list cont))) 1787 | return reg))) 1788 | 1789 | (defun register-environment-alive-registers (cont env) 1790 | (let ((env1 (register-environment-plist env))) 1791 | (loop for (reg var) on env1 by #'cddr 1792 | if (member var (flatten-list cont)) 1793 | collect reg))) 1794 | 1795 | (defun register-environment-assign-list (vars cont env) 1796 | (if vars 1797 | (destructuring-bind (var . rest) vars 1798 | (register-environment-assign-list rest cont 1799 | (register-environment-assign var cont env))) 1800 | env)) 1801 | 1802 | (defun register-environment-exists-p (var env) 1803 | (and (cdr (assoc var env)) 1804 | t)) 1805 | 1806 | (defun register-environment-lookup (var env) 1807 | (if (pic-reg-p var) 1808 | var 1809 | (or (cdr (assoc var env)) 1810 | (error "The variable ~S not found." var)))) 1811 | 1812 | (defun assign (env cont inst) 1813 | (cond 1814 | ((let-inst-p inst) (assign-let env cont inst)) 1815 | ((letrec-inst-p inst) (assign-letrec env cont inst)) 1816 | ((set-inst-p inst) (assign-set env inst)) 1817 | ((mov-inst-p inst) (assign-mov env inst)) 1818 | ((sub-inst-p inst) (assign-sub env inst)) 1819 | ((ifeq-inst-p inst) (assign-ifeq env cont inst)) 1820 | ((loop-inst-p inst) (assign-loop env cont inst)) 1821 | ((setreg-inst-p inst) (assign-setreg env inst)) 1822 | ((call-inst-p inst) (assign-call env cont inst)) 1823 | (t (error "The value ~S is an invalid instruction." inst)))) 1824 | 1825 | (defun assign-let (env cont inst) 1826 | (let ((var (let-inst-var inst)) 1827 | (expr (let-inst-expr inst)) 1828 | (body (let-inst-body inst))) 1829 | (let ((cont1 (cons body cont))) 1830 | (multiple-value-bind (expr1 env1) (assign env cont1 expr) 1831 | (let* ((env2 (register-environment-assign var cont1 env1)) 1832 | (var1 (register-environment-lookup var env2))) 1833 | (multiple-value-bind (body1 env3) (assign env2 cont body) 1834 | (values `(let ((,var1 ,expr1)) 1835 | ,body1) 1836 | env3))))))) 1837 | 1838 | (defun assign-letrec (env cont inst) 1839 | (assert (null cont)) 1840 | (let ((name (letrec-inst-name inst)) 1841 | (args (letrec-inst-args inst)) 1842 | (expr (letrec-inst-expr inst)) 1843 | (body (letrec-inst-body inst))) 1844 | (let* ((cont1 (list expr)) 1845 | (env0 (register-environment-assign-list args cont1 1846 | (empty-register-environment))) 1847 | (args1 (mapcar #'(lambda (arg) 1848 | (register-environment-lookup arg env0)) 1849 | args)) 1850 | (expr1 (assign env0 nil expr))) 1851 | (multiple-value-bind (body1 env1) (assign env cont body) 1852 | (values `(let ((,name ,args1 ,expr1)) 1853 | ,body1) 1854 | env1))))) 1855 | 1856 | (defun assign-set (env inst) 1857 | (values inst env)) 1858 | 1859 | (defun assign-mov (env inst) 1860 | (let ((reg (mov-inst-reg inst))) 1861 | (let ((reg1 (register-environment-lookup reg env))) 1862 | (values `(mov ,reg1) env)))) 1863 | 1864 | (defun assign-sub (env inst) 1865 | (let ((expr1 (sub-inst-expr1 inst)) 1866 | (expr2 (sub-inst-expr2 inst))) 1867 | (let ((expr1% (register-environment-lookup expr1 env)) 1868 | (expr2% (if (literal-p expr2) 1869 | expr2 1870 | (register-environment-lookup expr2 env)))) 1871 | (values `(sub ,expr1% ,expr2%) 1872 | env)))) 1873 | 1874 | (defun assign-ifeq (env cont inst) 1875 | (let ((lhs (ifeq-inst-lhs inst)) 1876 | (rhs (ifeq-inst-rhs inst)) 1877 | (then (ifeq-inst-then inst)) 1878 | (else (ifeq-inst-else inst))) 1879 | (let ((lhs1 (register-environment-lookup lhs env)) 1880 | (rhs1 (if (literal-p rhs) 1881 | rhs 1882 | (register-environment-lookup rhs env)))) 1883 | (multiple-value-bind (then1 env1) (assign env cont then) 1884 | (multiple-value-bind (else1 env2) (assign env1 cont else) 1885 | (values `(ifeq ,lhs1 ,rhs1 ,then1 ,else1) env2)))))) 1886 | 1887 | (defun assign-loop (env cont inst) 1888 | (let ((var (loop-inst-var inst)) 1889 | (body (loop-inst-body inst))) 1890 | (let ((var1 (register-environment-lookup var env)) 1891 | ;; add loop continuation for keeping the loop register alive 1892 | (cont1 (cons `(loop ,var) cont))) 1893 | (multiple-value-bind (body1 env1) (assign env cont1 body) 1894 | (values `(loop ,var1 ,body1) env1))))) 1895 | 1896 | (defun assign-setreg (env inst) 1897 | (let ((reg (setreg-inst-reg inst)) 1898 | (expr (setreg-inst-expr inst))) 1899 | (let ((expr1 (if (literal-p expr) 1900 | expr 1901 | (register-environment-lookup expr env)))) 1902 | (values `(setreg ,reg ,expr1) 1903 | env)))) 1904 | 1905 | (defun assign-call (env cont inst) 1906 | (let ((name (call-inst-name inst)) 1907 | (operands (call-inst-operands inst))) 1908 | (let ((operands1 (mapcar #'(lambda (operand) 1909 | (if (literal-p operand) 1910 | operand 1911 | (register-environment-lookup operand env))) 1912 | operands))) 1913 | (let ((alive-regs (register-environment-alive-registers cont env))) 1914 | (if alive-regs 1915 | (values `(with-save ,alive-regs 1916 | (call ,name ,@operands1)) 1917 | env) 1918 | (values `(call ,name ,@operands1) 1919 | env)))))) 1920 | 1921 | 1922 | ;;; 1923 | ;;; Emit 8-bit PIC assembly 1924 | ;;; 1925 | 1926 | (defvar *label-counter* 0) 1927 | 1928 | (defun genlbl (&rest things) 1929 | (let ((cnt (princ-to-string *label-counter*))) 1930 | (if (singlep things) 1931 | (prog1 (symbolicate (car things) cnt) 1932 | (incf *label-counter*)) 1933 | (prog1 (mapcar #'(lambda (thing) 1934 | (symbolicate thing cnt)) 1935 | things) 1936 | (incf *label-counter*))))) 1937 | 1938 | (defun emit (dest inst) 1939 | (cond 1940 | ((let-inst-p inst) (emit-let dest inst)) 1941 | ((letrec-inst-p inst) (emit-letrec dest inst)) 1942 | ((set-inst-p inst) (emit-set dest inst)) 1943 | ((mov-inst-p inst) (emit-mov dest inst)) 1944 | ((sub-inst-p inst) (emit-sub dest inst)) 1945 | ((ifeq-inst-p inst) (emit-ifeq dest inst)) 1946 | ((loop-inst-p inst) (emit-loop dest inst)) 1947 | ((setreg-p inst) (emit-setreg dest inst)) 1948 | ((call-inst-p inst) (emit-call dest inst)) 1949 | ((with-save-inst-p inst) (emit-with-save dest inst)) 1950 | (t (error "The value ~S is an invalid instruction." inst)))) 1951 | 1952 | (defun emit-let (dest inst) 1953 | (let ((var (let-inst-var inst)) 1954 | (expr (let-inst-expr inst)) 1955 | (body (let-inst-body inst))) 1956 | (append (emit `(:non-tail ,var) expr) 1957 | (emit dest body)))) 1958 | 1959 | (defun emit-letrec (dest inst) 1960 | (assert (eq dest :tail)) 1961 | (let ((name (letrec-inst-name inst)) 1962 | (args (letrec-inst-args inst)) 1963 | (expr (letrec-inst-expr inst)) 1964 | (body (letrec-inst-body inst))) 1965 | (let ((args1 (loop for arg in args 1966 | for ireg in (input-regs (length args)) 1967 | append (if (input-reg-p arg) 1968 | nil 1969 | `((movf ,ireg :w) 1970 | (movwf ,arg))))) 1971 | (expr1 (emit :tail expr)) 1972 | (body1 (emit dest body))) 1973 | `(,@body1 1974 | ,name 1975 | ,@args1 1976 | ,@expr1)))) 1977 | 1978 | (defun emit-set (dest inst) 1979 | (let ((literal (set-inst-literal inst))) 1980 | (cl-pattern:match dest 1981 | ((:non-tail reg) 1982 | (cond 1983 | ((eq :null reg) nil) 1984 | ((= literal 0) `((clrf ,reg))) 1985 | (t `((movlw ,literal) 1986 | (movwf ,reg))))) 1987 | (:tail `((retlw ,literal))) 1988 | (_ (error "The value ~S is an invalid destination." dest))))) 1989 | 1990 | (defun emit-mov (dest inst) 1991 | (let ((reg (mov-inst-reg inst))) 1992 | (cl-pattern:match dest 1993 | ((:non-tial :null) nil) 1994 | ((:non-tail reg1) `((movf ,reg :w) 1995 | (movwf ,reg1))) 1996 | (:tail `((movf ,reg :w) 1997 | (return))) 1998 | (_ (error "The value ~S is an invalid destination." dest))))) 1999 | 2000 | (defun emit-sub (dest inst) 2001 | (let ((expr1 (sub-inst-expr1 inst)) 2002 | (expr2 (sub-inst-expr2 inst))) 2003 | (let ((expr2-insts (if (literal-p expr2) 2004 | `((movlw ,expr2)) 2005 | `((movf ,expr2 :w))))) 2006 | (cl-pattern:match dest 2007 | ((:non-tail :null) nil) 2008 | ((:non-tail reg) `(,@expr2-insts 2009 | (subwf ,expr1 :w) 2010 | (movwf ,reg))) 2011 | (:tail `(,@expr2-insts 2012 | (subwf ,expr1 :w) 2013 | (return))) 2014 | (_ (error "The value ~S is an invalid destination." dest)))))) 2015 | 2016 | (defun emit-ifeq (dest inst) 2017 | (let ((lhs (ifeq-inst-lhs inst)) 2018 | (rhs (ifeq-inst-rhs inst)) 2019 | (then (ifeq-inst-then inst)) 2020 | (else (ifeq-inst-else inst))) 2021 | (let ((rhs-insts (if (literal-p rhs) 2022 | `((movlw ,rhs)) 2023 | `((movf ,rhs :w))))) 2024 | (let ((then1 (emit dest then)) 2025 | (else1 (emit dest else))) 2026 | (destructuring-bind (else-lbl end-lbl) (genlbl "ELSE" "END") 2027 | (cl-pattern:match dest 2028 | ((:non-tail _) `(,@rhs-insts 2029 | (subwf ,lhs :w) 2030 | (btfsc :status :z) 2031 | (goto ,else-lbl) 2032 | ,@then1 2033 | (goto ,end-lbl) 2034 | ,else-lbl 2035 | ,@else1 2036 | ,end-lbl)) 2037 | (:tail `(,@rhs-insts 2038 | (subwf ,lhs :w) 2039 | (btfsc :status :z) 2040 | (goto ,else-lbl) 2041 | ,@then1 2042 | ,else-lbl 2043 | ,@else1)) 2044 | (_ (error "The value ~S is an invalid destination." dest)))))))) 2045 | 2046 | (defun emit-loop (dest inst) 2047 | (let ((reg (loop-inst-var inst)) 2048 | (body (loop-inst-body inst))) 2049 | (let ((loop-lbl (genlbl "LOOP")) 2050 | (body-insts (emit '(:non-tail :null) body))) 2051 | (cl-pattern:match dest 2052 | ((:non-tail _) `(,loop-lbl 2053 | ,@body-insts 2054 | (decfsz ,reg :f) 2055 | (goto ,loop-lbl))) 2056 | (:tail `(,loop-lbl 2057 | ,@body-insts 2058 | (decfsz ,reg :f) 2059 | (goto ,loop-lbl) 2060 | (retlw 0))) 2061 | (_ (error "The value ~S is an invalid destination." dest)))))) 2062 | 2063 | (defun emit-setreg (dest inst) 2064 | (let ((reg (setreg-inst-reg inst)) 2065 | (expr (setreg-inst-expr inst))) 2066 | (let ((expr-insts (if (literal-p expr) 2067 | (if (= expr 0) 2068 | `((clrf ,reg)) 2069 | `((movlw ,expr) 2070 | (movwf ,reg))) 2071 | `((movf ,expr :w) 2072 | (movwf ,reg))))) 2073 | (cl-pattern:match dest 2074 | ((:non-tail _) `(,@expr-insts)) 2075 | (:tail `(,@expr-insts 2076 | (return))) 2077 | (_ (error "The value ~S is an invalid destination." dest)))))) 2078 | 2079 | (defun emit-call (dest inst) 2080 | (let ((name (call-inst-name inst)) 2081 | (operands (call-inst-operands inst))) 2082 | (let ((ireg-insts (loop for operand in operands 2083 | for ireg in (input-regs (length operands)) 2084 | append (cond 2085 | ((literal-p operand) `((movlw ,operand) 2086 | (movwf ,ireg))) 2087 | ((input-reg-p operand) nil) 2088 | (t `((movf ,operand :w) 2089 | (movwf ,ireg))))))) 2090 | (cl-pattern:match dest 2091 | ((:non-tail :null) `(,@ireg-insts 2092 | (call ,name))) 2093 | ((:non-tail reg) `(,@ireg-insts 2094 | (call ,name) 2095 | (movwf ,reg))) 2096 | (:tail `(,@ireg-insts 2097 | (goto ,name))) 2098 | (_ (error "The value ~S is an invalid destination." dest)))))) 2099 | 2100 | (defun emit-with-save (dest inst) 2101 | (let ((regs (with-save-inst-regs inst)) 2102 | (expr (with-save-inst-expr inst))) 2103 | (assert (call-inst-p expr)) 2104 | (let ((save-insts (loop for reg in regs 2105 | append `((movf ,reg :w) 2106 | (call push-stack)))) 2107 | (call-insts (emit-call dest expr)) 2108 | (restore-insts (loop for reg in regs 2109 | append `((call pop-stack) 2110 | (movwf ,reg))))) 2111 | `(,@save-insts 2112 | ,@call-insts 2113 | ,@restore-insts)))) 2114 | 2115 | 2116 | ;;; 2117 | ;;; Output 8-bit PIC assembly 2118 | ;;; 2119 | 2120 | (defun output (insts) 2121 | (loop for inst in insts 2122 | do (if (listp inst) 2123 | (output-inst inst) 2124 | (output-label inst)))) 2125 | 2126 | (defun output-inst (inst) 2127 | (let ((operator (car inst)) 2128 | (operands (cdr inst))) 2129 | (let ((operands1 (mapcar #'compile-token operands))) 2130 | (format t "~8T~A~16T~{~A~^,~}~%" operator operands1)))) 2131 | 2132 | (defun output-label (label) 2133 | (format t "~A~%" (compile-token label))) 2134 | 2135 | 2136 | ;;; 2137 | ;;; Compilation 2138 | ;;; 2139 | 2140 | (defun repeatedly (limit fun form) 2141 | (if (= limit 0) 2142 | form 2143 | (let ((form1 (funcall fun form))) 2144 | (if (equal form form1) 2145 | form1 2146 | (repeatedly (1- limit) fun form1))))) 2147 | 2148 | (defvar *limit* 1000) 2149 | 2150 | (defun compile-pic (form fundefs) 2151 | (output 2152 | (emit :tail 2153 | (assign (empty-register-environment) nil 2154 | (immediates (empty-immediates-environment) 2155 | (virtual 2156 | (closure 2157 | (repeatedly *limit* 2158 | #'(lambda (form) 2159 | (elim 2160 | (flatten 2161 | (beta (empty-beta-environment) form)))) 2162 | (alpha2 (empty-alpha2-environment) 2163 | (alpha1 (empty-alpha1-environment) 2164 | (k-normal (empty-k-normal-environment) 2165 | (repeatedly *limit* 2166 | #'(lambda (form) 2167 | (inlined fundefs form)) 2168 | (expand form))))))))))))) 2169 | 2170 | (defun expand-pic (form) 2171 | (expand form)) 2172 | 2173 | (defun inlined-pic (form fundefs) 2174 | (repeatedly *limit* 2175 | #'(lambda (form) 2176 | (inlined fundefs form)) 2177 | (expand-pic form))) 2178 | 2179 | (defun k-normal-pic (form fundefs) 2180 | (k-normal (empty-k-normal-environment) 2181 | (inlined-pic form fundefs))) 2182 | 2183 | (defun alpha-pic (form fundefs) 2184 | (alpha2 (empty-alpha2-environment) 2185 | (alpha1 (empty-alpha1-environment) 2186 | (k-normal-pic form fundefs)))) 2187 | 2188 | (defun beta-pic (form fundefs) 2189 | (beta (empty-beta-environment) 2190 | (alpha-pic form fundefs))) 2191 | 2192 | (defun flatten-pic (form fundefs) 2193 | (flatten 2194 | (beta-pic form fundefs))) 2195 | 2196 | (defun elim-pic (form fundefs) 2197 | (elim 2198 | (inlined-pic form fundefs))) 2199 | 2200 | (defun closure-pic (form fundefs) 2201 | (closure 2202 | (repeatedly *limit* 2203 | #'(lambda (form) 2204 | (elim 2205 | (flatten 2206 | (beta (empty-beta-environment) form)))) 2207 | (alpha-pic form fundefs)))) 2208 | 2209 | (defun virtual-pic (form fundefs) 2210 | (virtual 2211 | (closure-pic form fundefs))) 2212 | 2213 | (defun immediates-pic (form fundefs) 2214 | (immediates (empty-immediates-environment) 2215 | (virtual-pic form fundefs))) 2216 | 2217 | (defun assign-pic (form fundefs) 2218 | (assign (empty-register-environment) nil 2219 | (immediates-pic form fundefs))) 2220 | 2221 | (defun emit-pic (form fundefs) 2222 | (emit :tail 2223 | (assign-pic form fundefs))) 2224 | 2225 | (defun output-pic (form fundefs) 2226 | (output 2227 | (emit-pic form fundefs))) 2228 | 2229 | 2230 | ;;; 2231 | ;;; Program 2232 | ;;; 2233 | 2234 | (defun make-program () 2235 | (make-hash-table)) 2236 | 2237 | (defun program-defun (program name args body) 2238 | (unless (pic-symbol-p name) 2239 | (error "The value ~S is an invalid pic symbol." name)) 2240 | (dolist (arg args) 2241 | (unless (pic-symbol-p arg) 2242 | (error "The value ~S is an invalid pic symbol." arg))) 2243 | (unless (equal args (remove-duplicates args)) 2244 | (error "The values ~S are invalid arguments." args)) 2245 | (when (eq name 'main) 2246 | (unless (null args) 2247 | (error "The main function must have no arguments."))) 2248 | (when (eq name 'init) 2249 | (unless (null args) 2250 | (error "The init function must have no arguments."))) 2251 | (when (eq name 'intr) 2252 | (unless (null args) 2253 | (error "The intrrupt function must have no arguments."))) 2254 | (let* ((fundefs (program-fundefs-excluding program name)) 2255 | (insts (with-output-to-string (s) 2256 | (let ((*standard-output* s)) 2257 | (cond 2258 | ((eq name 'main) (write-line "_MAIN") 2259 | (compile-pic body fundefs)) 2260 | ((eq name 'init) (write-line "_INIT") 2261 | (compile-pic body fundefs)) 2262 | ((eq name 'intr) (write-line "_INTR") 2263 | (compile-pic body fundefs)) 2264 | (t (write-line (compile-token name) s) 2265 | (compile-pic `(with-args ,args ,body) fundefs))))))) 2266 | (setf (gethash name program) (list args body insts)) 2267 | name)) 2268 | 2269 | (defun program-defmacro (name expander) 2270 | (setf (get name 'pic-macro) expander) 2271 | name) 2272 | 2273 | (defun program-names (program) 2274 | (hash-table-keys program)) 2275 | 2276 | (defun program-fundefs (program) 2277 | (loop for name in (program-names program) 2278 | collect 2279 | (destructuring-bind (args body insts) (program-by-name program name) 2280 | (declare (ignore insts)) 2281 | (let ((body1 (expand body))) 2282 | (list name args body1))))) 2283 | 2284 | (defun program-fundefs-excluding (program name) 2285 | (remove name (program-fundefs program) :key #'car)) 2286 | 2287 | (defun program-exists-p (program name) 2288 | (and (gethash name program) 2289 | t)) 2290 | 2291 | (defun program-by-name (program name) 2292 | (or (values (gethash name program)) 2293 | (error "The function ~S not defined." name))) 2294 | 2295 | (defun program-compute-dependency (program) 2296 | (remove-duplicates 2297 | (append 2298 | (program-compute-dependency% program 'init) 2299 | (program-compute-dependency% program 'main) 2300 | (program-compute-dependency% program 'intr)))) 2301 | 2302 | (defun program-compute-dependency% (program name) 2303 | (if (program-exists-p program name) 2304 | (destructuring-bind (args body insts) (program-by-name program name) 2305 | (declare (ignore args body)) 2306 | (remove-duplicates 2307 | (loop for name1 in (program-names program) 2308 | if (and (not (eq name name1)) 2309 | (search (compile-token name1) insts)) 2310 | append (cons name1 2311 | (program-compute-dependency% program name1))))) 2312 | nil)) 2313 | 2314 | (defun program-macro-exists-p (name) 2315 | (and (symbolp name) 2316 | (get name 'pic-macro) 2317 | t)) 2318 | 2319 | (defun program-macro (name) 2320 | (if (program-macro-exists-p name) 2321 | (get name 'pic-macro) 2322 | (error "The macro ~S not defined." name))) 2323 | 2324 | (defun program-disassemble (program name) 2325 | (destructuring-bind (args body insts) (program-by-name program name) 2326 | (declare (ignore args body)) 2327 | (princ insts) 2328 | (values))) 2329 | 2330 | (defun program-clear (program) 2331 | (clrhash program) 2332 | (values)) 2333 | 2334 | (defun program-main (program) 2335 | (unless (program-exists-p program 'main) 2336 | (error "The main function not defined.")) 2337 | (program-by-name program 'main)) 2338 | 2339 | (defun program-init (program) 2340 | (values (gethash 'init program))) 2341 | 2342 | (defun program-intr (program) 2343 | (values (gethash 'intr program))) 2344 | 2345 | (defun program-compile (program &optional (stream *standard-output*)) 2346 | (program-main program) ; Check main existing. 2347 | (write-line " INCLUDE\"p12f683.inc\"" stream) 2348 | (write-line " list p=12f683" stream) 2349 | (write-line "" stream) 2350 | (write-line " __CONFIG _CP_OFF & _CPD_OFF & _WDT_OFF & _BOD_ON & _IESO_OFF& _PWRTE_ON & _INTOSCIO & _MCLRE_OFF" stream) 2351 | (write-line "" stream) 2352 | (write-line " CBLOCK 020h" stream) 2353 | (write-line " L0,L1,L2,L3,L4,L5,L6,L7 ; local registers" stream) 2354 | (write-line " I0,I1,I2,I3,I4,I5,I6,I7 ; input registers" stream) 2355 | (write-line " NULL ; null register (for NOP)" stream) 2356 | (write-line " SP,STMP,STK ; stack registers" stream) 2357 | (write-line " ENDC" stream) 2358 | (write-line "" stream) 2359 | (write-line " ORG 0" stream) 2360 | (write-line " GOTO MAIN" stream) 2361 | (write-line " ORG 4" stream) 2362 | (write-line " GOTO INTR" stream) 2363 | (output-functions program stream) 2364 | (output-intr program stream) 2365 | (output-init program stream) 2366 | (output-main program stream) 2367 | (write-line "_PUSH_STACK" stream) 2368 | (write-line " MOVWF STMP" stream) 2369 | (write-line " MOVF SP,W" stream) 2370 | (write-line " MOVWF FSR" stream) 2371 | (write-line " MOVF STMP,W" stream) 2372 | (write-line " MOVWF INDF" stream) 2373 | (write-line " INCF SP,F" stream) 2374 | (write-line " RETURN" stream) 2375 | (write-line "_POP_STACK" stream) 2376 | (write-line " DECF SP,F" stream) 2377 | (write-line " MOVF SP,W" stream) 2378 | (write-line " MOVWF FSR" stream) 2379 | (write-line " MOVF INDF,W" stream) 2380 | (write-line " RETURN" stream) 2381 | (write-line "INTR" stream) 2382 | (write-line " CALL _INTR" stream) 2383 | (write-line " RETFIE" stream) 2384 | (write-line "MAIN" stream) 2385 | (write-line " MOVLW STK ; initialize SP" stream) 2386 | (write-line " MOVWF SP" stream) 2387 | (write-line " CALL _INIT" stream) 2388 | (write-line " CALL _MAIN" stream) 2389 | (write-line " END" stream) 2390 | (values)) 2391 | 2392 | (defun output-init (program stream) 2393 | (let ((init (program-init program))) 2394 | (if init 2395 | (destructuring-bind (args body insts) init 2396 | (declare (ignore args body)) 2397 | (princ insts stream)) 2398 | (progn 2399 | (write-line "_INIT" stream) 2400 | (write-line " RETURN" stream))))) 2401 | 2402 | (defun output-main (program stream) 2403 | (destructuring-bind (args body insts) (program-main program) 2404 | (declare (ignore args body)) 2405 | (princ insts stream))) 2406 | 2407 | (defun output-intr (program stream) 2408 | (let ((intr (program-intr program))) 2409 | (if intr 2410 | (destructuring-bind (args body insts) intr 2411 | (declare (ignore args body)) 2412 | (princ insts stream)) 2413 | (progn 2414 | (write-line "_INTR" stream) 2415 | (write-line " RETURN" stream))))) 2416 | 2417 | (defun output-functions (program stream) 2418 | (loop for name in (program-compute-dependency program) 2419 | do (destructuring-bind (args body insts) 2420 | (program-by-name program name) 2421 | (declare (ignore args body)) 2422 | (princ insts stream)))) 2423 | 2424 | 2425 | ;;; 2426 | ;;; Programming Interfaces 2427 | ;;; 2428 | 2429 | (defvar *program* (make-program)) 2430 | 2431 | (defmacro defpic (name args body) 2432 | `(program-defun *program* ',name ',args ',body)) 2433 | 2434 | (defmacro defpicmacro (name args &rest body) 2435 | `(program-defmacro ',name #'(lambda ,args ,@body))) 2436 | 2437 | (defun pic-compile (&optional (stream *standard-output*)) 2438 | (program-compile *program* stream)) 2439 | 2440 | (defun pic-disassemble (name) 2441 | (program-disassemble *program* name)) 2442 | 2443 | (defun pic-macroexpand (form) 2444 | (labels ((aux (form expanded-p) 2445 | (multiple-value-bind (expansion newly-expanded-p) 2446 | (pic-macroexpand1 form) 2447 | (if newly-expanded-p 2448 | (aux expansion t) 2449 | (values expansion expanded-p))))) 2450 | (aux form nil))) 2451 | 2452 | (defun pic-macroexpand1 (form) 2453 | (if (macro-p form) 2454 | (let ((expander (macro-expander form)) 2455 | (operands (macro-operands form))) 2456 | (values (apply expander operands) t)) 2457 | (values form nil))) 2458 | 2459 | (defun pic-clear () 2460 | (program-clear *program*)) 2461 | 2462 | 2463 | ;;; 2464 | ;;; Macros 2465 | ;;; 2466 | 2467 | (defpicmacro progn (&rest forms) 2468 | (labels ((aux (forms0) 2469 | (let ((form (car forms0)) 2470 | (rest (cdr forms0))) 2471 | (if rest 2472 | `(let ((tmp ,form)) 2473 | ,(aux rest)) 2474 | form)))) 2475 | (aux forms))) 2476 | 2477 | (defpicmacro nop () 2478 | '(setreg :null 0)) 2479 | 2480 | (defpicmacro setbank0 () 2481 | '(setreg :status #x00)) 2482 | 2483 | (defpicmacro setbank1 () 2484 | '(setreg :status #x20)) 2485 | --------------------------------------------------------------------------------