module/language/ghil/compile-glil.scm

   1 ;;; GHIL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001 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 ghil compile-glil)
  23   #:use-syntax (system base syntax)
  24   #:use-module (language glil)
  25   #:use-module (language ghil)
  26   #:use-module (ice-9 common-list)
  27   #:export (compile-glil))
  28
  29 (define (compile-glil x e opts)
  30   (if (memq #:O opts) (set! x (optimize x)))
  31   (values (codegen x)
  32           (and e (cons (car e) (cddr e)))))
  33
  34 \f
  35 ;;;
  36 ;;; Stage 2: Optimization
  37 ;;;
  38
  39 (define (lift-variables! env)
  40   (let ((parent-env (ghil-env-parent env)))
  41     (for-each (lambda (v)
  42                 (case (ghil-var-kind v)
  43                   ((argument) (set! (ghil-var-kind v) 'local)))
  44                 (set! (ghil-var-env v) parent-env)
  45                 (ghil-env-add! parent-env v))
  46               (ghil-env-variables env))))
  47
  48 ;; The premise of this, unused, approach to optimization is that you can
  49 ;; determine the environment of a variable lexically, because they have
  50 ;; been alpha-renamed. It makes the transformations *much* easier.
  51 ;; Unfortunately it doesn't work yet.
  52 (define (optimize* x)
  53   (transform-record (<ghil> env loc) x
  54     ((quasiquote exp)
  55      (define (optimize-qq x)
  56        (cond ((list? x) (map optimize-qq x))
  57              ((pair? x) (cons (optimize-qq (car x)) (optimize-qq (cdr x))))
  58              ((record? x) (optimize x))
  59              (else x)))
  60      (-> (quasiquote (optimize-qq x))))
  61
  62     ((unquote exp)
  63      (-> (unquote (optimize exp))))
  64
  65     ((unquote-splicing exp)
  66      (-> (unquote-splicing (optimize exp))))
  67
  68     ((set var val)
  69      (-> (set var (optimize val))))
  70
  71     ((define var val)
  72      (-> (define var (optimize val))))
  73
  74     ((if test then else)
  75      (-> (if (optimize test) (optimize then) (optimize else))))
  76
  77     ((and exps)
  78      (-> (and (map optimize exps))))
  79
  80     ((or exps)
  81      (-> (or (map optimize exps))))
  82
  83     ((begin exps)
  84      (-> (begin (map optimize exps))))
  85
  86     ((bind vars vals body)
  87      (-> (bind vars (map optimize vals) (optimize body))))
  88
  89     ((mv-bind producer vars rest body)
  90      (-> (mv-bind (optimize producer) vars rest (optimize body))))
  91
  92     ((inline inst args)
  93      (-> (inline inst (map optimize args))))
  94
  95     ((call (proc (lambda vars (rest #f) meta body)) args)
  96      (-> (bind vars (optimize args) (optimize body))))
  97
  98     ((call proc args)
  99      (-> (call (optimize proc) (map optimize args))))
 100
 101     ((lambda vars rest meta body)
 102      (-> (lambda vars rest meta (optimize body))))
 103
 104     ((mv-call producer (consumer (lambda vars rest meta body)))
 105      (-> (mv-bind (optimize producer) vars rest (optimize body))))
 106
 107     ((mv-call producer consumer)
 108      (-> (mv-call (optimize producer) (optimize consumer))))
 109
 110     ((values values)
 111      (-> (values (map optimize values))))
 112
 113     ((values* values)
 114      (-> (values* (map optimize values))))
 115
 116     (else
 117      (error "unrecognized GHIL" x))))
 118
 119 (define (optimize x)
 120   (record-case x
 121     ((<ghil-set> env loc var val)
 122      (make-ghil-set env var (optimize val)))
 123
 124     ((<ghil-define> env loc var val)
 125      (make-ghil-define env var (optimize val)))
 126
 127     ((<ghil-if> env loc test then else)
 128      (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
 129
 130     ((<ghil-and> env loc exps)
 131      (make-ghil-and env loc (map optimize exps)))
 132
 133     ((<ghil-or> env loc exps)
 134      (make-ghil-or env loc (map optimize exps)))
 135
 136     ((<ghil-begin> env loc exps)
 137      (make-ghil-begin env loc (map optimize exps)))
 138
 139     ((<ghil-bind> env loc vars vals body)
 140      (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
 141
 142     ((<ghil-lambda> env loc vars rest meta body)
 143      (make-ghil-lambda env loc vars rest meta (optimize body)))
 144
 145     ((<ghil-inline> env loc instruction args)
 146      (make-ghil-inline env loc instruction (map optimize args)))
 147
 148     ((<ghil-call> env loc proc args)
 149      (let ((parent-env env))
 150        (record-case proc
 151          ;; ((@lambda (VAR...) BODY...) ARG...) =>
 152          ;;   (@let ((VAR ARG) ...) BODY...)
 153          ((<ghil-lambda> env loc vars rest meta body)
 154           (cond
 155            ((not rest)
 156             (lift-variables! env)
 157             (make-ghil-bind parent-env loc (map optimize args)))
 158            (else
 159             (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
 160          (else
 161           (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
 162
 163     ((<ghil-mv-call> env loc producer consumer)
 164      (record-case consumer
 165       ;; (mv-call PRODUCER (lambda ARGS BODY...)) =>
 166       ;;   (mv-let PRODUCER ARGS BODY...)
 167       ((<ghil-lambda> env loc vars rest meta body)
 168        (lift-variables! env)
 169        (make-ghil-mv-bind producer vars rest body))
 170       (else
 171        (make-ghil-mv-call env loc (optimize producer) (optimize consumer)))))
 172
 173     (else x)))
 174
 175 \f
 176 ;;;
 177 ;;; Stage 3: Code generation
 178 ;;;
 179
 180 (define *ia-void* (make-glil-void))
 181 (define *ia-drop* (make-glil-call 'drop 1))
 182 (define *ia-return* (make-glil-call 'return 1))
 183
 184 (define (make-label) (gensym ":L"))
 185
 186 (define (make-glil-var op env var)
 187   (case (ghil-var-kind var)
 188     ((argument)
 189      (make-glil-argument op (ghil-var-index var)))
 190     ((local)
 191      (make-glil-local op (ghil-var-index var)))
 192     ((external)
 193      (do ((depth 0 (1+ depth))
 194           (e env (ghil-env-parent e)))
 195          ((eq? e (ghil-var-env var))
 196           (make-glil-external op depth (ghil-var-index var)))))
 197     ((toplevel)
 198      (make-glil-toplevel op (ghil-var-name var)))
 199     ((public private)
 200      (make-glil-module op (ghil-var-env var) (ghil-var-name var)
 201                        (eq? (ghil-var-kind var) 'public)))
 202     (else (error "Unknown kind of variable:" var))))
 203
 204 (define (constant? x)
 205   (cond ((or (number? x) (string? x) (symbol? x) (keyword? x) (boolean? x)) #t)
 206         ((pair? x) (and (constant? (car x))
 207                         (constant? (cdr x))))
 208         ((vector? x) (let lp ((i (vector-length x)))
 209                        (or (zero? i)
 210                            (and (constant? (vector-ref x (1- i)))
 211                                 (lp (1- i))))))))
 212
 213 (define (codegen ghil)
 214   (let ((stack '()))
 215     (define (push-code! loc code)
 216       (set! stack (cons code stack))
 217       (if loc (set! stack (cons (make-glil-source loc) stack))))
 218     (define (var->binding var)
 219       (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
 220     (define (push-bindings! loc vars)
 221       (if (not (null? vars))
 222           (push-code! loc (make-glil-bind (map var->binding vars)))))
 223     (define (comp tree tail drop)
 224       (define (push-label! label)
 225         (push-code! #f (make-glil-label label)))
 226       (define (push-branch! loc inst label)
 227         (push-code! loc (make-glil-branch inst label)))
 228       (define (push-call! loc inst args)
 229         (for-each comp-push args)
 230         (push-code! loc (make-glil-call inst (length args))))
 231       ;; possible tail position
 232       (define (comp-tail tree) (comp tree tail drop))
 233       ;; push the result
 234       (define (comp-push tree) (comp tree #f #f))
 235       ;; drop the result
 236       (define (comp-drop tree) (comp tree #f #t))
 237       ;; drop the result if unnecessary
 238       (define (maybe-drop)
 239         (if drop (push-code! #f *ia-drop*)))
 240       ;; return here if necessary
 241       (define (maybe-return)
 242         (if tail (push-code! #f *ia-return*)))
 243       ;; return this code if necessary
 244       (define (return-code! loc code)
 245         (if (not drop) (push-code! loc code))
 246         (maybe-return))
 247       ;; return void if necessary
 248       (define (return-void!)
 249         (return-code! #f *ia-void*))
 250       ;; return object if necessary
 251       (define (return-object! loc obj)
 252         (return-code! loc (make-glil-const obj)))
 253       ;;
 254       ;; dispatch
 255       (record-case tree
 256         ((<ghil-void>)
 257          (return-void!))
 258
 259         ((<ghil-quote> env loc obj)
 260          (return-object! loc obj))
 261
 262         ((<ghil-quasiquote> env loc exp)
 263          (let loop ((x exp) (in-car? #f))
 264            (cond
 265             ((list? x)
 266              (push-call! #f 'mark '())
 267              (for-each (lambda (x) (loop x #t)) x)
 268              (push-call! #f 'list-mark '()))
 269             ((pair? x)
 270              (push-call! #f 'mark '())
 271              (loop (car x) #t)
 272              (loop (cdr x) #f)
 273              (push-call! #f 'cons-mark '()))
 274             ((record? x)
 275              (record-case x
 276               ((<ghil-unquote> env loc exp)
 277                (comp-push exp))
 278               ((<ghil-unquote-splicing> env loc exp)
 279                (if (not in-car?)
 280                    (error "unquote-splicing in the cdr of a pair" exp))
 281                (comp-push exp)
 282                (push-call! #f 'list-break '()))))
 283             ((constant? x)
 284              (push-code! #f (make-glil-const x)))
 285             (else
 286              (error "element of quasiquote can't be compiled" x))))
 287          (maybe-drop)
 288          (maybe-return))
 289
 290         ((<ghil-unquote> env loc exp)
 291          (error "unquote outside of quasiquote" exp))
 292
 293         ((<ghil-unquote-splicing> env loc exp)
 294          (error "unquote-splicing outside of quasiquote" exp))
 295
 296         ((<ghil-ref> env loc var)
 297          (return-code! loc (make-glil-var 'ref env var)))
 298
 299         ((<ghil-set> env loc var val)
 300          (comp-push val)
 301          (push-code! loc (make-glil-var 'set env var))
 302          (return-void!))
 303
 304         ((<ghil-define> env loc var val)
 305          (comp-push val)
 306          (push-code! loc (make-glil-var 'define env var))
 307          (return-void!))
 308
 309         ((<ghil-if> env loc test then else)
 310          ;;     TEST
 311          ;;     (br-if-not L1)
 312          ;;     THEN
 313          ;;     (br L2)
 314          ;; L1: ELSE
 315          ;; L2:
 316          (let ((L1 (make-label)) (L2 (make-label)))
 317            (comp-push test)
 318            (push-branch! loc 'br-if-not L1)
 319            (comp-tail then)
 320            (if (not tail) (push-branch! #f 'br L2))
 321            (push-label! L1)
 322            (comp-tail else)
 323            (if (not tail) (push-label! L2))))
 324
 325         ((<ghil-and> env loc exps)
 326          ;;     EXP
 327          ;;     (br-if-not L1)
 328          ;;     ...
 329          ;;     TAIL
 330          ;;     (br L2)
 331          ;; L1: (const #f)
 332          ;; L2:
 333          (cond ((null? exps) (return-object! loc #t))
 334                ((null? (cdr exps)) (comp-tail (car exps)))
 335                (else
 336                 (let ((L1 (make-label)) (L2 (make-label)))
 337                   (let lp ((exps exps))
 338                     (cond ((null? (cdr exps))
 339                            (comp-tail (car exps))
 340                            (push-branch! #f 'br L2)
 341                            (push-label! L1)
 342                            (return-object! #f #f)
 343                            (push-label! L2)
 344                            (maybe-return))
 345                           (else
 346                            (comp-push (car exps))
 347                            (push-branch! #f 'br-if-not L1)
 348                            (lp (cdr exps)))))))))
 349
 350         ((<ghil-or> env loc exps)
 351          ;;     EXP
 352          ;;     (dup)
 353          ;;     (br-if L1)
 354          ;;     (drop)
 355          ;;     ...
 356          ;;     TAIL
 357          ;; L1:
 358          (cond ((null? exps) (return-object! loc #f))
 359                ((null? (cdr exps)) (comp-tail (car exps)))
 360                (else
 361                 (let ((L1 (make-label)))
 362                   (let lp ((exps exps))
 363                     (cond ((null? (cdr exps))
 364                            (comp-tail (car exps))
 365                            (push-label! L1)
 366                            (maybe-return))
 367                           (else
 368                            (comp-push (car exps))
 369                            (if (not drop)
 370                                (push-call! #f 'dup '()))
 371                            (push-branch! #f 'br-if L1)
 372                            (if (not drop)
 373                                (push-code! loc (make-glil-call 'drop 1)))
 374                            (lp (cdr exps)))))))))
 375
 376         ((<ghil-begin> env loc exps)
 377          ;; EXPS...
 378          ;; TAIL
 379          (if (null? exps)
 380              (return-void!)
 381              (do ((exps exps (cdr exps)))
 382                  ((null? (cdr exps))
 383                   (comp-tail (car exps)))
 384                (comp-drop (car exps)))))
 385
 386         ((<ghil-bind> env loc vars vals body)
 387          ;; VALS...
 388          ;; (set VARS)...
 389          ;; BODY
 390          (for-each comp-push vals)
 391          (push-bindings! loc vars)
 392          (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
 393                    (reverse vars))
 394          (comp-tail body)
 395          (push-code! #f (make-glil-unbind)))
 396
 397         ((<ghil-mv-bind> env loc producer vars rest body)
 398          ;; VALS...
 399          ;; (set VARS)...
 400          ;; BODY
 401          (let ((MV (make-label)))
 402            (comp-push producer)
 403            (push-code! loc (make-glil-mv-call 0 MV))
 404            (push-code! #f (make-glil-const 1))
 405            (push-label! MV)
 406            (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
 407            (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
 408                      (reverse vars)))
 409          (comp-tail body)
 410          (push-code! #f (make-glil-unbind)))
 411
 412         ((<ghil-lambda> env loc vars rest meta body)
 413          (return-code! loc (codegen tree)))
 414
 415         ((<ghil-inline> env loc inline args)
 416          ;; ARGS...
 417          ;; (INST NARGS)
 418          (let ((tail-table '((call . goto/args)
 419                              (apply . goto/apply)
 420                              (call/cc . goto/cc))))
 421            (cond ((and tail (assq-ref tail-table inline))
 422                   => (lambda (tail-inst)
 423                        (push-call! loc tail-inst args)))
 424                  (else
 425                   (push-call! loc inline args)
 426                   (maybe-drop)
 427                   (maybe-return)))))
 428
 429         ((<ghil-values> env loc values)
 430          (cond (tail ;; (lambda () (values 1 2))
 431                 (push-call! loc 'return/values values))
 432                (drop ;; (lambda () (values 1 2) 3)
 433                 (for-each comp-drop values))
 434                (else ;; (lambda () (list (values 10 12) 1))
 435                 (push-code! #f (make-glil-const 'values))
 436                 (push-code! #f (make-glil-call 'link-now 1))
 437                 (push-code! #f (make-glil-call 'variable-ref 0))
 438                 (push-call! loc 'call values))))
 439
 440         ((<ghil-values*> env loc values)
 441          (cond (tail ;; (lambda () (apply values '(1 2)))
 442                 (push-call! loc 'return/values* values))
 443                (drop ;; (lambda () (apply values '(1 2)) 3)
 444                 (for-each comp-drop values))
 445                (else ;; (lambda () (list (apply values '(10 12)) 1))
 446                 (push-code! #f (make-glil-const 'values))
 447                 (push-code! #f (make-glil-call 'link-now 1))
 448                 (push-code! #f (make-glil-call 'variable-ref 0))
 449                 (push-call! loc 'apply values))))
 450
 451         ((<ghil-call> env loc proc args)
 452          ;; PROC
 453          ;; ARGS...
 454          ;; ([tail-]call NARGS)
 455          (comp-push proc)
 456          (let ((nargs (length args)))
 457            (cond ((< nargs 255)
 458                   (push-call! loc (if tail 'goto/args 'call) args))
 459                  (else
 460                   (push-call! loc 'mark '())
 461                   (for-each comp-push args)
 462                   (push-call! loc 'list-mark '())
 463                   (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
 464          (maybe-drop))
 465
 466         ((<ghil-mv-call> env loc producer consumer)
 467          ;; CONSUMER
 468          ;; PRODUCER
 469          ;; (mv-call MV)
 470          ;; ([tail]-call 1)
 471          ;; goto POST
 472          ;; MV: [tail-]call/nargs
 473          ;; POST: (maybe-drop)
 474          (let ((MV (make-label)) (POST (make-label)))
 475            (comp-push consumer)
 476            (comp-push producer)
 477            (push-code! loc (make-glil-mv-call 0 MV))
 478            (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
 479            (cond ((not tail)
 480                   (push-branch! #f 'br POST)))
 481            (push-label! MV)
 482            (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
 483            (cond ((not tail)
 484                   (push-label! POST)
 485                   (maybe-drop)))))
 486
 487         ((<ghil-reified-env> env loc)
 488          (return-object! loc (ghil-env-reify env)))))
 489
 490     ;;
 491     ;; main
 492     (record-case ghil
 493       ((<ghil-lambda> env loc vars rest meta body)
 494        (let* ((evars (ghil-env-variables env))
 495               (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
 496               (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
 497               (nargs (allocate-indices-linearly! vars))
 498               (nlocs (allocate-locals! locs body))
 499               (nexts (allocate-indices-linearly! exts)))
 500          ;; meta bindings
 501          (push-bindings! #f vars)
 502          ;; copy args to the heap if they're marked as external
 503          (do ((n 0 (1+ n))
 504               (l vars (cdr l)))
 505              ((null? l))
 506            (let ((v (car l)))
 507              (case (ghil-var-kind v)
 508                ((external)
 509                 (push-code! #f (make-glil-argument 'ref n))
 510                 (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
 511          ;; push on definition source location
 512          (if loc (set! stack (cons (make-glil-source loc) stack)))
 513          ;; compile body
 514          (comp body #t #f)
 515          ;; create GLIL
 516          (make-glil-program nargs (if rest 1 0) nlocs nexts meta
 517                             (reverse! stack)))))))
 518
 519 (define (allocate-indices-linearly! vars)
 520   (do ((n 0 (1+ n))
 521        (l vars (cdr l)))
 522       ((null? l) n)
 523     (let ((v (car l))) (set! (ghil-var-index v) n))))
 524
 525 (define (allocate-locals! vars body)
 526   (let ((free '()) (nlocs 0))
 527     (define (allocate! var)
 528       (cond
 529        ((pair? free)
 530         (set! (ghil-var-index var) (car free))
 531         (set! free (cdr free)))
 532        (else
 533         (set! (ghil-var-index var) nlocs)
 534         (set! nlocs (1+ nlocs)))))
 535     (define (deallocate! var)
 536       (set! free (cons (ghil-var-index var) free)))
 537     (let lp ((x body))
 538       (record-case x
 539         ((<ghil-void>))
 540         ((<ghil-quote>))
 541         ((<ghil-quasiquote> exp)
 542          (let qlp ((x exp))
 543            (cond ((list? x) (for-each qlp x))
 544                  ((pair? x) (qlp (car x)) (qlp (cdr x)))
 545                  ((record? x)
 546                   (record-case x
 547                    ((<ghil-unquote> exp) (lp exp))
 548                    ((<ghil-unquote-splicing> exp) (lp exp)))))))
 549         ((<ghil-unquote> exp)
 550          (lp exp))
 551         ((<ghil-unquote-splicing> exp)
 552          (lp exp))
 553         ((<ghil-reified-env>))
 554         ((<ghil-set> val)
 555          (lp val))
 556         ((<ghil-ref>))
 557         ((<ghil-define> val)
 558          (lp val))
 559         ((<ghil-if> test then else)
 560          (lp test) (lp then) (lp else))
 561         ((<ghil-and> exps)
 562          (for-each lp exps))
 563         ((<ghil-or> exps)
 564          (for-each lp exps))
 565         ((<ghil-begin> exps)
 566          (for-each lp exps))
 567         ((<ghil-bind> vars vals body)
 568          (for-each allocate! vars)
 569          (for-each lp vals)
 570          (lp body)
 571          (for-each deallocate! vars))
 572         ((<ghil-mv-bind> vars producer body)
 573          (lp producer)
 574          (for-each allocate! vars)
 575          (lp body)
 576          (for-each deallocate! vars))
 577         ((<ghil-inline> args)
 578          (for-each lp args))
 579         ((<ghil-call> proc args)
 580          (lp proc)
 581          (for-each lp args))
 582         ((<ghil-lambda>))
 583         ((<ghil-mv-call> producer consumer)
 584          (lp producer)
 585          (lp consumer))
 586         ((<ghil-values> values)
 587          (for-each lp values))
 588         ((<ghil-values*> values)
 589          (for-each lp values))))
 590     nlocs))