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