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 ;; basic degenerate-case reduction
  35
  36 ;; allocation:
  37 ;;  sym -> (local . index) | (heap level . index)
  38 ;;  lambda -> (nlocs . nexts)
  39
  40 (define *comp-module* (make-fluid))
  41
  42 (define (compile-glil x e opts)
  43   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
  44          (x (optimize! x e opts))
  45          (allocation (analyze-lexicals x)))
  46     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
  47       (lambda ()
  48         (values (flatten-lambda x -1 allocation)
  49                 (and e (cons (car e) (cddr e)))
  50                 e)))))
  51
  52 \f
  53
  54 (define *primcall-ops* (make-hash-table))
  55 (for-each
  56  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
  57  '(((eq? . 2) . eq?)
  58    ((eqv? . 2) . eqv?)
  59    ((equal? . 2) . equal?)
  60    ((= . 2) . ee?)
  61    ((< . 2) . lt?)
  62    ((> . 2) . gt?)
  63    ((<= . 2) . le?)
  64    ((>= . 2) . ge?)
  65    ((+ . 2) . add)
  66    ((- . 2) . sub)
  67    ((* . 2) . mul)
  68    ((/ . 2) . div)
  69    ((quotient . 2) . quo)
  70    ((remainder . 2) . rem)
  71    ((modulo . 2) . mod)
  72    ((not . 1) . not)
  73    ((pair? . 1) . pair?)
  74    ((cons . 2) . cons)
  75    ((car . 1) . car)
  76    ((cdr . 1) . cdr)
  77    ((set-car! . 2) . set-car!)
  78    ((set-cdr! . 2) . set-cdr!)
  79    ((null? . 1) . null?)
  80    ((list? . 1) . list?)
  81    (list . list)
  82    (vector . vector)
  83    ((@slot-ref . 2) . slot-ref)
  84    ((@slot-set! . 3) . slot-set)))
  85
  86 (define (make-label) (gensym ":L"))
  87
  88 (define (vars->bind-list ids vars allocation)
  89   (map (lambda (id v)
  90          (let ((loc (hashq-ref allocation v)))
  91            (case (car loc)
  92              ((stack) (list id 'local (cdr loc)))
  93              ((heap)  (list id 'external (cddr loc)))
  94              (else (error "badness" id v loc)))))
  95        ids
  96        vars))
  97
  98 (define (emit-bindings src ids vars allocation emit-code)
  99   (if (pair? vars)
 100       (emit-code src (make-glil-bind
 101                       (vars->bind-list ids vars allocation)))))
 102
 103 (define (with-output-to-code proc)
 104   (let ((out '()))
 105     (define (emit-code src x)
 106       (set! out (cons x out))
 107       (if src
 108           (set! out (cons (make-glil-source src) out))))
 109     (proc emit-code)
 110     (reverse out)))
 111
 112 (define (flatten-lambda x level allocation)
 113   (receive (ids vars nargs nrest)
 114       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
 115                (oids '()) (ovars '()) (n 0))
 116           (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
 117                 ((pair? vars) (lp (cdr ids) (cdr vars)
 118                                   (cons (car ids) oids) (cons (car vars) ovars)
 119                                   (1+ n)))
 120                 (else (values (reverse (cons ids oids))
 121                               (reverse (cons vars ovars))
 122                               (1+ n) 1))))
 123     (let ((nlocs (car (hashq-ref allocation x)))
 124           (nexts (cdr (hashq-ref allocation x))))
 125       (make-glil-program
 126        nargs nrest nlocs nexts (lambda-meta x)
 127        (with-output-to-code
 128         (lambda (emit-code)
 129           ;; write bindings and source debugging info
 130           (emit-bindings #f ids vars allocation emit-code)
 131           (if (lambda-src x)
 132               (emit-code (make-glil-src (lambda-src x))))
 133
 134           ;; copy args to the heap if necessary
 135           (let lp ((in vars) (n 0))
 136             (if (not (null? in))
 137                 (let ((loc (hashq-ref allocation (car in))))
 138                   (case (car loc)
 139                     ((heap)
 140                      (emit-code #f (make-glil-local 'ref n))
 141                      (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
 142                   (lp (cdr in) (1+ n)))))
 143
 144           ;; and here, here, dear reader: we compile.
 145           (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
 146
 147 (define (flatten x level allocation emit-code)
 148   (define (emit-label label)
 149     (emit-code #f (make-glil-label label)))
 150   (define (emit-branch src inst label)
 151     (emit-code src (make-glil-branch inst label)))
 152
 153   (let comp ((x x) (context 'tail))
 154     (define (comp-tail tree) (comp tree context))
 155     (define (comp-push tree) (comp tree 'push))
 156     (define (comp-drop tree) (comp tree 'drop))
 157
 158     (record-case x
 159       ((<void>)
 160        (case context
 161          ((push) (emit-code #f (make-glil-void)))
 162          ((tail)
 163           (emit-code #f (make-glil-void))
 164           (emit-code #f (make-glil-call 'return 1)))))
 165
 166       ((<const> src exp)
 167        (case context
 168          ((push) (emit-code src (make-glil-const exp)))
 169          ((tail)
 170           (emit-code src (make-glil-const exp))
 171           (emit-code #f (make-glil-call 'return 1)))))
 172
 173       ;; FIXME: should represent sequence as exps tail
 174       ((<sequence> src exps)
 175        (let lp ((exps exps))
 176          (if (null? (cdr exps))
 177              (comp-tail (car exps))
 178              (begin
 179                (comp-drop (car exps))
 180                (lp (cdr exps))))))
 181
 182       ((<application> src proc args)
 183        ;; FIXME: need a better pattern-matcher here
 184        (cond
 185         ((and (primitive-ref? proc)
 186               (eq? (primitive-ref-name proc) '@apply)
 187               (>= (length args) 2))
 188          (let ((proc (car args))
 189                (args (cdr args)))
 190            (cond
 191             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 192                   (not (eq? context 'push)))
 193              ;; tail: (lambda () (apply values '(1 2)))
 194              ;; drop: (lambda () (apply values '(1 2)) 3)
 195              ;; push: (lambda () (list (apply values '(10 12)) 1))
 196              (case context
 197                ((drop) (for-each comp-drop args))
 198                ((tail)
 199                 (for-each comp-push args)
 200                 (emit-code src (make-glil-call 'return/values* (length args))))))
 201
 202             (else
 203              (comp-push proc)
 204              (for-each comp-push args)
 205              (case context
 206                ((drop) (emit-code src (make-glil-call 'apply (1+ (length args))))
 207                        (emit-code src (make-glil-call 'drop 1)))
 208                ((tail) (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 209                ((push) (emit-code src (make-glil-call 'apply (1+ (length args))))))))))
 210
 211         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 212               (not (eq? context 'push)))
 213          ;; tail: (lambda () (values '(1 2)))
 214          ;; drop: (lambda () (values '(1 2)) 3)
 215          ;; push: (lambda () (list (values '(10 12)) 1))
 216          (case context
 217            ((drop) (for-each comp-drop args))
 218            ((tail)
 219             (for-each comp-push args)
 220             (emit-code src (make-glil-call 'return/values (length args))))))
 221         ((and (primitive-ref? proc)
 222               (eq? (primitive-ref-name proc) '@call-with-values)
 223               (= (length args) 2))
 224          ;; CONSUMER
 225          ;; PRODUCER
 226          ;; (mv-call MV)
 227          ;; ([tail]-call 1)
 228          ;; goto POST
 229          ;; MV: [tail-]call/nargs
 230          ;; POST: (maybe-drop)
 231          (let ((MV (make-label)) (POST (make-label))
 232                (producer (car args)) (consumer (cadr args)))
 233            (comp-push consumer)
 234            (comp-push producer)
 235            (emit-code src (make-glil-mv-call 0 MV))
 236            (case context
 237              ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 238              (else   (emit-code src (make-glil-call 'call 1))
 239                      (emit-branch #f 'br POST)))
 240            (emit-label MV)
 241            (case context
 242              ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 243              (else   (emit-code src (make-glil-call 'call/nargs 0))
 244                      (emit-label POST)
 245                      (if (eq? context 'drop)
 246                          (emit-code #f (make-glil-call 'drop 1)))))))
 247
 248         ((and (primitive-ref? proc)
 249               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 250               (= (length args) 1))
 251          (comp-push (car args))
 252          (case context
 253            ((tail) (emit-code src (make-glil-call 'goto/cc 1)))
 254            ((push) (emit-code src (make-glil-call 'call/cc 1)))
 255            ((drop) (emit-code src (make-glil-call 'call/cc 1))
 256                    (emit-code src (make-glil-call 'drop 1)))))
 257
 258         ((and (primitive-ref? proc)
 259               (or (hash-ref *primcall-ops*
 260                             (cons (primitive-ref-name proc) (length args)))
 261                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 262          => (lambda (op)
 263               (for-each comp-push args)
 264               (emit-code src (make-glil-call op (length args)))
 265               (case context
 266                 ((tail) (emit-code #f (make-glil-call 'return 1)))
 267                 ((drop) (emit-code #f (make-glil-call 'drop 1))))))
 268         (else
 269          (comp-push proc)
 270          (for-each comp-push args)
 271          (let ((len (length args)))
 272            (case context
 273              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 274              ((push) (emit-code src (make-glil-call 'call len)))
 275              ((drop) (emit-code src (make-glil-call 'call len))
 276                      (emit-code src (make-glil-call 'drop 1))))))))
 277
 278       ((<conditional> src test then else)
 279        ;;     TEST
 280        ;;     (br-if-not L1)
 281        ;;     THEN
 282        ;;     (br L2)
 283        ;; L1: ELSE
 284        ;; L2:
 285        (let ((L1 (make-label)) (L2 (make-label)))
 286          (comp-push test)
 287          (emit-branch src 'br-if-not L1)
 288          (comp-tail then)
 289          (if (not (eq? context 'tail))
 290              (emit-branch #f 'br L2))
 291          (emit-label L1)
 292          (comp-tail else)
 293          (if (not (eq? context 'tail))
 294              (emit-label L2))))
 295
 296       ((<primitive-ref> src name)
 297        (cond
 298         ((eq? (module-variable (fluid-ref *comp-module*) name)
 299               (module-variable the-root-module name))
 300          (case context
 301            ((push)
 302             (emit-code src (make-glil-toplevel 'ref name)))
 303            ((tail)
 304             (emit-code src (make-glil-toplevel 'ref name))
 305             (emit-code #f (make-glil-call 'return 1)))))
 306         (else
 307          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
 308          (case context
 309            ((push)
 310             (emit-code src (make-glil-module 'ref '(guile) name #f)))
 311            ((tail)
 312             (emit-code src (make-glil-module 'ref '(guile) name #f))
 313             (emit-code #f (make-glil-call 'return 1)))))))
 314
 315       ((<lexical-ref> src name gensym)
 316        (case context
 317          ((push tail)
 318           (let ((loc (hashq-ref allocation gensym)))
 319             (case (car loc)
 320               ((stack)
 321                (emit-code src (make-glil-local 'ref (cdr loc))))
 322               ((heap)
 323                (emit-code src (make-glil-external
 324                                'ref (- level (cadr loc)) (cddr loc))))
 325               (else (error "badness" x loc)))
 326             (if (eq? context 'tail)
 327                 (emit-code #f (make-glil-call 'return 1)))))))
 328
 329       ((<lexical-set> src name gensym exp)
 330        (comp-push exp)
 331        (let ((loc (hashq-ref allocation gensym)))
 332          (case (car loc)
 333            ((stack)
 334             (emit-code src (make-glil-local 'set (cdr loc))))
 335            ((heap)
 336             (emit-code src (make-glil-external
 337                             'set (- level (cadr loc)) (cddr loc))))
 338            (else (error "badness" x loc))))
 339        (case context
 340          ((push)
 341           (emit-code #f (make-glil-void)))
 342          ((tail)
 343           (emit-code #f (make-glil-void))
 344           (emit-code #f (make-glil-call 'return 1)))))
 345
 346       ((<module-ref> src mod name public?)
 347        (emit-code src (make-glil-module 'ref mod name public?))
 348        (case context
 349          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 350          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 351
 352       ((<module-set> src mod name public? exp)
 353        (comp-push exp)
 354        (emit-code src (make-glil-module 'set mod name public?))
 355        (case context
 356          ((push)
 357           (emit-code #f (make-glil-void)))
 358          ((tail)
 359           (emit-code #f (make-glil-void))
 360           (emit-code #f (make-glil-call 'return 1)))))
 361
 362       ((<toplevel-ref> src name)
 363        (emit-code src (make-glil-toplevel 'ref name))
 364        (case context
 365          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 366          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 367
 368       ((<toplevel-set> src name exp)
 369        (comp-push exp)
 370        (emit-code src (make-glil-toplevel 'set name))
 371        (case context
 372          ((push)
 373           (emit-code #f (make-glil-void)))
 374          ((tail)
 375           (emit-code #f (make-glil-void))
 376           (emit-code #f (make-glil-call 'return 1)))))
 377
 378       ((<toplevel-define> src name exp)
 379        (comp-push exp)
 380        (emit-code src (make-glil-toplevel 'define name))
 381        (case context
 382          ((push)
 383           (emit-code #f (make-glil-void)))
 384          ((tail)
 385           (emit-code #f (make-glil-void))
 386           (emit-code #f (make-glil-call 'return 1)))))
 387
 388       ((<lambda>)
 389        (case context
 390          ((push)
 391           (emit-code #f (flatten-lambda x level allocation)))
 392          ((tail)
 393           (emit-code #f (flatten-lambda x level allocation))
 394           (emit-code #f (make-glil-call 'return 1)))))
 395
 396       ((<let> src names vars vals exp)
 397        (for-each comp-push vals)
 398        (emit-bindings src names vars allocation emit-code)
 399        (for-each (lambda (v)
 400                    (let ((loc (hashq-ref allocation v)))
 401                      (case (car loc)
 402                        ((stack)
 403                         (emit-code src (make-glil-local 'set (cdr loc))))
 404                        ((heap)
 405                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 406                        (else (error "badness" x loc)))))
 407                  (reverse vars))
 408        (comp-tail exp)
 409        (emit-code #f (make-glil-unbind)))
 410
 411       ((<letrec> src names vars vals exp)
 412        (for-each comp-push vals)
 413        (emit-bindings src names vars allocation emit-code)
 414        (for-each (lambda (v)
 415                    (let ((loc (hashq-ref allocation v)))
 416                      (case (car loc)
 417                        ((stack)
 418                         (emit-code src (make-glil-local 'set (cdr loc))))
 419                        ((heap)
 420                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 421                        (else (error "badness" x loc)))))
 422                  (reverse vars))
 423        (comp-tail exp)
 424        (emit-code #f (make-glil-unbind))))))