module/system/il/compile.scm

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