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 (optimize x)
  39   (record-case x
  40     ((<ghil-set> env loc var val)
  41      (make-ghil-set env var (optimize val)))
  42
  43     ((<ghil-if> env loc test then else)
  44      (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
  45
  46     ((<ghil-begin> env loc exps)
  47      (make-ghil-begin env loc (map optimize exps)))
  48
  49     ((<ghil-bind> env loc vars vals body)
  50      (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
  51
  52     ((<ghil-lambda> env loc vars rest meta body)
  53      (make-ghil-lambda env loc vars rest meta (optimize body)))
  54
  55     ((<ghil-inline> env loc instruction args)
  56      (make-ghil-inline env loc instruction (map optimize args)))
  57
  58     ((<ghil-call> env loc proc args)
  59      (let ((parent-env env))
  60        (record-case proc
  61          ;; ((@lambda (VAR...) BODY...) ARG...) =>
  62          ;;   (@let ((VAR ARG) ...) BODY...)
  63          ((<ghil-lambda> env loc vars rest meta body)
  64           (cond
  65            ((not rest)
  66             (for-each (lambda (v)
  67                         (case (ghil-var-kind v)
  68                           ((argument) (set! (ghil-var-kind v) 'local)))
  69                         (set! (ghil-var-env v) parent-env)
  70                         (ghil-env-add! parent-env v))
  71                       (ghil-env-variables env)))
  72            (else
  73             (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
  74          (else
  75           (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
  76
  77     (else x)))
  78
  79 \f
  80 ;;;
  81 ;;; Stage 3: Code generation
  82 ;;;
  83
  84 (define *ia-void* (make-glil-void))
  85 (define *ia-drop* (make-glil-call 'drop 0))
  86 (define *ia-return* (make-glil-call 'return 0))
  87
  88 (define (make-label) (gensym ":L"))
  89
  90 (define (make-glil-var op env var)
  91   (case (ghil-var-kind var)
  92     ((argument)
  93      (make-glil-argument op (ghil-var-index var)))
  94     ((local)
  95      (make-glil-local op (ghil-var-index var)))
  96     ((external)
  97      (do ((depth 0 (1+ depth))
  98           (e env (ghil-env-parent e)))
  99          ((eq? e (ghil-var-env var))
 100           (make-glil-external op depth (ghil-var-index var)))))
 101     ((module)
 102      (let ((env (ghil-var-env var)))
 103        (make-glil-module op (ghil-mod-module (ghil-env-mod env))
 104                          (ghil-var-name var))))
 105     (else (error "Unknown kind of variable:" var))))
 106
 107 (define (codegen ghil)
 108   (let ((stack '()))
 109     (define (push-code! loc code)
 110       (set! stack (cons code stack))
 111       (if loc (set! stack (cons (make-glil-source loc) stack))))
 112     (define (push-bindings! loc vars)
 113       (if (not (null? vars))
 114           (push-code!
 115            loc
 116            (make-glil-bind
 117             (map list
 118                  (map ghil-var-name vars)
 119                  (map ghil-var-kind vars)
 120                  (map ghil-var-index vars))))))
 121     (define (comp tree tail drop)
 122       (define (push-label! label)
 123         (push-code! #f (make-glil-label label)))
 124       (define (push-branch! loc inst label)
 125         (push-code! loc (make-glil-branch inst label)))
 126       (define (push-call! loc inst args)
 127         (for-each comp-push args)
 128         (push-code! loc (make-glil-call inst (length args))))
 129       ;; possible tail position
 130       (define (comp-tail tree) (comp tree tail drop))
 131       ;; push the result
 132       (define (comp-push tree) (comp tree #f #f))
 133       ;; drop the result
 134       (define (comp-drop tree) (comp tree #f #t))
 135       ;; drop the result if unnecessary
 136       (define (maybe-drop)
 137         (if drop (push-code! #f *ia-drop*)))
 138       ;; return here if necessary
 139       (define (maybe-return)
 140         (if tail (push-code! #f *ia-return*)))
 141       ;; return this code if necessary
 142       (define (return-code! loc code)
 143         (if (not drop) (push-code! loc code))
 144         (maybe-return))
 145       ;; return void if necessary
 146       (define (return-void!)
 147         (return-code! #f *ia-void*))
 148       ;; return object if necessary
 149       (define (return-object! loc obj)
 150         (return-code! loc (make-glil-const #:obj obj)))
 151       ;;
 152       ;; dispatch
 153       (record-case tree
 154         ((<ghil-void>)
 155          (return-void!))
 156
 157         ((<ghil-quote> env loc obj)
 158          (return-object! loc obj))
 159
 160         ((<ghil-quasiquote> env loc exp)
 161          (let loop ((x exp))
 162            (cond
 163             ((list? x)
 164              (push-call! #f 'mark '())
 165              (for-each loop x)
 166              (push-call! #f 'list-mark '()))
 167             ((pair? x)
 168              (loop (car x))
 169              (loop (cdr x))
 170              (push-code! #f (make-glil-call 'cons 2)))
 171             ((record? x)
 172              (record-case x
 173               ((<ghil-unquote> env loc exp)
 174                (comp-push exp))
 175               ((<ghil-unquote-splicing> env loc exp)
 176                (comp-push exp)
 177                (push-call! #f 'list-break '()))))
 178             (else
 179              (push-code! #f (make-glil-const #:obj x)))))
 180          (maybe-drop)
 181          (maybe-return))
 182
 183         ((<ghil-ref> env loc var)
 184          (return-code! loc (make-glil-var 'ref env var)))
 185
 186         ((<ghil-set> env loc var val)
 187          (comp-push val)
 188          (push-code! loc (make-glil-var 'set env var))
 189          (return-void!))
 190
 191         ((<ghil-define> env loc var val)
 192          (comp-push val)
 193          (push-code! loc (make-glil-var 'define env var))
 194          (return-void!))
 195
 196         ((<ghil-if> env loc test then else)
 197          ;;     TEST
 198          ;;     (br-if-not L1)
 199          ;;     THEN
 200          ;;     (br L2)
 201          ;; L1: ELSE
 202          ;; L2:
 203          (let ((L1 (make-label)) (L2 (make-label)))
 204            (comp-push test)
 205            (push-branch! loc 'br-if-not L1)
 206            (comp-tail then)
 207            (if (not tail) (push-branch! #f 'br L2))
 208            (push-label! L1)
 209            (comp-tail else)
 210            (if (not tail) (push-label! L2))))
 211
 212         ((<ghil-and> env loc exps)
 213          ;;     EXP
 214          ;;     (br-if-not L1)
 215          ;;     ...
 216          ;;     TAIL
 217          ;;     (br L2)
 218          ;; L1: (const #f)
 219          ;; L2:
 220          (cond ((null? exps) (return-object! loc #t))
 221                ((null? (cdr exps)) (comp-tail (car exps)))
 222                (else
 223                 (let ((L1 (make-label)) (L2 (make-label)))
 224                   (let lp ((exps exps))
 225                     (cond ((null? (cdr exps))
 226                            (comp-tail (car exps))
 227                            (push-branch! #f 'br L2)
 228                            (push-label! L1)
 229                            (return-object! #f #f)
 230                            (push-label! L2)
 231                            (maybe-return))
 232                           (else
 233                            (comp-push (car exps))
 234                            (push-branch! #f 'br-if-not L1)
 235                            (lp (cdr exps)))))))))
 236
 237         ((<ghil-or> env loc exps)
 238          ;;     EXP
 239          ;;     (dup)
 240          ;;     (br-if L1)
 241          ;;     (drop)
 242          ;;     ...
 243          ;;     TAIL
 244          ;; L1:
 245          (cond ((null? exps) (return-object! loc #f))
 246                ((null? (cdr exps)) (comp-tail (car exps)))
 247                (else
 248                 (let ((L1 (make-label)))
 249                   (let lp ((exps exps))
 250                     (cond ((null? (cdr exps))
 251                            (comp-tail (car exps))
 252                            (push-label! L1)
 253                            (maybe-return))
 254                           (else
 255                            (comp-push (car exps))
 256                            (push-call! #f 'dup '())
 257                            (push-branch! #f 'br-if L1)
 258                            (push-call! #f 'drop '())
 259                            (lp (cdr exps)))))))))
 260
 261         ((<ghil-begin> env loc exps)
 262          ;; EXPS...
 263          ;; TAIL
 264          (if (null? exps)
 265              (return-void!)
 266              (do ((exps exps (cdr exps)))
 267                  ((null? (cdr exps))
 268                   (comp-tail (car exps)))
 269                (comp-drop (car exps)))))
 270
 271         ((<ghil-bind> env loc vars vals body)
 272          ;; VALS...
 273          ;; (set VARS)...
 274          ;; BODY
 275          (for-each comp-push vals)
 276          (push-bindings! loc vars)
 277          (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
 278                    (reverse vars))
 279          (comp-tail body)
 280          (push-code! #f (make-glil-unbind)))
 281
 282         ((<ghil-lambda> env loc vars rest meta body)
 283          (return-code! loc (codegen tree)))
 284
 285         ((<ghil-inline> env loc inline args)
 286          ;; ARGS...
 287          ;; (INST NARGS)
 288          (push-call! loc inline args)
 289          (maybe-drop)
 290          (maybe-return))
 291
 292         ((<ghil-call> env loc proc args)
 293          ;; PROC
 294          ;; ARGS...
 295          ;; ([tail-]call NARGS)
 296          (comp-push proc)
 297          (push-call! loc (if tail 'tail-call 'call) args)
 298          (maybe-drop))))
 299     ;;
 300     ;; main
 301     (record-case ghil
 302       ((<ghil-lambda> env loc vars rest meta body)
 303        (let* ((evars (ghil-env-variables env))
 304               (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
 305               (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
 306          ;; initialize variable indexes
 307          (finalize-index! vars)
 308          (finalize-index! locs)
 309          (finalize-index! exts)
 310          ;; meta bindings
 311          (push-bindings! #f vars)
 312          ;; export arguments
 313          (do ((n 0 (1+ n))
 314               (l vars (cdr l)))
 315              ((null? l))
 316            (let ((v (car l)))
 317              (case (ghil-var-kind v)
 318                ((external)
 319                 (push-code! #f (make-glil-argument 'ref n))
 320                 (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
 321          ;; compile body
 322          (comp body #t #f)
 323          ;; create GLIL
 324          (let ((vars (make-glil-vars :nargs (length vars)
 325                                      :nrest (if rest 1 0)
 326                                      :nlocs (length locs)
 327                                      :nexts (length exts))))
 328            (make-glil-asm vars meta (reverse! stack))))))))
 329
 330 (define (finalize-index! list)
 331   (do ((n 0 (1+ n))
 332        (l list (cdr l)))
 333       ((null? l))
 334     (let ((v (car l))) (set! (ghil-var-index v) n))))