module/language/tree-il/compile-glil.scm

   1 ;;; TREE-IL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001,2008,2009 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 (language tree-il compile-glil)
  23   #:use-module (system base syntax)
  24   #:use-module (ice-9 receive)
  25   #:use-module (language glil)
  26   #:use-module (language tree-il)
  27   #:use-module (language tree-il optimize)
  28   #:use-module (language tree-il analyze)
  29   #:export (compile-glil))
  30
  31 ;;; TODO:
  32 ;;
  33 ;; * ([@]apply f args) -> goto/apply or similar
  34 ;; * ([@]apply values args) -> goto/values or similar
  35 ;; * ([@]call-with-values prod cons) ...
  36 ;; * ([@]call-with-current-continuation prod cons) ...
  37 ;; call-with-values -> mv-bind
  38 ;; compile-time-environment
  39 ;; GOOPS' @slot-ref, @slot-set
  40 ;; basic degenerate-case reduction
  41
  42 ;; allocation:
  43 ;;  sym -> (local . index) | (heap level . index)
  44 ;;  lambda -> (nlocs . nexts)
  45
  46 (define (compile-glil x e opts)
  47   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
  48          (x (optimize! x e opts))
  49          (allocation (analyze-lexicals x)))
  50     (values (flatten-lambda x -1 allocation)
  51             (and e (cons (car e) (cddr e)))
  52             e)))
  53
  54 \f
  55
  56 (define *primcall-ops* (make-hash-table))
  57 (for-each
  58  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
  59  '(((eq? . 2) . eq?)
  60    ((eqv? . 2) . eqv?)
  61    ((equal? . 2) . equal?)
  62    ((= . 2) . ee?)
  63    ((< . 2) . lt?)
  64    ((> . 2) . gt?)
  65    ((<= . 2) . le?)
  66    ((>= . 2) . ge?)
  67    ((+ . 2) . add)
  68    ((- . 2) . sub)
  69    ((* . 2) . mul)
  70    ((/ . 2) . div)
  71    ((quotient . 2) . quo)
  72    ((remainder . 2) . rem)
  73    ((modulo . 2) . mod)
  74    ((not . 1) . not)
  75    ((pair? . 1) . pair?)
  76    ((cons . 2) . cons)
  77    ((car . 1) . car)
  78    ((cdr . 1) . cdr)
  79    ((set-car! . 2) . set-car!)
  80    ((set-cdr! . 2) . set-cdr!)
  81    ((null? . 1) . null?)
  82    ((list? . 1) . list?)))
  83
  84 (define (make-label) (gensym ":L"))
  85
  86 (define (vars->bind-list ids vars allocation)
  87   (map (lambda (id v)
  88          (let ((loc (hashq-ref allocation v)))
  89            (case (car loc)
  90              ((stack) (list id 'local (cdr loc)))
  91              ((heap)  (list id 'external (cddr loc)))
  92              (else (error "badness" id v loc)))))
  93        ids
  94        vars))
  95
  96 (define (emit-bindings src ids vars allocation emit-code)
  97   (if (pair? vars)
  98       (emit-code src (make-glil-bind
  99                       (vars->bind-list ids vars allocation)))))
 100
 101 (define (with-output-to-code proc)
 102   (let ((out '()))
 103     (define (emit-code src x)
 104       (set! out (cons x out))
 105       (if src
 106           (set! out (cons (make-glil-source src) out))))
 107     (proc emit-code)
 108     (reverse out)))
 109
 110 (define (flatten-lambda x level allocation)
 111   (receive (ids vars nargs nrest)
 112       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
 113                (oids '()) (ovars '()) (n 0))
 114           (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
 115                 ((pair? vars) (lp (cdr ids) (cdr vars)
 116                                   (cons (car ids) oids) (cons (car vars) ovars)
 117                                   (1+ n)))
 118                 (else (values (reverse (cons ids oids))
 119                               (reverse (cons vars ovars))
 120                               (1+ n) 1))))
 121     (let ((nlocs (car (hashq-ref allocation x)))
 122           (nexts (cdr (hashq-ref allocation x))))
 123       (make-glil-program
 124        nargs nrest nlocs nexts (lambda-meta x)
 125        (with-output-to-code
 126         (lambda (emit-code)
 127           ;; write bindings and source debugging info
 128           (emit-bindings #f ids vars allocation emit-code)
 129           (if (lambda-src x)
 130               (emit-code (make-glil-src (lambda-src x))))
 131
 132           ;; copy args to the heap if necessary
 133           (let lp ((in vars) (n 0))
 134             (if (not (null? in))
 135                 (let ((loc (hashq-ref allocation (car vars))))
 136                   (case (car loc)
 137                     ((heap)
 138                      (emit-code (make-glil-argument 'ref n))
 139                      (emit-code (make-glil-external 'set 0 (cddr loc)))))
 140                   (lp (cdr in) (1+ n)))))
 141
 142           ;; and here, here, dear reader: we compile.
 143           (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
 144
 145 (define (flatten x level allocation emit-code)
 146   (define (emit-label label)
 147     (emit-code #f (make-glil-label label)))
 148   (define (emit-branch src inst label)
 149     (emit-code src (make-glil-branch inst label)))
 150
 151   (let comp ((x x) (context 'tail))
 152     (define (comp-tail tree) (comp tree context))
 153     (define (comp-push tree) (comp tree 'push))
 154     (define (comp-drop tree) (comp tree 'drop))
 155
 156     (record-case x
 157       ((<void>)
 158        (case context
 159          ((push) (emit-code #f (make-glil-void)))
 160          ((tail)
 161           (emit-code #f (make-glil-void))
 162           (emit-code #f (make-glil-call 'return 1)))))
 163
 164       ((<const> src exp)
 165        (case context
 166          ((push) (emit-code src (make-glil-const exp)))
 167          ((tail)
 168           (emit-code src (make-glil-const exp))
 169           (emit-code #f (make-glil-call 'return 1)))))
 170
 171       ;; FIXME: should represent sequence as exps tail
 172       ((<sequence> src exps)
 173        (let lp ((exps exps))
 174          (if (null? (cdr exps))
 175              (comp-tail (car exps))
 176              (begin
 177                (comp-drop (car exps))
 178                (lp (cdr exps))))))
 179
 180       ((<application> src proc args)
 181        (cond
 182         ((and (primitive-ref? proc)
 183               (hash-ref *primcall-ops*
 184                         (cons (primitive-ref-name proc) (length args))))
 185          => (lambda (op)
 186               (for-each comp-push args)
 187               (emit-code src (make-glil-call op (length args)))
 188               (case context
 189                 ((tail) (emit-code #f (make-glil-call 'return 1)))
 190                 ((drop) (emit-code #f (make-glil-call 'drop 1))))))
 191         (else
 192          (comp-push proc)
 193          (for-each comp-push args)
 194          (emit-code src (make-glil-call (case context
 195                                           ((tail) 'goto/args)
 196                                           (else 'call))
 197                                         (length args))))))
 198
 199       ((<conditional> src test then else)
 200        ;;     TEST
 201        ;;     (br-if-not L1)
 202        ;;     THEN
 203        ;;     (br L2)
 204        ;; L1: ELSE
 205        ;; L2:
 206        (let ((L1 (make-label)) (L2 (make-label)))
 207          (comp-push test)
 208          (emit-branch src 'br-if-not L1)
 209          (comp-tail then)
 210          (if (not (eq? context 'tail))
 211              (emit-branch #f 'br L2))
 212          (emit-label L1)
 213          (comp-tail else)
 214          (if (not (eq? context 'tail))
 215              (emit-label L2))))
 216
 217       ((<primitive-ref> src name)
 218        (case context
 219          ((push)
 220           (emit-code src (make-glil-module 'ref '(guile) name #f)))
 221          ((tail)
 222           (emit-code src (make-glil-module 'ref '(guile) name #f))
 223           (emit-code #f (make-glil-call 'return 1)))))
 224
 225       ((<lexical-ref> src name gensym)
 226        (case context
 227          ((push tail)
 228           (let ((loc (hashq-ref allocation gensym)))
 229             (case (car loc)
 230               ((stack)
 231                (emit-code src (make-glil-local 'ref (cdr loc))))
 232               ((heap)
 233                (emit-code src (make-glil-external
 234                                'ref (- level (cadr loc)) (cddr loc))))
 235               (else (error "badness" x loc)))
 236             (if (eq? context 'tail)
 237                 (emit-code #f (make-glil-call 'return 1)))))))
 238
 239       ((<lexical-set> src name gensym exp)
 240        (comp-push exp)
 241        (let ((loc (hashq-ref allocation gensym)))
 242          (case (car loc)
 243            ((stack)
 244             (emit-code src (make-glil-local 'set (cdr loc))))
 245            ((heap)
 246             (emit-code src (make-glil-external
 247                             'set (- level (cadr loc)) (cddr loc))))
 248            (else (error "badness" x loc))))
 249        (case context
 250          ((push)
 251           (emit-code #f (make-glil-void)))
 252          ((tail)
 253           (emit-code #f (make-glil-void))
 254           (emit-code #f (make-glil-call 'return 1)))))
 255
 256       ((<module-ref> src mod name public?)
 257        (emit-code src (make-glil-module 'ref mod name public?))
 258        (case context
 259          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 260          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 261
 262       ((<module-set> src mod name public? exp)
 263        (comp-push exp)
 264        (emit-code src (make-glil-module 'set mod name public?))
 265        (case context
 266          ((push)
 267           (emit-code #f (make-glil-void)))
 268          ((tail)
 269           (emit-code #f (make-glil-void))
 270           (emit-code #f (make-glil-call 'return 1)))))
 271
 272       ((<toplevel-ref> src name)
 273        (emit-code src (make-glil-toplevel 'ref name))
 274        (case context
 275          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 276          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 277
 278       ((<toplevel-set> src name exp)
 279        (comp-push exp)
 280        (emit-code src (make-glil-toplevel 'set name))
 281        (case context
 282          ((push)
 283           (emit-code #f (make-glil-void)))
 284          ((tail)
 285           (emit-code #f (make-glil-void))
 286           (emit-code #f (make-glil-call 'return 1)))))
 287
 288       ((<toplevel-define> src name exp)
 289        (comp-push exp)
 290        (emit-code src (make-glil-toplevel 'define name))
 291        (case context
 292          ((push)
 293           (emit-code #f (make-glil-void)))
 294          ((tail)
 295           (emit-code #f (make-glil-void))
 296           (emit-code #f (make-glil-call 'return 1)))))
 297
 298       ((<lambda>)
 299        (case context
 300          ((push)
 301           (emit-code #f (flatten-lambda x level allocation)))
 302          ((tail)
 303           (emit-code #f (flatten-lambda x level allocation))
 304           (emit-code #f (make-glil-call 'return 1)))))
 305
 306       ((<let> src names vars vals exp)
 307        (for-each comp-push vals)
 308        (emit-bindings src names vars allocation emit-code)
 309        (for-each (lambda (v)
 310                    (let ((loc (hashq-ref allocation v)))
 311                      (case (car loc)
 312                        ((stack)
 313                         (emit-code src (make-glil-local 'set (cdr loc))))
 314                        ((heap)
 315                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 316                        (else (error "badness" x loc)))))
 317                  (reverse vars))
 318        (comp-tail exp)
 319        (emit-code #f (make-glil-unbind)))
 320
 321       ((<letrec> src names vars vals exp)
 322        (for-each comp-push vals)
 323        (emit-bindings src names vars allocation emit-code)
 324        (for-each (lambda (v)
 325                    (let ((loc (hashq-ref allocation v)))
 326                      (case (car loc)
 327                        ((stack)
 328                         (emit-code src (make-glil-local 'set (cdr loc))))
 329                        ((heap)
 330                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 331                        (else (error "badness" x loc)))))
 332                  (reverse vars))
 333        (comp-tail exp)
 334        (emit-code #f (make-glil-unbind))))))