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 library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library 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 GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language tree-il compile-glil)
  22   #:use-module (system base syntax)
  23   #:use-module (ice-9 receive)
  24   #:use-module (language glil)
  25   #:use-module (system vm instruction)
  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    ((vector-ref . 2) . vector-ref)
  86    ((vector-set! . 3) . vector-set)
  87
  88    ((bytevector-u8-ref . 2) . bv-u8-ref)
  89    ((bytevector-u8-set! . 3) . bv-u8-set)
  90    ((bytevector-s8-ref . 2) . bv-s8-ref)
  91    ((bytevector-s8-set! . 3) . bv-s8-set)
  92
  93    ((bytevector-u16-ref . 3) . bv-u16-ref)
  94    ((bytevector-u16-set! . 4) . bv-u16-set)
  95    ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
  96    ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
  97    ((bytevector-s16-ref . 3) . bv-s16-ref)
  98    ((bytevector-s16-set! . 4) . bv-s16-set)
  99    ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
 100    ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
 101
 102    ((bytevector-u32-ref . 3) . bv-u32-ref)
 103    ((bytevector-u32-set! . 4) . bv-u32-set)
 104    ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
 105    ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
 106    ((bytevector-s32-ref . 3) . bv-s32-ref)
 107    ((bytevector-s32-set! . 4) . bv-s32-set)
 108    ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
 109    ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
 110
 111    ((bytevector-u64-ref . 3) . bv-u64-ref)
 112    ((bytevector-u64-set! . 4) . bv-u64-set)
 113    ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
 114    ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
 115    ((bytevector-s64-ref . 3) . bv-s64-ref)
 116    ((bytevector-s64-set! . 4) . bv-s64-set)
 117    ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
 118    ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
 119
 120    ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
 121    ((bytevector-ieee-single-set! . 4) . bv-f32-set)
 122    ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
 123    ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
 124    ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
 125    ((bytevector-ieee-double-set! . 4) . bv-f64-set)
 126    ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
 127    ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
 128
 129
 130 \f
 131
 132 (define (make-label) (gensym ":L"))
 133
 134 (define (vars->bind-list ids vars allocation)
 135   (map (lambda (id v)
 136          (let ((loc (hashq-ref allocation v)))
 137            (case (car loc)
 138              ((stack) (list id 'local (cdr loc)))
 139              ((heap)  (list id 'external (cddr loc)))
 140              (else (error "badness" id v loc)))))
 141        ids
 142        vars))
 143
 144 (define (emit-bindings src ids vars allocation emit-code)
 145   (if (pair? vars)
 146       (emit-code src (make-glil-bind
 147                       (vars->bind-list ids vars allocation)))))
 148
 149 (define (with-output-to-code proc)
 150   (let ((out '()))
 151     (define (emit-code src x)
 152       (set! out (cons x out))
 153       (if src
 154           (set! out (cons (make-glil-source src) out))))
 155     (proc emit-code)
 156     (reverse out)))
 157
 158 (define (flatten-lambda x level allocation)
 159   (receive (ids vars nargs nrest)
 160       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
 161                (oids '()) (ovars '()) (n 0))
 162           (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
 163                 ((pair? vars) (lp (cdr ids) (cdr vars)
 164                                   (cons (car ids) oids) (cons (car vars) ovars)
 165                                   (1+ n)))
 166                 (else (values (reverse (cons ids oids))
 167                               (reverse (cons vars ovars))
 168                               (1+ n) 1))))
 169     (let ((nlocs (car (hashq-ref allocation x)))
 170           (nexts (cdr (hashq-ref allocation x))))
 171       (make-glil-program
 172        nargs nrest nlocs nexts (lambda-meta x)
 173        (with-output-to-code
 174         (lambda (emit-code)
 175           ;; write bindings and source debugging info
 176           (emit-bindings #f ids vars allocation emit-code)
 177           (if (lambda-src x)
 178               (emit-code #f (make-glil-source (lambda-src x))))
 179
 180           ;; copy args to the heap if necessary
 181           (let lp ((in vars) (n 0))
 182             (if (not (null? in))
 183                 (let ((loc (hashq-ref allocation (car in))))
 184                   (case (car loc)
 185                     ((heap)
 186                      (emit-code #f (make-glil-local 'ref n))
 187                      (emit-code #f (make-glil-external 'set 0 (cddr loc)))))
 188                   (lp (cdr in) (1+ n)))))
 189
 190           ;; and here, here, dear reader: we compile.
 191           (flatten (lambda-body x) (1+ level) allocation emit-code)))))))
 192
 193 (define (flatten x level allocation emit-code)
 194   (define (emit-label label)
 195     (emit-code #f (make-glil-label label)))
 196   (define (emit-branch src inst label)
 197     (emit-code src (make-glil-branch inst label)))
 198
 199   ;; LMVRA == "let-values MV return address"
 200   (let comp ((x x) (context 'tail) (LMVRA #f))
 201     (define (comp-tail tree) (comp tree context LMVRA))
 202     (define (comp-push tree) (comp tree 'push #f))
 203     (define (comp-drop tree) (comp tree 'drop #f))
 204     (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
 205
 206     (record-case x
 207       ((<void>)
 208        (case context
 209          ((push vals) (emit-code #f (make-glil-void)))
 210          ((tail)
 211           (emit-code #f (make-glil-void))
 212           (emit-code #f (make-glil-call 'return 1)))))
 213
 214       ((<const> src exp)
 215        (case context
 216          ((push vals) (emit-code src (make-glil-const exp)))
 217          ((tail)
 218           (emit-code src (make-glil-const exp))
 219           (emit-code #f (make-glil-call 'return 1)))))
 220
 221       ;; FIXME: should represent sequence as exps tail
 222       ((<sequence> src exps)
 223        (let lp ((exps exps))
 224          (if (null? (cdr exps))
 225              (comp-tail (car exps))
 226              (begin
 227                (comp-drop (car exps))
 228                (lp (cdr exps))))))
 229
 230       ((<application> src proc args)
 231        ;; FIXME: need a better pattern-matcher here
 232        (cond
 233         ((and (primitive-ref? proc)
 234               (eq? (primitive-ref-name proc) '@apply)
 235               (>= (length args) 1))
 236          (let ((proc (car args))
 237                (args (cdr args)))
 238            (cond
 239             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 240                   (not (eq? context 'push)) (not (eq? context 'vals)))
 241              ;; tail: (lambda () (apply values '(1 2)))
 242              ;; drop: (lambda () (apply values '(1 2)) 3)
 243              ;; push: (lambda () (list (apply values '(10 12)) 1))
 244              (case context
 245                ((drop) (for-each comp-drop args))
 246                ((tail)
 247                 (for-each comp-push args)
 248                 (emit-code src (make-glil-call 'return/values* (length args))))))
 249
 250             (else
 251              (case context
 252                ((tail)
 253                 (comp-push proc)
 254                 (for-each comp-push args)
 255                 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 256                ((push)
 257                 (comp-push proc)
 258                 (for-each comp-push args)
 259                 (emit-code src (make-glil-call 'apply (1+ (length args)))))
 260                ((vals)
 261                 (comp-vals
 262                  (make-application src (make-primitive-ref #f 'apply)
 263                                    (cons proc args))
 264                  LMVRA))
 265                ((drop)
 266                 ;; Well, shit. The proc might return any number of
 267                 ;; values (including 0), since it's in a drop context,
 268                 ;; yet apply does not create a MV continuation. So we
 269                 ;; mv-call out to our trampoline instead.
 270                 (comp-drop
 271                  (make-application src (make-primitive-ref #f 'apply)
 272                                    (cons proc args)))))))))
 273
 274         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 275               (not (eq? context 'push)))
 276          ;; tail: (lambda () (values '(1 2)))
 277          ;; drop: (lambda () (values '(1 2)) 3)
 278          ;; push: (lambda () (list (values '(10 12)) 1))
 279          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 280          (case context
 281            ((drop) (for-each comp-drop args))
 282            ((vals)
 283             (for-each comp-push args)
 284             (emit-code #f (make-glil-const (length args)))
 285             (emit-branch src 'br LMVRA))
 286            ((tail)
 287             (for-each comp-push args)
 288             (emit-code src (make-glil-call 'return/values (length args))))))
 289
 290         ((and (primitive-ref? proc)
 291               (eq? (primitive-ref-name proc) '@call-with-values)
 292               (= (length args) 2))
 293          ;; CONSUMER
 294          ;; PRODUCER
 295          ;; (mv-call MV)
 296          ;; ([tail]-call 1)
 297          ;; goto POST
 298          ;; MV: [tail-]call/nargs
 299          ;; POST: (maybe-drop)
 300          (case context
 301            ((vals)
 302             ;; Fall back.
 303             (comp-vals
 304              (make-application src (make-primitive-ref #f 'call-with-values)
 305                                args)
 306              LMVRA))
 307            (else
 308             (let ((MV (make-label)) (POST (make-label))
 309                   (producer (car args)) (consumer (cadr args)))
 310               (comp-push consumer)
 311               (comp-push producer)
 312               (emit-code src (make-glil-mv-call 0 MV))
 313               (case context
 314                 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 315                 (else   (emit-code src (make-glil-call 'call 1))
 316                         (emit-branch #f 'br POST)))
 317               (emit-label MV)
 318               (case context
 319                 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 320                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 321                         (emit-label POST)
 322                         (if (eq? context 'drop)
 323                             (emit-code #f (make-glil-call 'drop 1)))))))))
 324
 325         ((and (primitive-ref? proc)
 326               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 327               (= (length args) 1))
 328          (case context
 329            ((tail)
 330             (comp-push (car args))
 331             (emit-code src (make-glil-call 'goto/cc 1)))
 332            ((vals)
 333             (comp-vals
 334              (make-application
 335               src (make-primitive-ref #f 'call-with-current-continuation)
 336               args)
 337              LMVRA))
 338            ((push)
 339             (comp-push (car args))
 340             (emit-code src (make-glil-call 'call/cc 1)))
 341            ((drop)
 342             ;; Crap. Just like `apply' in drop context.
 343             (comp-drop
 344              (make-application
 345               src (make-primitive-ref #f 'call-with-current-continuation)
 346               args)))))
 347
 348         ((and (primitive-ref? proc)
 349               (or (hash-ref *primcall-ops*
 350                             (cons (primitive-ref-name proc) (length args)))
 351                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 352          => (lambda (op)
 353               (for-each comp-push args)
 354               (emit-code src (make-glil-call op (length args)))
 355               (case (instruction-pushes op)
 356                 ((0)
 357                  (case context
 358                    ((tail) (emit-code #f (make-glil-void))
 359                            (emit-code #f (make-glil-call 'return 1)))
 360                    ((push vals) (emit-code #f (make-glil-void)))))
 361                 ((1)
 362                  (case context
 363                    ((tail) (emit-code #f (make-glil-call 'return 1)))
 364                    ((drop) (emit-code #f (make-glil-call 'drop 1)))))
 365                 (else
 366                  (error "bad primitive op: too many pushes"
 367                         op (instruction-pushes op))))))
 368
 369         (else
 370          (comp-push proc)
 371          (for-each comp-push args)
 372          (let ((len (length args)))
 373            (case context
 374              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 375              ((push) (emit-code src (make-glil-call 'call len)))
 376              ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
 377              ((drop)
 378               (let ((MV (make-label)) (POST (make-label)))
 379                 (emit-code src (make-glil-mv-call len MV))
 380                 (emit-code #f (make-glil-call 'drop 1))
 381                 (emit-branch #f 'br POST)
 382                 (emit-label MV)
 383                 (emit-code #f (make-glil-mv-bind '() #f))
 384                 (emit-code #f (make-glil-unbind))
 385                 (emit-label POST))))))))
 386
 387       ((<conditional> src test then else)
 388        ;;     TEST
 389        ;;     (br-if-not L1)
 390        ;;     THEN
 391        ;;     (br L2)
 392        ;; L1: ELSE
 393        ;; L2:
 394        (let ((L1 (make-label)) (L2 (make-label)))
 395          (comp-push test)
 396          (emit-branch src 'br-if-not L1)
 397          (comp-tail then)
 398          (if (not (eq? context 'tail))
 399              (emit-branch #f 'br L2))
 400          (emit-label L1)
 401          (comp-tail else)
 402          (if (not (eq? context 'tail))
 403              (emit-label L2))))
 404
 405       ((<primitive-ref> src name)
 406        (cond
 407         ((eq? (module-variable (fluid-ref *comp-module*) name)
 408               (module-variable the-root-module name))
 409          (case context
 410            ((push vals)
 411             (emit-code src (make-glil-toplevel 'ref name)))
 412            ((tail)
 413             (emit-code src (make-glil-toplevel 'ref name))
 414             (emit-code #f (make-glil-call 'return 1)))))
 415         (else
 416          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
 417          (case context
 418            ((push vals)
 419             (emit-code src (make-glil-module 'ref '(guile) name #f)))
 420            ((tail)
 421             (emit-code src (make-glil-module 'ref '(guile) name #f))
 422             (emit-code #f (make-glil-call 'return 1)))))))
 423
 424       ((<lexical-ref> src name gensym)
 425        (case context
 426          ((push vals tail)
 427           (let ((loc (hashq-ref allocation gensym)))
 428             (case (car loc)
 429               ((stack)
 430                (emit-code src (make-glil-local 'ref (cdr loc))))
 431               ((heap)
 432                (emit-code src (make-glil-external
 433                                'ref (- level (cadr loc)) (cddr loc))))
 434               (else (error "badness" x loc)))
 435             (if (eq? context 'tail)
 436                 (emit-code #f (make-glil-call 'return 1)))))))
 437
 438       ((<lexical-set> src name gensym exp)
 439        (comp-push exp)
 440        (let ((loc (hashq-ref allocation gensym)))
 441          (case (car loc)
 442            ((stack)
 443             (emit-code src (make-glil-local 'set (cdr loc))))
 444            ((heap)
 445             (emit-code src (make-glil-external
 446                             'set (- level (cadr loc)) (cddr loc))))
 447            (else (error "badness" x loc))))
 448        (case context
 449          ((push vals)
 450           (emit-code #f (make-glil-void)))
 451          ((tail)
 452           (emit-code #f (make-glil-void))
 453           (emit-code #f (make-glil-call 'return 1)))))
 454
 455       ((<module-ref> src mod name public?)
 456        (emit-code src (make-glil-module 'ref mod name public?))
 457        (case context
 458          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 459          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 460
 461       ((<module-set> src mod name public? exp)
 462        (comp-push exp)
 463        (emit-code src (make-glil-module 'set mod name public?))
 464        (case context
 465          ((push vals)
 466           (emit-code #f (make-glil-void)))
 467          ((tail)
 468           (emit-code #f (make-glil-void))
 469           (emit-code #f (make-glil-call 'return 1)))))
 470
 471       ((<toplevel-ref> src name)
 472        (emit-code src (make-glil-toplevel 'ref name))
 473        (case context
 474          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 475          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 476
 477       ((<toplevel-set> src name exp)
 478        (comp-push exp)
 479        (emit-code src (make-glil-toplevel 'set name))
 480        (case context
 481          ((push vals)
 482           (emit-code #f (make-glil-void)))
 483          ((tail)
 484           (emit-code #f (make-glil-void))
 485           (emit-code #f (make-glil-call 'return 1)))))
 486
 487       ((<toplevel-define> src name exp)
 488        (comp-push exp)
 489        (emit-code src (make-glil-toplevel 'define name))
 490        (case context
 491          ((push vals)
 492           (emit-code #f (make-glil-void)))
 493          ((tail)
 494           (emit-code #f (make-glil-void))
 495           (emit-code #f (make-glil-call 'return 1)))))
 496
 497       ((<lambda>)
 498        (case context
 499          ((push vals)
 500           (emit-code #f (flatten-lambda x level allocation)))
 501          ((tail)
 502           (emit-code #f (flatten-lambda x level allocation))
 503           (emit-code #f (make-glil-call 'return 1)))))
 504
 505       ((<let> src names vars vals body)
 506        (for-each comp-push vals)
 507        (emit-bindings src names vars allocation emit-code)
 508        (for-each (lambda (v)
 509                    (let ((loc (hashq-ref allocation v)))
 510                      (case (car loc)
 511                        ((stack)
 512                         (emit-code src (make-glil-local 'set (cdr loc))))
 513                        ((heap)
 514                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 515                        (else (error "badness" x loc)))))
 516                  (reverse vars))
 517        (comp-tail body)
 518        (emit-code #f (make-glil-unbind)))
 519
 520       ((<letrec> src names vars vals body)
 521        (for-each comp-push vals)
 522        (emit-bindings src names vars allocation emit-code)
 523        (for-each (lambda (v)
 524                    (let ((loc (hashq-ref allocation v)))
 525                      (case (car loc)
 526                        ((stack)
 527                         (emit-code src (make-glil-local 'set (cdr loc))))
 528                        ((heap)
 529                         (emit-code src (make-glil-external 'set 0 (cddr loc))))
 530                        (else (error "badness" x loc)))))
 531                  (reverse vars))
 532        (comp-tail body)
 533        (emit-code #f (make-glil-unbind)))
 534
 535       ((<let-values> src names vars exp body)
 536        (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
 537          (cond
 538           ((pair? inames)
 539            (lp (cons (car inames) names) (cons (car ivars) vars)
 540                (cdr inames) (cdr ivars) #f))
 541           ((not (null? inames))
 542            (lp (cons inames names) (cons ivars vars) '() '() #t))
 543           (else
 544            (let ((names (reverse! names))
 545                  (vars (reverse! vars))
 546                  (MV (make-label)))
 547              (comp-vals exp MV)
 548              (emit-code #f (make-glil-const 1))
 549              (emit-label MV)
 550              (emit-code src (make-glil-mv-bind
 551                              (vars->bind-list names vars allocation)
 552                              rest?))
 553              (for-each (lambda (v)
 554                          (let ((loc (hashq-ref allocation v)))
 555                            (case (car loc)
 556                              ((stack)
 557                               (emit-code src (make-glil-local 'set (cdr loc))))
 558                              ((heap)
 559                               (emit-code src (make-glil-external 'set 0 (cddr loc))))
 560                              (else (error "badness" x loc)))))
 561                        (reverse vars))
 562              (comp-tail body)
 563              (emit-code #f (make-glil-unbind))))))))))