module/language/ghil/compile-glil.scm

   1 ;;; GHIL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001 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 ghil compile-glil)
  22   #:use-module (system base syntax)
  23   #:use-module (language glil)
  24   #:use-module (language ghil)
  25   #:use-module (ice-9 common-list)
  26   #:export (compile-glil))
  27
  28 (define (compile-glil x e opts)
  29   (if (memq #:O opts) (set! x (optimize x)))
  30   (values (codegen x)
  31           (and e (cons (car e) (cddr e)))
  32           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-local 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) (let ((kind (ghil-var-kind var)))
 220                                   (case kind ((argument) 'local) (else kind)))
 221             (ghil-var-index var)))
 222     (define (push-bindings! loc vars)
 223       (if (not (null? vars))
 224           (push-code! loc (make-glil-bind (map var->binding vars)))))
 225     (define (comp tree tail drop)
 226       (define (push-label! label)
 227         (push-code! #f (make-glil-label label)))
 228       (define (push-branch! loc inst label)
 229         (push-code! loc (make-glil-branch inst label)))
 230       (define (push-call! loc inst args)
 231         (for-each comp-push args)
 232         (push-code! loc (make-glil-call inst (length args))))
 233       ;; possible tail position
 234       (define (comp-tail tree) (comp tree tail drop))
 235       ;; push the result
 236       (define (comp-push tree) (comp tree #f #f))
 237       ;; drop the result
 238       (define (comp-drop tree) (comp tree #f #t))
 239       ;; drop the result if unnecessary
 240       (define (maybe-drop)
 241         (if drop (push-code! #f *ia-drop*)))
 242       ;; return here if necessary
 243       (define (maybe-return)
 244         (if tail (push-code! #f *ia-return*)))
 245       ;; return this code if necessary
 246       (define (return-code! loc code)
 247         (if (not drop) (push-code! loc code))
 248         (maybe-return))
 249       ;; return void if necessary
 250       (define (return-void!)
 251         (return-code! #f *ia-void*))
 252       ;; return object if necessary
 253       (define (return-object! loc obj)
 254         (return-code! loc (make-glil-const obj)))
 255       ;;
 256       ;; dispatch
 257       (record-case tree
 258         ((<ghil-void>)
 259          (return-void!))
 260
 261         ((<ghil-quote> env loc obj)
 262          (return-object! loc obj))
 263
 264         ((<ghil-quasiquote> env loc exp)
 265          (let loop ((x exp) (in-car? #f))
 266            (cond
 267             ((list? x)
 268              (push-call! #f 'mark '())
 269              (for-each (lambda (x) (loop x #t)) x)
 270              (push-call! #f 'list-mark '()))
 271             ((pair? x)
 272              (push-call! #f 'mark '())
 273              (loop (car x) #t)
 274              (loop (cdr x) #f)
 275              (push-call! #f 'cons-mark '()))
 276             ((record? x)
 277              (record-case x
 278               ((<ghil-unquote> env loc exp)
 279                (comp-push exp))
 280               ((<ghil-unquote-splicing> env loc exp)
 281                (if (not in-car?)
 282                    (error "unquote-splicing in the cdr of a pair" exp))
 283                (comp-push exp)
 284                (push-call! #f 'list-break '()))))
 285             ((constant? x)
 286              (push-code! #f (make-glil-const x)))
 287             (else
 288              (error "element of quasiquote can't be compiled" x))))
 289          (maybe-drop)
 290          (maybe-return))
 291
 292         ((<ghil-unquote> env loc exp)
 293          (error "unquote outside of quasiquote" exp))
 294
 295         ((<ghil-unquote-splicing> env loc exp)
 296          (error "unquote-splicing outside of quasiquote" exp))
 297
 298         ((<ghil-ref> env loc var)
 299          (return-code! loc (make-glil-var 'ref env var)))
 300
 301         ((<ghil-set> env loc var val)
 302          (comp-push val)
 303          (push-code! loc (make-glil-var 'set env var))
 304          (return-void!))
 305
 306         ((<ghil-define> env loc var val)
 307          (comp-push val)
 308          (push-code! loc (make-glil-var 'define env var))
 309          (return-void!))
 310
 311         ((<ghil-if> env loc test then else)
 312          ;;     TEST
 313          ;;     (br-if-not L1)
 314          ;;     THEN
 315          ;;     (br L2)
 316          ;; L1: ELSE
 317          ;; L2:
 318          (let ((L1 (make-label)) (L2 (make-label)))
 319            (comp-push test)
 320            (push-branch! loc 'br-if-not L1)
 321            (comp-tail then)
 322            (if (not tail) (push-branch! #f 'br L2))
 323            (push-label! L1)
 324            (comp-tail else)
 325            (if (not tail) (push-label! L2))))
 326
 327         ((<ghil-and> env loc exps)
 328          ;;     EXP
 329          ;;     (br-if-not L1)
 330          ;;     ...
 331          ;;     TAIL
 332          ;;     (br L2)
 333          ;; L1: (const #f)
 334          ;; L2:
 335          (cond ((null? exps) (return-object! loc #t))
 336                ((null? (cdr exps)) (comp-tail (car exps)))
 337                (else
 338                 (let ((L1 (make-label)) (L2 (make-label)))
 339                   (let lp ((exps exps))
 340                     (cond ((null? (cdr exps))
 341                            (comp-tail (car exps))
 342                            (push-branch! #f 'br L2)
 343                            (push-label! L1)
 344                            (return-object! #f #f)
 345                            (push-label! L2)
 346                            (maybe-return))
 347                           (else
 348                            (comp-push (car exps))
 349                            (push-branch! #f 'br-if-not L1)
 350                            (lp (cdr exps)))))))))
 351
 352         ((<ghil-or> env loc exps)
 353          ;;     EXP
 354          ;;     (dup)
 355          ;;     (br-if L1)
 356          ;;     (drop)
 357          ;;     ...
 358          ;;     TAIL
 359          ;; L1:
 360          (cond ((null? exps) (return-object! loc #f))
 361                ((null? (cdr exps)) (comp-tail (car exps)))
 362                (else
 363                 (let ((L1 (make-label)))
 364                   (let lp ((exps exps))
 365                     (cond ((null? (cdr exps))
 366                            (comp-tail (car exps))
 367                            (push-label! L1)
 368                            (maybe-return))
 369                           (else
 370                            (comp-push (car exps))
 371                            (if (not drop)
 372                                (push-call! #f 'dup '()))
 373                            (push-branch! #f 'br-if L1)
 374                            (if (not drop)
 375                                (push-code! loc (make-glil-call 'drop 1)))
 376                            (lp (cdr exps)))))))))
 377
 378         ((<ghil-begin> env loc exps)
 379          ;; EXPS...
 380          ;; TAIL
 381          (if (null? exps)
 382              (return-void!)
 383              (do ((exps exps (cdr exps)))
 384                  ((null? (cdr exps))
 385                   (comp-tail (car exps)))
 386                (comp-drop (car exps)))))
 387
 388         ((<ghil-bind> env loc vars vals body)
 389          ;; VALS...
 390          ;; (set VARS)...
 391          ;; BODY
 392          (for-each comp-push vals)
 393          (push-bindings! loc vars)
 394          (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
 395                    (reverse vars))
 396          (comp-tail body)
 397          (push-code! #f (make-glil-unbind)))
 398
 399         ((<ghil-mv-bind> env loc producer vars rest body)
 400          ;; VALS...
 401          ;; (set VARS)...
 402          ;; BODY
 403          (let ((MV (make-label)))
 404            (comp-push producer)
 405            (push-code! loc (make-glil-mv-call 0 MV))
 406            (push-code! #f (make-glil-const 1))
 407            (push-label! MV)
 408            (push-code! #f (make-glil-mv-bind (map var->binding vars) rest))
 409            (for-each (lambda (var) (push-code! #f (make-glil-var 'set env var)))
 410                      (reverse vars)))
 411          (comp-tail body)
 412          (push-code! #f (make-glil-unbind)))
 413
 414         ((<ghil-lambda> env loc vars rest meta body)
 415          (return-code! loc (codegen tree)))
 416
 417         ((<ghil-inline> env loc inline args)
 418          ;; ARGS...
 419          ;; (INST NARGS)
 420          (let ((tail-table '((call . goto/args)
 421                              (apply . goto/apply)
 422                              (call/cc . goto/cc))))
 423            (cond ((and tail (assq-ref tail-table inline))
 424                   => (lambda (tail-inst)
 425                        (push-call! loc tail-inst args)))
 426                  (else
 427                   (push-call! loc inline args)
 428                   (maybe-drop)
 429                   (maybe-return)))))
 430
 431         ((<ghil-values> env loc values)
 432          (cond (tail ;; (lambda () (values 1 2))
 433                 (push-call! loc 'return/values values))
 434                (drop ;; (lambda () (values 1 2) 3)
 435                 (for-each comp-drop values))
 436                (else ;; (lambda () (list (values 10 12) 1))
 437                 (push-code! #f (make-glil-const 'values))
 438                 (push-code! #f (make-glil-call 'link-now 1))
 439                 (push-code! #f (make-glil-call 'variable-ref 0))
 440                 (push-call! loc 'call values))))
 441
 442         ((<ghil-values*> env loc values)
 443          (cond (tail ;; (lambda () (apply values '(1 2)))
 444                 (push-call! loc 'return/values* values))
 445                (drop ;; (lambda () (apply values '(1 2)) 3)
 446                 (for-each comp-drop values))
 447                (else ;; (lambda () (list (apply values '(10 12)) 1))
 448                 (push-code! #f (make-glil-const 'values))
 449                 (push-code! #f (make-glil-call 'link-now 1))
 450                 (push-code! #f (make-glil-call 'variable-ref 0))
 451                 (push-call! loc 'apply values))))
 452
 453         ((<ghil-call> env loc proc args)
 454          ;; PROC
 455          ;; ARGS...
 456          ;; ([tail-]call NARGS)
 457          (comp-push proc)
 458          (let ((nargs (length args)))
 459            (cond ((< nargs 255)
 460                   (push-call! loc (if tail 'goto/args 'call) args))
 461                  (else
 462                   (push-call! loc 'mark '())
 463                   (for-each comp-push args)
 464                   (push-call! loc 'list-mark '())
 465                   (push-code! loc (make-glil-call (if tail 'goto/apply 'apply) 2)))))
 466          (maybe-drop))
 467
 468         ((<ghil-mv-call> env loc producer consumer)
 469          ;; CONSUMER
 470          ;; PRODUCER
 471          ;; (mv-call MV)
 472          ;; ([tail]-call 1)
 473          ;; goto POST
 474          ;; MV: [tail-]call/nargs
 475          ;; POST: (maybe-drop)
 476          (let ((MV (make-label)) (POST (make-label)))
 477            (comp-push consumer)
 478            (comp-push producer)
 479            (push-code! loc (make-glil-mv-call 0 MV))
 480            (push-code! loc (make-glil-call (if tail 'goto/args 'call) 1))
 481            (cond ((not tail)
 482                   (push-branch! #f 'br POST)))
 483            (push-label! MV)
 484            (push-code! loc (make-glil-call (if tail 'goto/nargs 'call/nargs) 0))
 485            (cond ((not tail)
 486                   (push-label! POST)
 487                   (maybe-drop)))))
 488
 489         ((<ghil-reified-env> env loc)
 490          (return-object! loc (ghil-env-reify env)))))
 491
 492     ;;
 493     ;; main
 494     (record-case ghil
 495       ((<ghil-lambda> env loc vars rest meta body)
 496        (let* ((evars (ghil-env-variables env))
 497               (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
 498               (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
 499               (nargs (allocate-indices-linearly! vars))
 500               (nlocs (allocate-locals! locs body nargs))
 501               (nexts (allocate-indices-linearly! exts)))
 502          ;; meta bindings
 503          (push-bindings! #f vars)
 504          ;; push on definition source location
 505          (if loc (set! stack (cons (make-glil-source loc) stack)))
 506          ;; copy args to the heap if they're marked as external
 507          (do ((n 0 (1+ n))
 508               (l vars (cdr l)))
 509              ((null? l))
 510            (let ((v (car l)))
 511              (case (ghil-var-kind v)
 512                ((external)
 513                 (push-code! #f (make-glil-local 'ref n))
 514                 (push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
 515          ;; compile body
 516          (comp body #t #f)
 517          ;; create GLIL
 518          (make-glil-program nargs (if rest 1 0) nlocs nexts meta
 519                             (reverse! stack)))))))
 520
 521 (define (allocate-indices-linearly! vars)
 522   (do ((n 0 (1+ n))
 523        (l vars (cdr l)))
 524       ((null? l) n)
 525     (let ((v (car l))) (set! (ghil-var-index v) n))))
 526
 527 (define (allocate-locals! vars body nargs)
 528   (let ((free '()) (nlocs nargs))
 529     (define (allocate! var)
 530       (cond
 531        ((pair? free)
 532         (set! (ghil-var-index var) (car free))
 533         (set! free (cdr free)))
 534        (else
 535         (set! (ghil-var-index var) nlocs)
 536         (set! nlocs (1+ nlocs)))))
 537     (define (deallocate! var)
 538       (set! free (cons (ghil-var-index var) free)))
 539     (let lp ((x body))
 540       (record-case x
 541         ((<ghil-void>))
 542         ((<ghil-quote>))
 543         ((<ghil-quasiquote> exp)
 544          (let qlp ((x exp))
 545            (cond ((list? x) (for-each qlp x))
 546                  ((pair? x) (qlp (car x)) (qlp (cdr x)))
 547                  ((record? x)
 548                   (record-case x
 549                    ((<ghil-unquote> exp) (lp exp))
 550                    ((<ghil-unquote-splicing> exp) (lp exp)))))))
 551         ((<ghil-unquote> exp)
 552          (lp exp))
 553         ((<ghil-unquote-splicing> exp)
 554          (lp exp))
 555         ((<ghil-reified-env>))
 556         ((<ghil-set> val)
 557          (lp val))
 558         ((<ghil-ref>))
 559         ((<ghil-define> val)
 560          (lp val))
 561         ((<ghil-if> test then else)
 562          (lp test) (lp then) (lp else))
 563         ((<ghil-and> exps)
 564          (for-each lp exps))
 565         ((<ghil-or> exps)
 566          (for-each lp exps))
 567         ((<ghil-begin> exps)
 568          (for-each lp exps))
 569         ((<ghil-bind> vars vals body)
 570          (for-each allocate! vars)
 571          (for-each lp vals)
 572          (lp body)
 573          (for-each deallocate! vars))
 574         ((<ghil-mv-bind> vars producer body)
 575          (lp producer)
 576          (for-each allocate! vars)
 577          (lp body)
 578          (for-each deallocate! vars))
 579         ((<ghil-inline> args)
 580          (for-each lp args))
 581         ((<ghil-call> proc args)
 582          (lp proc)
 583          (for-each lp args))
 584         ((<ghil-lambda>))
 585         ((<ghil-mv-call> producer consumer)
 586          (lp producer)
 587          (lp consumer))
 588         ((<ghil-values> values)
 589          (for-each lp values))
 590         ((<ghil-values*> values)
 591          (for-each lp values))))
 592     nlocs))