| 1 | ;;; GHIL -> GLIL compiler |
| 2 | |
| 3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; This program is free software; you can redistribute it and/or modify |
| 6 | ;; it under the terms of the GNU General Public License as published by |
| 7 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 8 | ;; any later version. |
| 9 | ;; |
| 10 | ;; This program is distributed in the hope that it will be useful, |
| 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 13 | ;; GNU General Public License for more details. |
| 14 | ;; |
| 15 | ;; You should have received a copy of the GNU General Public License |
| 16 | ;; along with this program; see the file COPYING. If not, write to |
| 17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 18 | ;; Boston, MA 02111-1307, USA. |
| 19 | |
| 20 | ;;; Code: |
| 21 | |
| 22 | (define-module (system il compile) |
| 23 | #:use-syntax (system base syntax) |
| 24 | #:use-module (system il glil) |
| 25 | #:use-module (system il ghil) |
| 26 | #:use-module (ice-9 common-list) |
| 27 | #:export (compile)) |
| 28 | |
| 29 | (define (compile x e . opts) |
| 30 | (if (memq #:O opts) (set! x (optimize x))) |
| 31 | (codegen x)) |
| 32 | |
| 33 | \f |
| 34 | ;;; |
| 35 | ;;; Stage 2: Optimization |
| 36 | ;;; |
| 37 | |
| 38 | (define (lift-variables! env) |
| 39 | (let ((parent-env (ghil-env-parent env))) |
| 40 | (for-each (lambda (v) |
| 41 | (case (ghil-var-kind v) |
| 42 | ((argument) (set! (ghil-var-kind v) 'local))) |
| 43 | (set! (ghil-var-env v) parent-env) |
| 44 | (ghil-env-add! parent-env v)) |
| 45 | (ghil-env-variables env)))) |
| 46 | |
| 47 | (define (optimize x) |
| 48 | (record-case x |
| 49 | ((<ghil-set> env loc var val) |
| 50 | (make-ghil-set env var (optimize val))) |
| 51 | |
| 52 | ((<ghil-define> env loc var val) |
| 53 | (make-ghil-define env var (optimize val))) |
| 54 | |
| 55 | ((<ghil-if> env loc test then else) |
| 56 | (make-ghil-if env loc (optimize test) (optimize then) (optimize else))) |
| 57 | |
| 58 | ((<ghil-and> env loc exps) |
| 59 | (make-ghil-and env loc (map optimize exps))) |
| 60 | |
| 61 | ((<ghil-or> env loc exps) |
| 62 | (make-ghil-or env loc (map optimize exps))) |
| 63 | |
| 64 | ((<ghil-begin> env loc exps) |
| 65 | (make-ghil-begin env loc (map optimize exps))) |
| 66 | |
| 67 | ((<ghil-bind> env loc vars vals body) |
| 68 | (make-ghil-bind env loc vars (map optimize vals) (optimize body))) |
| 69 | |
| 70 | ((<ghil-lambda> env loc vars rest meta body) |
| 71 | (make-ghil-lambda env loc vars rest meta (optimize body))) |
| 72 | |
| 73 | ((<ghil-inline> env loc instruction args) |
| 74 | (make-ghil-inline env loc instruction (map optimize args))) |
| 75 | |
| 76 | ((<ghil-call> env loc proc args) |
| 77 | (let ((parent-env env)) |
| 78 | (record-case proc |
| 79 | ;; ((@lambda (VAR...) BODY...) ARG...) => |
| 80 | ;; (@let ((VAR ARG) ...) BODY...) |
| 81 | ((<ghil-lambda> env loc vars rest meta body) |
| 82 | (cond |
| 83 | ((not rest) |
| 84 | (lift-variables! env) |
| 85 | (make-ghil-bind parent-env loc (map optimize args))) |
| 86 | (else |
| 87 | (make-ghil-call parent-env loc (optimize proc) (map optimize args))))) |
| 88 | (else |
| 89 | (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))) |
| 90 | |
| 91 | ((<ghil-mv-call> env loc producer consumer) |
| 92 | (record-case consumer |
| 93 | ;; (mv-call PRODUCER (lambda ARGS BODY...)) => |
| 94 | ;; (mv-let PRODUCER ARGS BODY...) |
| 95 | ((<ghil-lambda> env loc vars rest meta body) |
| 96 | (lift-variables! env) |
| 97 | (make-ghil-mv-bind producer vars rest body)) |
| 98 | (else |
| 99 | (make-ghil-mv-call env loc (optimize producer) (optimize consumer))))) |
| 100 | |
| 101 | (else x))) |
| 102 | |
| 103 | \f |
| 104 | ;;; |
| 105 | ;;; Stage 3: Code generation |
| 106 | ;;; |
| 107 | |
| 108 | (define *ia-void* (make-glil-void)) |
| 109 | (define *ia-drop* (make-glil-call 'drop 0)) |
| 110 | (define *ia-return* (make-glil-call 'return 0)) |
| 111 | |
| 112 | (define (make-label) (gensym ":L")) |
| 113 | |
| 114 | (define (make-glil-var op env var) |
| 115 | (case (ghil-var-kind var) |
| 116 | ((argument) |
| 117 | (make-glil-argument op (ghil-var-index var))) |
| 118 | ((local) |
| 119 | (make-glil-local op (ghil-var-index var))) |
| 120 | ((external) |
| 121 | (do ((depth 0 (1+ depth)) |
| 122 | (e env (ghil-env-parent e))) |
| 123 | ((eq? e (ghil-var-env var)) |
| 124 | (make-glil-external op depth (ghil-var-index var))))) |
| 125 | ((toplevel) |
| 126 | (make-glil-toplevel op (ghil-var-name var))) |
| 127 | ((public private) |
| 128 | (make-glil-module op (ghil-var-env var) (ghil-var-name var) |
| 129 | (eq? (ghil-var-kind var) 'public))) |
| 130 | (else (error "Unknown kind of variable:" var)))) |
| 131 | |
| 132 | (define (constant? x) |
| 133 | (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t) |
| 134 | ((pair? x) (and (constant? (car x)) |
| 135 | (constant? (cdr x)))) |
| 136 | ((vector? x) (let lp ((i (vector-length x))) |
| 137 | (or (zero? i) |
| 138 | (and (constant? (vector-ref x (1- i))) |
| 139 | (lp (1- i)))))))) |
| 140 | |
| 141 | (define (codegen ghil) |
| 142 | (let ((stack '())) |
| 143 | (define (push-code! loc code) |
| 144 | (set! stack (cons code stack)) |
| 145 | (if loc (set! stack (cons (make-glil-source loc) stack)))) |
| 146 | (define (var->binding var) |
| 147 | (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) |
| 148 | (define (push-bindings! loc vars) |
| 149 | (if (not (null? vars)) |
| 150 | (push-code! loc (make-glil-bind (map var->binding vars))))) |
| 151 | (define (comp tree tail drop) |
| 152 | (define (push-label! label) |
| 153 | (push-code! #f (make-glil-label label))) |
| 154 | (define (push-branch! loc inst label) |
| 155 | (push-code! loc (make-glil-branch inst label))) |
| 156 | (define (push-call! loc inst args) |
| 157 | (for-each comp-push args) |
| 158 | (push-code! loc (make-glil-call inst (length args)))) |
| 159 | ;; possible tail position |
| 160 | (define (comp-tail tree) (comp tree tail drop)) |
| 161 | ;; push the result |
| 162 | (define (comp-push tree) (comp tree #f #f)) |
| 163 | ;; drop the result |
| 164 | (define (comp-drop tree) (comp tree #f #t)) |
| 165 | ;; drop the result if unnecessary |
| 166 | (define (maybe-drop) |
| 167 | (if drop (push-code! #f *ia-drop*))) |
| 168 | ;; return here if necessary |
| 169 | (define (maybe-return) |
| 170 | (if tail (push-code! #f *ia-return*))) |
| 171 | ;; return this code if necessary |
| 172 | (define (return-code! loc code) |
| 173 | (if (not drop) (push-code! loc code)) |
| 174 | (maybe-return)) |
| 175 | ;; return void if necessary |
| 176 | (define (return-void!) |
| 177 | (return-code! #f *ia-void*)) |
| 178 | ;; return object if necessary |
| 179 | (define (return-object! loc obj) |
| 180 | (return-code! loc (make-glil-const #:obj obj))) |
| 181 | ;; |
| 182 | ;; dispatch |
| 183 | (record-case tree |
| 184 | ((<ghil-void>) |
| 185 | (return-void!)) |
| 186 | |
| 187 | ((<ghil-quote> env loc obj) |
| 188 | (return-object! loc obj)) |
| 189 | |
| 190 | ((<ghil-quasiquote> env loc exp) |
| 191 | (let loop ((x exp)) |
| 192 | (cond |
| 193 | ((list? x) |
| 194 | (push-call! #f 'mark '()) |
| 195 | (for-each loop x) |
| 196 | (push-call! #f 'list-mark '())) |
| 197 | ((pair? x) |
| 198 | (loop (car x)) |
| 199 | (loop (cdr x)) |
| 200 | (push-code! #f (make-glil-call 'cons 2))) |
| 201 | ((record? x) |
| 202 | (record-case x |
| 203 | ((<ghil-unquote> env loc exp) |
| 204 | (comp-push exp)) |
| 205 | ((<ghil-unquote-splicing> env loc exp) |
| 206 | (comp-push exp) |
| 207 | (push-call! #f 'list-break '())))) |
| 208 | ((constant? x) |
| 209 | (push-code! #f (make-glil-const #:obj x))) |
| 210 | (else |
| 211 | (error "element of quasiquote can't be compiled" x)))) |
| 212 | (maybe-drop) |
| 213 | (maybe-return)) |
| 214 | |
| 215 | ((<ghil-ref> env loc var) |
| 216 | (return-code! loc (make-glil-var 'ref env var))) |
| 217 | |
| 218 | ((<ghil-set> env loc var val) |
| 219 | (comp-push val) |
| 220 | (push-code! loc (make-glil-var 'set env var)) |
| 221 | (return-void!)) |
| 222 | |
| 223 | ((<ghil-define> env loc var val) |
| 224 | (comp-push val) |
| 225 | (push-code! loc (make-glil-var 'define env var)) |
| 226 | (return-void!)) |
| 227 | |
| 228 | ((<ghil-if> env loc test then else) |
| 229 | ;; TEST |
| 230 | ;; (br-if-not L1) |
| 231 | ;; THEN |
| 232 | ;; (br L2) |
| 233 | ;; L1: ELSE |
| 234 | ;; L2: |
| 235 | (let ((L1 (make-label)) (L2 (make-label))) |
| 236 | (comp-push test) |
| 237 | (push-branch! loc 'br-if-not L1) |
| 238 | (comp-tail then) |
| 239 | (if (not tail) (push-branch! #f 'br L2)) |
| 240 | (push-label! L1) |
| 241 | (comp-tail else) |
| 242 | (if (not tail) (push-label! L2)))) |
| 243 | |
| 244 | ((<ghil-and> env loc exps) |
| 245 | ;; EXP |
| 246 | ;; (br-if-not L1) |
| 247 | ;; ... |
| 248 | ;; TAIL |
| 249 | ;; (br L2) |
| 250 | ;; L1: (const #f) |
| 251 | ;; L2: |
| 252 | (cond ((null? exps) (return-object! loc #t)) |
| 253 | ((null? (cdr exps)) (comp-tail (car exps))) |
| 254 | (else |
| 255 | (let ((L1 (make-label)) (L2 (make-label))) |
| 256 | (let lp ((exps exps)) |
| 257 | (cond ((null? (cdr exps)) |
| 258 | (comp-tail (car exps)) |
| 259 | (push-branch! #f 'br L2) |
| 260 | (push-label! L1) |
| 261 | (return-object! #f #f) |
| 262 | (push-label! L2) |
| 263 | (maybe-return)) |
| 264 | (else |
| 265 | (comp-push (car exps)) |
| 266 | (push-branch! #f 'br-if-not L1) |
| 267 | (lp (cdr exps))))))))) |
| 268 | |
| 269 | ((<ghil-or> env loc exps) |
| 270 | ;; EXP |
| 271 | ;; (dup) |
| 272 | ;; (br-if L1) |
| 273 | ;; (drop) |
| 274 | ;; ... |
| 275 | ;; TAIL |
| 276 | ;; L1: |
| 277 | (cond ((null? exps) (return-object! loc #f)) |
| 278 | ((null? (cdr exps)) (comp-tail (car exps))) |
| 279 | (else |
| 280 | (let ((L1 (make-label))) |
| 281 | (let lp ((exps exps)) |
| 282 | (cond ((null? (cdr exps)) |
| 283 | (comp-tail (car exps)) |
| 284 | (push-label! L1) |
| 285 | (maybe-return)) |
| 286 | (else |
| 287 | (comp-push (car exps)) |
| 288 | (if (not drop) |
| 289 | (push-call! #f 'dup '())) |
| 290 | (push-branch! #f 'br-if L1) |
| 291 | (if (not drop) |
| 292 | (push-call! #f 'drop '())) |
| 293 | (lp (cdr exps))))))))) |
| 294 | |
| 295 | ((<ghil-begin> env loc exps) |
| 296 | ;; EXPS... |
| 297 | ;; TAIL |
| 298 | (if (null? exps) |
| 299 | (return-void!) |
| 300 | (do ((exps exps (cdr exps))) |
| 301 | ((null? (cdr exps)) |
| 302 | (comp-tail (car exps))) |
| 303 | (comp-drop (car exps))))) |
| 304 | |
| 305 | ((<ghil-bind> env loc vars vals body) |
| 306 | ;; VALS... |
| 307 | ;; (set VARS)... |
| 308 | ;; BODY |
| 309 | (for-each comp-push vals) |
| 310 | (push-bindings! loc vars) |
| 311 | (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) |
| 312 | (reverse vars)) |
| 313 | (comp-tail body) |
| 314 | (push-code! #f (make-glil-unbind))) |
| 315 | |
| 316 | ((<ghil-mv-bind> env loc producer vars rest body) |
| 317 | ;; VALS... |
| 318 | ;; (set VARS)... |
| 319 | ;; BODY |
| 320 | (let ((MV (make-label))) |
| 321 | (comp-push producer) |
| 322 | (push-code! loc (make-glil-mv-call 0 MV)) |
| 323 | (push-code! #f (make-glil-const #:obj 1)) |
| 324 | (push-label! MV) |
| 325 | (push-code! #f (make-glil-mv-bind (map var->binding vars) rest)) |
| 326 | (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var))) |
| 327 | (reverse vars))) |
| 328 | (comp-tail body) |
| 329 | (push-code! #f (make-glil-unbind))) |
| 330 | |
| 331 | ((<ghil-lambda> env loc vars rest meta body) |
| 332 | (return-code! loc (codegen tree))) |
| 333 | |
| 334 | ((<ghil-inline> env loc inline args) |
| 335 | ;; ARGS... |
| 336 | ;; (INST NARGS) |
| 337 | (let ((tail-table '((call . goto/args) |
| 338 | (apply . goto/apply) |
| 339 | (call/cc . goto/cc)))) |
| 340 | (cond ((and tail (assq-ref tail-table inline)) |
| 341 | => (lambda (tail-inst) |
| 342 | (push-call! loc tail-inst args))) |
| 343 | (else |
| 344 | (push-call! loc inline args) |
| 345 | (maybe-drop) |
| 346 | (maybe-return))))) |
| 347 | |
| 348 | ((<ghil-values> env loc values) |
| 349 | (cond (tail ;; (lambda () (values 1 2)) |
| 350 | (push-call! loc 'return/values values)) |
| 351 | (drop ;; (lambda () (values 1 2) 3) |
| 352 | (for-each comp-drop values)) |
| 353 | (else ;; (lambda () (list (values 10 12) 1)) |
| 354 | (push-code! #f (make-glil-const #:obj 'values)) |
| 355 | (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1)) |
| 356 | (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0)) |
| 357 | (push-call! loc 'call values)))) |
| 358 | |
| 359 | ((<ghil-values*> env loc values) |
| 360 | (cond (tail ;; (lambda () (apply values '(1 2))) |
| 361 | (push-call! loc 'return/values* values)) |
| 362 | (drop ;; (lambda () (apply values '(1 2)) 3) |
| 363 | (for-each comp-drop values)) |
| 364 | (else ;; (lambda () (list (apply values '(10 12)) 1)) |
| 365 | (push-code! #f (make-glil-const #:obj 'values)) |
| 366 | (push-code! #f (make-glil-call #:inst 'link-now #:nargs 1)) |
| 367 | (push-code! #f (make-glil-call #:inst 'variable-ref #:nargs 0)) |
| 368 | (push-call! loc 'apply values)))) |
| 369 | |
| 370 | ((<ghil-call> env loc proc args) |
| 371 | ;; PROC |
| 372 | ;; ARGS... |
| 373 | ;; ([tail-]call NARGS) |
| 374 | (comp-push proc) |
| 375 | (push-call! loc (if tail 'goto/args 'call) args) |
| 376 | (maybe-drop)) |
| 377 | |
| 378 | ((<ghil-mv-call> env loc producer consumer) |
| 379 | ;; CONSUMER |
| 380 | ;; PRODUCER |
| 381 | ;; (mv-call MV) |
| 382 | ;; ([tail]-call 1) |
| 383 | ;; goto POST |
| 384 | ;; MV: [tail-]call/nargs |
| 385 | ;; POST: (maybe-drop) |
| 386 | (let ((MV (make-label)) (POST (make-label))) |
| 387 | (comp-push consumer) |
| 388 | (comp-push producer) |
| 389 | (push-code! loc (make-glil-mv-call 0 MV)) |
| 390 | (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1)) |
| 391 | (cond ((not tail) |
| 392 | (push-branch! #f 'br POST))) |
| 393 | (push-label! MV) |
| 394 | (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0)) |
| 395 | (cond ((not tail) |
| 396 | (push-label! POST) |
| 397 | (maybe-drop))))))) |
| 398 | ;; |
| 399 | ;; main |
| 400 | (record-case ghil |
| 401 | ((<ghil-lambda> env loc vars rest meta body) |
| 402 | (let* ((evars (ghil-env-variables env)) |
| 403 | (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) |
| 404 | (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))) |
| 405 | ;; initialize variable indexes |
| 406 | (finalize-index! vars) |
| 407 | (finalize-index! locs) |
| 408 | (finalize-index! exts) |
| 409 | ;; meta bindings |
| 410 | (push-bindings! #f vars) |
| 411 | ;; export arguments |
| 412 | (do ((n 0 (1+ n)) |
| 413 | (l vars (cdr l))) |
| 414 | ((null? l)) |
| 415 | (let ((v (car l))) |
| 416 | (case (ghil-var-kind v) |
| 417 | ((external) |
| 418 | (push-code! #f (make-glil-argument 'ref n)) |
| 419 | (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) |
| 420 | ;; compile body |
| 421 | (comp body #t #f) |
| 422 | ;; create GLIL |
| 423 | (let ((vars (make-glil-vars #:nargs (length vars) |
| 424 | #:nrest (if rest 1 0) |
| 425 | #:nlocs (length locs) |
| 426 | #:nexts (length exts)))) |
| 427 | (make-glil-asm vars meta (reverse! stack)))))))) |
| 428 | |
| 429 | (define (finalize-index! list) |
| 430 | (do ((n 0 (1+ n)) |
| 431 | (l list (cdr l))) |
| 432 | ((null? l)) |
| 433 | (let ((v (car l))) (set! (ghil-var-index v) n)))) |