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 ;; call-with-values -> mv-bind
  34 ;; compile-time-environment
  35 ;; GOOPS' @slot-ref, @slot-set
  36 ;; basic degenerate-case reduction
  37
  38 ;; allocation:
  39 ;;  sym -> (local . index) | (heap level . index)
  40 ;;  lambda -> (nlocs . nexts)
  41
  42 (define *comp-module* (make-fluid))
  43
  44 (define (compile-glil x e opts)
  45   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
  46          (x (optimize! x e opts))
  47          (allocation (analyze-lexicals x)))
  48     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
  49       (lambda ()
  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 in))))
 136                   (case (car loc)
 137                     ((heap)
 138                      (emit-code #f (make-glil-local 'ref n))
 139                      (emit-code #f (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        ;; FIXME: need a better pattern-matcher here
 182        (cond
 183         ((and (primitive-ref? proc)
 184               (eq? (primitive-ref-name proc) '@apply)
 185               (>= (length args) 2))
 186          (let ((proc (car args))
 187                (args (cdr args)))
 188            (cond
 189             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 190                   (not (eq? context 'push)))
 191              ;; tail: (lambda () (apply values '(1 2)))
 192              ;; drop: (lambda () (apply values '(1 2)) 3)
 193              ;; push: (lambda () (list (apply values '(10 12)) 1))
 194              (case context
 195                ((drop) (for-each comp-drop args))
 196                ((tail)
 197                 (for-each comp-push args)
 198                 (emit-code src (make-glil-call 'return/values* (length args))))))
 199
 200             (else
 201              (comp-push proc)
 202              (for-each comp-push args)
 203              (case context
 204                ((drop) (emit-code src (make-glil-call 'apply (1+ (length args))))
 205                        (emit-code src (make-glil-call 'drop 1)))
 206                ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 207                ((push) (emit-code src (make-glil-call 'apply (1+ (length args))))))))))
 208
 209         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 210               (not (eq? context 'push)))
 211          ;; tail: (lambda () (values '(1 2)))
 212          ;; drop: (lambda () (values '(1 2)) 3)
 213          ;; push: (lambda () (list (values '(10 12)) 1))
 214          (case context
 215            ((drop) (for-each comp-drop args))
 216            ((tail)
 217             (for-each comp-push args)
 218             (emit-code src (make-glil-call 'return/values (length args))))))
 219         ((and (primitive-ref? proc)
 220               (eq? (primitive-ref-name proc) '@call-with-values)
 221               (= (length args) 2))
 222          ;; CONSUMER
 223          ;; PRODUCER
 224          ;; (mv-call MV)
 225          ;; ([tail]-call 1)
 226          ;; goto POST
 227          ;; MV: [tail-]call/nargs
 228          ;; POST: (maybe-drop)
 229          (let ((MV (make-label)) (POST (make-label))
 230                (producer (car args)) (consumer (cadr args)))
 231            (comp-push consumer)
 232            (comp-push producer)
 233            (emit-code src (make-glil-mv-call 0 MV))
 234            (case context
 235              ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 236              (else   (emit-code src (make-glil-call 'call 1))
 237                      (emit-branch #f 'br POST)))
 238            (emit-label MV)
 239            (case context
 240              ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 241              (else   (emit-code src (make-glil-call 'call/nargs 0))
 242                      (emit-label POST)
 243                      (if (eq? context 'drop)
 244                          (emit-code #f (make-glil-call 'drop 1)))))))
 245
 246         ((and (primitive-ref? proc)
 247               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 248               (= (length args 1)))
 249          (comp-push (car args))
 250          (case context
 251            ((tail) (emit-code src (make-glil-call 'goto/cc 1)))
 252            ((push) (emit-code src (make-glil-call 'call/cc 1)))
 253            ((drop) (emit-code src (make-glil-call 'call/cc 1))
 254                    (emit-code src (make-glil-call 'drop 1)))))
 255
 256         ((and (primitive-ref? proc)
 257               (hash-ref *primcall-ops*
 258                         (cons (primitive-ref-name proc) (length args))))
 259          => (lambda (op)
 260               (for-each comp-push args)
 261               (emit-code src (make-glil-call op (length args)))
 262               (case context
 263                 ((tail) (emit-code #f (make-glil-call 'return 1)))
 264                 ((drop) (emit-code #f (make-glil-call 'drop 1))))))
 265         (else
 266          (comp-push proc)
 267          (for-each comp-push args)
 268          (let ((len (length args)))
 269            (case context
 270              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 271              ((push) (emit-code src (make-glil-call 'call len)))
 272              ((drop) (emit-code src (make-glil-call 'call len))
 273                      (emit-code src (make-glil-call 'drop 1))))))))
 274
 275       ((<conditional> src test then else)
 276        ;;     TEST
 277        ;;     (br-if-not L1)
 278        ;;     THEN
 279        ;;     (br L2)
 280        ;; L1: ELSE
 281        ;; L2:
 282        (let ((L1 (make-label)) (L2 (make-label)))
 283          (comp-push test)
 284          (emit-branch src 'br-if-not L1)
 285          (comp-tail then)
 286          (if (not (eq? context 'tail))
 287              (emit-branch #f 'br L2))
 288          (emit-label L1)
 289          (comp-tail else)
 290          (if (not (eq? context 'tail))
 291              (emit-label L2))))
 292
 293       ((<primitive-ref> src name)
 294        (cond
 295         ((eq? (module-variable (fluid-ref *comp-module*) name)
 296               (module-variable the-root-module name))
 297          (case context
 298            ((push)
 299             (emit-code src (make-glil-toplevel 'ref name)))
 300            ((tail)
 301             (emit-code src (make-glil-toplevel 'ref name))
 302             (emit-code #f (make-glil-call 'return 1)))))
 303         (else
 304          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
 305          (case context
 306            ((push)
 307             (emit-code src (make-glil-module 'ref '(guile) name #f)))
 308            ((tail)
 309             (emit-code src (make-glil-module 'ref '(guile) name #f))
 310             (emit-code #f (make-glil-call 'return 1)))))))
 311
 312       ((<lexical-ref> src name gensym)
 313        (case context
 314          ((push tail)
 315           (let ((loc (hashq-ref allocation gensym)))
 316             (case (car loc)
 317               ((stack)
 318                (emit-code src (make-glil-local 'ref (cdr loc))))
 319               ((heap)
 320                (emit-code src (make-glil-external
 321                                'ref (- level (cadr loc)) (cddr loc))))
 322               (else (error "badness" x loc)))
 323             (if (eq? context 'tail)
 324                 (emit-code #f (make-glil-call 'return 1)))))))
 325
 326       ((<lexical-set> src name gensym exp)
 327        (comp-push exp)
 328        (let ((loc (hashq-ref allocation gensym)))
 329          (case (car loc)
 330            ((stack)
 331             (emit-code src (make-glil-local 'set (cdr loc))))
 332            ((heap)
 333             (emit-code src (make-glil-external
 334                             'set (- level (cadr loc)) (cddr loc))))
 335            (else (error "badness" x loc))))
 336        (case context
 337          ((push)
 338           (emit-code #f (make-glil-void)))
 339          ((tail)
 340           (emit-code #f (make-glil-void))
 341           (emit-code #f (make-glil-call 'return 1)))))
 342
 343       ((<module-ref> src mod name public?)
 344        (emit-code src (make-glil-module 'ref mod name public?))
 345        (case context
 346          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 347          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 348
 349       ((<module-set> src mod name public? exp)
 350        (comp-push exp)
 351        (emit-code src (make-glil-module 'set mod name public?))
 352        (case context
 353          ((push)
 354           (emit-code #f (make-glil-void)))
 355          ((tail)
 356           (emit-code #f (make-glil-void))
 357           (emit-code #f (make-glil-call 'return 1)))))
 358
 359       ((<toplevel-ref> src name)
 360        (emit-code src (make-glil-toplevel 'ref name))
 361        (case context
 362          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 363          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 364
 365       ((<toplevel-set> src name exp)
 366        (comp-push exp)
 367        (emit-code src (make-glil-toplevel 'set name))
 368        (case context
 369          ((push)
 370           (emit-code #f (make-glil-void)))
 371          ((tail)
 372           (emit-code #f (make-glil-void))
 373           (emit-code #f (make-glil-call 'return 1)))))
 374
 375       ((<toplevel-define> src name exp)
 376        (comp-push exp)
 377        (emit-code src (make-glil-toplevel 'define name))
 378        (case context
 379          ((push)
 380           (emit-code #f (make-glil-void)))
 381          ((tail)
 382           (emit-code #f (make-glil-void))
 383           (emit-code #f (make-glil-call 'return 1)))))
 384
 385       ((<lambda>)
 386        (case context
 387          ((push)
 388           (emit-code #f (flatten-lambda x level allocation)))
 389          ((tail)
 390           (emit-code #f (flatten-lambda x level allocation))
 391           (emit-code #f (make-glil-call 'return 1)))))
 392
 393       ((<let> src names vars vals exp)
 394        (for-each comp-push vals)
 395        (emit-bindings src names vars allocation emit-code)
 396        (for-each (lambda (v)
 397                    (let ((loc (hashq-ref allocation v)))
 398                      (case (car loc)
 399                        ((stack)
 400                         (emit-code src (make-glil-local 'set (cdr loc))))
 401                        ((heap)
 402                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 403                        (else (error "badness" x loc)))))
 404                  (reverse vars))
 405        (comp-tail exp)
 406        (emit-code #f (make-glil-unbind)))
 407
 408       ((<letrec> src names vars vals exp)
 409        (for-each comp-push vals)
 410        (emit-bindings src names vars allocation emit-code)
 411        (for-each (lambda (v)
 412                    (let ((loc (hashq-ref allocation v)))
 413                      (case (car loc)
 414                        ((stack)
 415                         (emit-code src (make-glil-local 'set (cdr loc))))
 416                        ((heap)
 417                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 418                        (else (error "badness" x loc)))))
 419                  (reverse vars))
 420        (comp-tail exp)
 421        (emit-code #f (make-glil-unbind))))))