module/language/cps/compile-rtl.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013 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 ;;; Commentary:
  20 ;;;
  21 ;;; Compiling CPS to RTL.  The result is in the RTL language, which
  22 ;;; happens to be an ELF image as a bytecode.
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps compile-rtl)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (language cps)
  30   #:use-module (language cps arities)
  31   #:use-module (language cps closure-conversion)
  32   #:use-module (language cps contification)
  33   #:use-module (language cps constructors)
  34   #:use-module (language cps dfg)
  35   #:use-module (language cps elide-values)
  36   #:use-module (language cps primitives)
  37   #:use-module (language cps reify-primitives)
  38   #:use-module (language cps slot-allocation)
  39   #:use-module (system vm assembler)
  40   #:export (compile-rtl))
  41
  42 ;; TODO: Source info, local var names.  Needs work in the linker and the
  43 ;; debugger.
  44
  45 (define (kw-arg-ref args kw default)
  46   (match (memq kw args)
  47     ((_ val . _) val)
  48     (_ default)))
  49
  50 (define (optimize exp opts)
  51   (define (run-pass exp pass kw default)
  52     (if (kw-arg-ref opts kw default)
  53         (pass exp)
  54         exp))
  55
  56   ;; Calls to source-to-source optimization passes go here.
  57   (let* ((exp (run-pass exp contify #:contify? #t))
  58          (exp (run-pass exp inline-constructors #:inline-constructors? #t))
  59          (exp (run-pass exp elide-values #:elide-values? #t)))
  60     ;; Passes that are needed:
  61     ;;
  62     ;;  * Abort contification: turning abort primcalls into continuation
  63     ;;    calls, and eliding prompts if possible.
  64     ;;
  65     ;;  * Common subexpression elimination.  Desperately needed.  Requires
  66     ;;    effects analysis.
  67     ;;
  68     ;;  * Loop peeling.  Unrolls the first round through a loop if the
  69     ;;    loop has effects that CSE can work on.  Requires effects
  70     ;;    analysis.  When run before CSE, loop peeling is the equivalent
  71     ;;    of loop-invariant code motion (LICM).
  72     ;;
  73     ;;  * Generic simplification pass, to be run as needed.  Used to
  74     ;;    "clean up", both on the original raw input and after specific
  75     ;;    optimization passes.
  76
  77     exp))
  78
  79 (define (visit-funs proc exp)
  80   (match exp
  81     (($ $continue _ exp)
  82      (visit-funs proc exp))
  83
  84     (($ $fun meta free body)
  85      (proc exp)
  86      (visit-funs proc body))
  87
  88     (($ $letk conts body)
  89      (visit-funs proc body)
  90      (for-each (lambda (cont) (visit-funs proc cont)) conts))
  91
  92     (($ $cont sym src ($ $kargs names syms body))
  93      (visit-funs proc body))
  94
  95     (($ $cont sym src ($ $kclause arity body))
  96      (visit-funs proc body))
  97
  98     (($ $cont sym src ($ $kentry self tail clauses))
  99      (for-each (lambda (clause) (visit-funs proc clause)) clauses))
 100
 101     (_ (values))))
 102
 103 (define (emit-rtl-sequence asm exp allocation nlocals cont-table)
 104   (define (immediate-u8? val)
 105     (and (integer? val) (exact? val) (<= 0 val 255)))
 106
 107   (define (maybe-immediate-u8 sym)
 108     (call-with-values (lambda ()
 109                         (lookup-maybe-constant-value sym allocation))
 110       (lambda (has-const? val)
 111         (and has-const? (immediate-u8? val) val))))
 112
 113   (define (slot sym)
 114     (lookup-slot sym allocation))
 115
 116   (define (constant sym)
 117     (lookup-constant-value sym allocation))
 118
 119   (define (emit-rtl label k exp next-label)
 120     (define (maybe-mov dst src)
 121       (unless (= dst src)
 122         (emit-mov asm dst src)))
 123
 124     (define (maybe-jump label)
 125       (unless (eq? label next-label)
 126         (emit-br asm label)))
 127
 128     (define (maybe-load-constant slot src)
 129       (call-with-values (lambda ()
 130                           (lookup-maybe-constant-value src allocation))
 131         (lambda (has-const? val)
 132           (and has-const?
 133                (begin
 134                  (emit-load-constant asm slot val)
 135                  #t)))))
 136
 137     (define (emit-tail)
 138       ;; There are only three kinds of expressions in tail position:
 139       ;; tail calls, multiple-value returns, and single-value returns.
 140       (match exp
 141         (($ $call proc args)
 142          (for-each (match-lambda
 143                     ((src . dst) (emit-mov asm dst src)))
 144                    (lookup-parallel-moves label allocation))
 145          (let ((tail-slots (cdr (iota (1+ (length args))))))
 146            (for-each maybe-load-constant tail-slots args))
 147          (emit-tail-call asm (1+ (length args))))
 148         (($ $values args)
 149          (let ((tail-slots (cdr (iota (1+ (length args))))))
 150            (for-each (match-lambda
 151                       ((src . dst) (emit-mov asm dst src)))
 152                      (lookup-parallel-moves label allocation))
 153            (for-each maybe-load-constant tail-slots args))
 154          (emit-reset-frame asm (1+ (length args)))
 155          (emit-return-values asm))
 156         (($ $primcall 'return (arg))
 157          (emit-return asm (slot arg)))))
 158
 159     (define (emit-val sym)
 160       (let ((dst (slot sym)))
 161         (match exp
 162           (($ $var sym)
 163            (maybe-mov dst (slot sym)))
 164           (($ $void)
 165            (when dst
 166              (emit-load-constant asm dst *unspecified*)))
 167           (($ $const exp)
 168            (when dst
 169              (emit-load-constant asm dst exp)))
 170           (($ $fun meta () ($ $cont k))
 171            (emit-load-static-procedure asm dst k))
 172           (($ $fun meta free ($ $cont k))
 173            (emit-make-closure asm dst k (length free)))
 174           (($ $call proc args)
 175            (let ((proc-slot (lookup-call-proc-slot label allocation))
 176                  (nargs (length args)))
 177              (or (maybe-load-constant proc-slot proc)
 178                  (maybe-mov proc-slot (slot proc)))
 179              (let lp ((n (1+ proc-slot)) (args args))
 180                (match args
 181                  (()
 182                   (emit-call asm proc-slot (+ nargs 1))
 183                   (emit-receive asm dst proc-slot nlocals))
 184                  ((arg . args)
 185                   (or (maybe-load-constant n arg)
 186                       (maybe-mov n (slot arg)))
 187                   (lp (1+ n) args))))))
 188           (($ $primcall 'current-module)
 189            (emit-current-module asm dst))
 190           (($ $primcall 'cached-toplevel-box (scope name bound?))
 191            (emit-cached-toplevel-box asm dst (constant scope) (constant name)
 192                                      (constant bound?)))
 193           (($ $primcall 'cached-module-box (mod name public? bound?))
 194            (emit-cached-module-box asm dst (constant mod) (constant name)
 195                                    (constant public?) (constant bound?)))
 196           (($ $primcall 'resolve (name bound?))
 197            (emit-resolve asm dst (constant bound?) (slot name)))
 198           (($ $primcall 'free-ref (closure idx))
 199            (emit-free-ref asm dst (slot closure) (constant idx)))
 200           (($ $primcall 'make-vector (length init))
 201            (cond
 202             ((maybe-immediate-u8 length)
 203              => (lambda (length)
 204                   (emit-constant-make-vector asm dst length (slot init))))
 205             (else
 206              (emit-make-vector asm dst (slot length) (slot init)))))
 207           (($ $primcall 'vector-ref (vector index))
 208            (cond
 209             ((maybe-immediate-u8 index)
 210              => (lambda (index)
 211                   (emit-constant-vector-ref asm dst (slot vector) index)))
 212             (else
 213              (emit-vector-ref asm dst (slot vector) (slot index)))))
 214           (($ $primcall name args)
 215            ;; FIXME: Inline all the cases.
 216            (let ((inst (prim-rtl-instruction name)))
 217              (emit-text asm `((,inst ,dst ,@(map slot args))))))
 218           (($ $values (arg))
 219            (or (maybe-load-constant dst arg)
 220                (maybe-mov dst (slot arg)))))
 221         (maybe-jump k)))
 222
 223     (define (emit-vals syms)
 224       (match exp
 225         (($ $primcall name args)
 226          (error "unimplemented primcall in values context" name))
 227         (($ $values args)
 228          (for-each (match-lambda
 229                     ((src . dst) (emit-mov asm dst src)))
 230                    (lookup-parallel-moves label allocation))
 231          (for-each maybe-load-constant (map slot syms) args)))
 232       (maybe-jump k))
 233
 234     (define (emit-seq)
 235       (match exp
 236         (($ $primcall 'cache-current-module! (sym scope))
 237          (emit-cache-current-module! asm (slot sym) (constant scope)))
 238         (($ $primcall 'free-set! (closure idx value))
 239          (emit-free-set! asm (slot closure) (slot value) (constant idx)))
 240         (($ $primcall 'box-set! (box value))
 241          (emit-box-set! asm (slot box) (slot value)))
 242         (($ $primcall 'struct-set! (struct index value))
 243          (emit-struct-set! asm (slot struct) (slot index) (slot value)))
 244         (($ $primcall 'vector-set! (vector index value))
 245          (call-with-values (lambda ()
 246                              (lookup-maybe-constant-value index allocation))
 247            (lambda (has-const? index-val)
 248              (if (and has-const? (integer? index-val) (exact? index-val)
 249                       (<= 0 index-val 255))
 250                  (emit-constant-vector-set! asm (slot vector) index-val
 251                                             (slot value))
 252                  (emit-vector-set! asm (slot vector) (slot index)
 253                                    (slot value))))))
 254         (($ $primcall 'variable-set! (var val))
 255          (emit-box-set! asm (slot var) (slot val)))
 256         (($ $primcall 'set-car! (pair value))
 257          (emit-set-car! asm (slot pair) (slot value)))
 258         (($ $primcall 'set-cdr! (pair value))
 259          (emit-set-cdr! asm (slot pair) (slot value)))
 260         (($ $primcall 'define! (sym value))
 261          (emit-define asm (slot sym) (slot value)))
 262         (($ $primcall 'push-fluid (fluid val))
 263          (emit-push-fluid asm (slot fluid) (slot val)))
 264         (($ $primcall 'pop-fluid ())
 265          (emit-pop-fluid asm))
 266         (($ $primcall 'wind (winder unwinder))
 267          (emit-wind asm (slot winder) (slot unwinder)))
 268         (($ $primcall 'unwind ())
 269          (emit-unwind asm))
 270         (($ $primcall name args)
 271          (error "unhandled primcall in seq context" name))
 272         (($ $values ()) #f)
 273         (($ $prompt escape? tag handler)
 274          (match (lookup-cont handler cont-table)
 275            (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
 276             (let ((receive-args (gensym "handler"))
 277                   (nreq (length req))
 278                   (proc-slot (lookup-call-proc-slot label allocation)))
 279               (emit-prompt asm (slot tag) escape? proc-slot receive-args)
 280               (emit-br asm k)
 281               (emit-label asm receive-args)
 282               (emit-receive-values asm proc-slot (->bool rest) nreq)
 283               (when rest
 284                 (emit-bind-rest asm (+ proc-slot 1 nreq)))
 285               (for-each (match-lambda
 286                          ((src . dst) (emit-mov asm dst src)))
 287                         (lookup-parallel-moves handler allocation))
 288               (emit-reset-frame asm nlocals)
 289               (emit-br asm khandler-body))))))
 290       (maybe-jump k))
 291
 292     (define (emit-test kt kf)
 293       (define (unary op sym)
 294         (cond
 295          ((eq? kt next-label)
 296           (op asm (slot sym) #t kf))
 297          (else
 298           (op asm (slot sym) #f kt)
 299           (maybe-jump kf))))
 300       (define (binary op a b)
 301         (cond
 302          ((eq? kt next-label)
 303           (op asm (slot a) (slot b) #t kf))
 304          (else
 305           (op asm (slot a) (slot b) #f kt)
 306           (maybe-jump kf))))
 307       (match exp
 308         (($ $var sym) (unary emit-br-if-true sym))
 309         (($ $primcall 'null? (a)) (unary emit-br-if-null a))
 310         (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
 311         (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
 312         (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
 313         (($ $primcall 'char? (a)) (unary emit-br-if-char a))
 314         (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
 315         (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
 316         (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
 317         (($ $primcall 'string? (a)) (unary emit-br-if-string a))
 318         ;; Add more TC7 tests here.  Keep in sync with
 319         ;; *branching-primcall-arities* in (language cps primitives) and
 320         ;; the set of macro-instructions in assembly.scm.
 321         (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
 322         (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
 323         (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
 324         (($ $primcall '< (a b)) (binary emit-br-if-< a b))
 325         (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
 326         (($ $primcall '= (a b)) (binary emit-br-if-= a b))
 327         (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
 328         (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
 329
 330     (define (emit-trunc nreq rest? k)
 331       (match exp
 332         (($ $call proc args)
 333          (let ((proc-slot (lookup-call-proc-slot label allocation))
 334                (nargs (length args)))
 335            (or (maybe-load-constant proc-slot proc)
 336                (maybe-mov proc-slot (slot proc)))
 337            (let lp ((n (1+ proc-slot)) (args args))
 338              (match args
 339                (()
 340                 (emit-call asm proc-slot (+ nargs 1))
 341                 ;; FIXME: Only allow more values if there is a rest arg.
 342                 ;; Express values truncation by the presence of an
 343                 ;; unused rest arg instead of implicitly.
 344                 (emit-receive-values asm proc-slot #t nreq)
 345                 (when rest?
 346                   (emit-bind-rest asm (+ proc-slot 1 nreq)))
 347                 (for-each (match-lambda
 348                            ((src . dst) (emit-mov asm dst src)))
 349                           (lookup-parallel-moves label allocation))
 350                 (emit-reset-frame asm nlocals))
 351                ((arg . args)
 352                 (or (maybe-load-constant n arg)
 353                     (maybe-mov n (slot arg)))
 354                 (lp (1+ n) args)))))))
 355       (maybe-jump k))
 356
 357     (match (lookup-cont k cont-table)
 358       (($ $ktail) (emit-tail))
 359       (($ $kargs (name) (sym)) (emit-val sym))
 360       (($ $kargs () ()) (emit-seq))
 361       (($ $kargs names syms) (emit-vals syms))
 362       (($ $kargs (name) (sym)) (emit-val sym))
 363       (($ $kif kt kf) (emit-test kt kf))
 364       (($ $ktrunc ($ $arity req () rest () #f) k)
 365        (emit-trunc (length req) (and rest #t) k))))
 366
 367   (define (collect-exps k src cont tail)
 368     (define (find-exp k src term)
 369       (match term
 370         (($ $continue exp-k exp)
 371          (cons (list k src exp-k exp) tail))
 372         (($ $letk conts body)
 373          (find-exp k src body))))
 374     (match cont
 375       (($ $kargs names syms body)
 376        (find-exp k src body))
 377       (_ tail)))
 378
 379   (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
 380     (match exps
 381       (() #t)
 382       (((k src exp-k exp) . exps)
 383        (let ((next-label (match exps
 384                            (((k . _) . _) k)
 385                            (() #f))))
 386          (emit-label asm k)
 387          (when src
 388            (emit-source asm src))
 389          (emit-rtl k exp-k exp next-label)
 390          (lp exps))))))
 391
 392 (define (compile-fun f asm)
 393   (let ((allocation (allocate-slots f))
 394         (cont-table (match f
 395                       (($ $fun meta free body)
 396                        (build-local-cont-table body)))))
 397     (define (emit-fun-clause clause alternate)
 398       (match clause
 399         (($ $cont k src
 400             ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
 401                body))
 402          (let ((kw-indices (map (match-lambda
 403                                  ((key name sym)
 404                                   (cons key (lookup-slot sym allocation))))
 405                                 kw))
 406                (nlocals (lookup-nlocals k allocation)))
 407            (emit-label asm k)
 408            (when src
 409              (emit-source asm src))
 410            (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
 411                                 nlocals alternate)
 412            (emit-rtl-sequence asm body allocation nlocals cont-table)
 413            (emit-end-arity asm)))))
 414
 415     (define (emit-fun-clauses clauses)
 416       (match clauses
 417         ((clause . clauses)
 418          (let ((kalternate (match clauses
 419                              (() #f)
 420                              ((($ $cont k) . _) k))))
 421            (emit-fun-clause clause kalternate)
 422            (when kalternate
 423              (emit-fun-clauses clauses))))))
 424
 425     (match f
 426       (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
 427        (emit-begin-program asm k (or meta '()))
 428        (when src
 429          (emit-source asm src))
 430        (emit-fun-clauses clauses)
 431        (emit-end-program asm)))))
 432
 433 (define (compile-rtl exp env opts)
 434   (let* ((exp (fix-arities exp))
 435          (exp (optimize exp opts))
 436          (exp (convert-closures exp))
 437          (exp (reify-primitives exp))
 438          (asm (make-assembler)))
 439     (visit-funs (lambda (fun)
 440                   (compile-fun fun asm))
 441                 exp)
 442     (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
 443             env
 444             env)))