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