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