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