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-module (oop goops)
  24   :use-syntax (system base syntax)
  25   :use-module (system il glil)
  26   :use-module (system il ghil)
  27   :use-module (ice-9 common-list)
  28   :export (compile))
  29
  30 (define (compile x e . opts)
  31   (set! x (parse-ghil x e))
  32   (if (memq :O opts) (set! x (optimize x)))
  33   (codegen x))
  34
  35 \f
  36 ;;;
  37 ;;; Stage 2: Optimization
  38 ;;;
  39
  40 (define (optimize x)
  41   (match x
  42     (($ <ghil-set> env var val)
  43      (make-<ghil-set> env var (optimize val)))
  44
  45     (($ <ghil-if> test then else)
  46      (make-<ghil-if> (optimize test) (optimize then) (optimize else)))
  47
  48     (($ <ghil-begin> exps)
  49      (make-<ghil-begin> (map optimize exps)))
  50
  51     (($ <ghil-bind> env vars vals body)
  52      (make-<ghil-bind> env vars (map optimize vals) (optimize body)))
  53
  54     (($ <ghil-lambda> env vars rest body)
  55      (make-<ghil-lambda> env vars rest (optimize body)))
  56
  57     (($ <ghil-inst> inst args)
  58      (make-<ghil-inst> inst (map optimize args)))
  59
  60     (($ <ghil-call> env proc args)
  61      (match proc
  62        ;; ((@lambda (VAR...) BODY...) ARG...) =>
  63        ;;   (@let ((VAR ARG) ...) BODY...)
  64        (($ <ghil-lambda> lambda-env vars #f body)
  65         (for-each (lambda (v)
  66                     (if (eq? v.kind 'argument) (set! v.kind 'local))
  67                     (set! v.env env)
  68                     (ghil-env-add! env v))
  69                   lambda-env.variables)
  70         (optimize (make-<ghil-bind> env vars args body)))
  71        (else
  72         (make-<ghil-call> env (optimize proc) (map optimize args)))))
  73     (else x)))
  74
  75 \f
  76 ;;;
  77 ;;; Stage 3: Code generation
  78 ;;;
  79
  80 (define *ia-void* (make-<glil-void>))
  81 (define *ia-drop* (make-<glil-call> 'drop 0))
  82 (define *ia-return* (make-<glil-call> 'return 0))
  83
  84 (define (make-label) (gensym ":L"))
  85
  86 (define (make-glil-var op env var)
  87   (case var.kind
  88     ((argument)
  89      (make-<glil-argument> op var.index))
  90     ((local)
  91      (make-<glil-local> op var.index))
  92     ((external)
  93      (do ((depth 0 (1+ depth))
  94           (e env e.parent))
  95          ((eq? e var.env)
  96           (make-<glil-external> op depth var.index))))
  97     ((module)
  98      (make-<glil-module> op var.env var.name))
  99     (else (error "Unknown kind of variable:" var))))
 100
 101 (define (codegen ghil)
 102   (let ((stack '()))
 103     (define (push-code! code)
 104       (set! stack (cons code stack)))
 105     (define (comp tree tail drop)
 106       ;; possible tail position
 107       (define (comp-tail tree) (comp tree tail drop))
 108       ;; push the result
 109       (define (comp-push tree) (comp tree #f #f))
 110       ;; drop the result
 111       (define (comp-drop tree) (comp tree #f #t))
 112       ;; return this code if necessary
 113       (define (return-code! code)
 114         (if (not drop) (push-code! code))
 115         (if tail (push-code! *ia-return*)))
 116       ;; return void if necessary
 117       (define (return-void!) (return-code! *ia-void*))
 118       ;;
 119       ;; dispatch
 120       (match tree
 121         (($ <ghil-void>)
 122          (return-void!))
 123
 124         (($ <ghil-quote> obj)
 125          (return-code! (make-<glil-const> obj)))
 126
 127         (($ <ghil-ref> env var)
 128          (return-code! (make-glil-var 'ref env var)))
 129
 130         (($ <ghil-set> env var val)
 131          (comp-push val)
 132          (push-code! (make-glil-var 'set env var))
 133          (return-void!))
 134
 135         (($ <ghil-if> test then else)
 136          ;;     TEST
 137          ;;     (br-if-not L1)
 138          ;;     THEN
 139          ;;     (br L2)
 140          ;; L1: ELSE
 141          ;; L2:
 142          (let ((L1 (make-label)) (L2 (make-label)))
 143            (comp-push test)
 144            (push-code! (make-<glil-branch> 'br-if-not L1))
 145            (comp-tail then)
 146            (if (not tail) (push-code! (make-<glil-branch> 'br L2)))
 147            (push-code! (make-<glil-label> L1))
 148            (comp-tail else)
 149            (if (not tail) (push-code! (make-<glil-label> L2)))))
 150
 151         (($ <ghil-begin> exps)
 152          ;; EXPS...
 153          ;; TAIL
 154          (if (null? exps)
 155              (return-void!)
 156              (do ((exps exps (cdr exps)))
 157                  ((null? (cdr exps))
 158                   (comp-tail (car exps)))
 159                (comp-drop (car exps)))))
 160
 161         (($ <ghil-bind> env vars vals body)
 162          ;; VALS...
 163          ;; (set VARS)...
 164          ;; BODY
 165          (for-each comp-push vals)
 166          (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
 167                    (reverse vars))
 168          (comp-tail body))
 169
 170         (($ <ghil-lambda> env vars rest body)
 171          (return-code! (codegen tree)))
 172
 173         (($ <ghil-inst> inst args)
 174          ;; ARGS...
 175          ;; (INST NARGS)
 176          (for-each comp-push args)
 177          (push-code! (make-<glil-call> inst (length args)))
 178          (if drop (push-code! *ia-drop*))
 179          (if tail (push-code! *ia-return*)))
 180
 181         (($ <ghil-call> env proc args)
 182          ;; PROC
 183          ;; ARGS...
 184          ;; ([tail-]call NARGS)
 185          (comp-push proc)
 186          (for-each comp-push args)
 187          (let ((inst (if tail 'tail-call 'call)))
 188            (push-code! (make-<glil-call> inst (length args))))
 189          (if drop (push-code! *ia-drop*)))))
 190     ;;
 191     ;; main
 192     (match ghil
 193       (($ <ghil-lambda> env args rest body)
 194        (let* ((vars env.variables)
 195               (locs (pick (lambda (v) (eq? v.kind 'local)) vars))
 196               (exts (pick (lambda (v) (eq? v.kind 'external)) vars)))
 197          ;; initialize variable indexes
 198          (finalize-index! args)
 199          (finalize-index! locs)
 200          (finalize-index! exts)
 201          ;; export arguments
 202          (do ((n 0 (1+ n)) (l args (cdr l)))
 203              ((null? l))
 204            (let ((v (car l)))
 205              (if (eq? v.kind 'external)
 206                  (begin (push-code! (make-<glil-argument> 'ref n))
 207                         (push-code! (make-<glil-external> 'set 0 v.index))))))
 208          ;; compile body
 209          (comp body #t #f)
 210          ;; create GLIL
 211          (make-<glil-asm> (length args) (if rest 1 0) (length locs)
 212                           (length exts) (reverse! stack)))))))
 213
 214 (define (finalize-index! list)
 215   (do ((n 0 (1+ n))
 216        (l list (cdr l)))
 217       ((null? l))
 218     (let ((v (car l))) (set! v.index n))))