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           (($ $prompt escape? tag handler)
 195            (emit-prompt asm escape? tag handler)))
 196         (maybe-jump k)))
 197
 198     (define (emit-vals syms)
 199       (match exp
 200         (($ $primcall name args)
 201          (error "unimplemented primcall in values context" name))
 202         (($ $values args)
 203          (for-each (match-lambda
 204                     ((src . dst) (emit-mov asm dst src)))
 205                    (lookup-parallel-moves label allocation))
 206          (for-each maybe-load-constant (map slot syms) args)))
 207       (maybe-jump k))
 208
 209     (define (emit-seq)
 210       (match exp
 211         (($ $primcall 'cache-current-module! (sym scope))
 212          (emit-cache-current-module! asm (slot sym) (constant scope)))
 213         (($ $primcall 'free-set! (closure idx value))
 214          (emit-free-set! asm (slot closure) (slot value) (constant idx)))
 215         (($ $primcall 'box-set! (box value))
 216          (emit-box-set! asm (slot box) (slot value)))
 217         (($ $primcall 'struct-set! (struct index value))
 218          (emit-struct-set! asm (slot struct) (slot index) (slot value)))
 219         (($ $primcall 'vector-set! (vector index value))
 220          (emit-vector-set asm (slot vector) (slot index) (slot value)))
 221         (($ $primcall 'set-car! (pair value))
 222          (emit-set-car! asm (slot pair) (slot value)))
 223         (($ $primcall 'set-cdr! (pair value))
 224          (emit-set-cdr! asm (slot pair) (slot value)))
 225         (($ $primcall 'define! (sym value))
 226          (emit-define asm (slot sym) (slot value)))
 227         (($ $primcall name args)
 228          (error "unhandled primcall in seq context" name))
 229         (($ $values ()) #f))
 230       (maybe-jump k))
 231
 232     (define (emit-test kt kf)
 233       (define (unary op sym)
 234         (cond
 235          ((eq? kt next-label)
 236           (op asm (slot sym) #t kf))
 237          (else
 238           (op asm (slot sym) #f kt)
 239           (maybe-jump kf))))
 240       (define (binary op a b)
 241         (cond
 242          ((eq? kt next-label)
 243           (op asm (slot a) (slot b) #t kf))
 244          (else
 245           (op asm (slot a) (slot b) #f kt)
 246           (maybe-jump kf))))
 247       (match exp
 248         (($ $var sym) (unary emit-br-if-true sym))
 249         (($ $primcall 'null? (a)) (unary emit-br-if-null a))
 250         (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
 251         (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
 252         (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
 253         (($ $primcall 'char? (a)) (unary emit-br-if-char a))
 254         ;; Add TC7 tests here
 255         (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
 256         (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
 257         (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
 258         (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
 259         (($ $primcall '< (a b)) (binary emit-br-if-< a b))
 260         (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
 261         (($ $primcall '= (a b)) (binary emit-br-if-= a b))
 262         (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
 263         (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
 264
 265     (define (emit-trunc nreq rest? k)
 266       (match exp
 267         (($ $call proc args)
 268          (let ((proc-slot (lookup-call-proc-slot label allocation))
 269                (nargs (length args)))
 270            (or (maybe-load-constant proc-slot proc)
 271                (maybe-mov proc-slot (slot proc)))
 272            (let lp ((n (1+ proc-slot)) (args args))
 273              (match args
 274                (()
 275                 (emit-call asm proc-slot (+ nargs 1))
 276                 ;; FIXME: Only allow more values if there is a rest arg.
 277                 ;; Express values truncation by the presence of an
 278                 ;; unused rest arg instead of implicitly.
 279                 (emit-receive-values asm proc-slot #t nreq)
 280                 (when rest?
 281                   (emit-bind-rest asm (+ proc-slot 1 nreq)))
 282                 (for-each (match-lambda
 283                            ((src . dst) (emit-mov asm dst src)))
 284                           (lookup-parallel-moves label allocation))
 285                 (emit-reset-frame asm nlocals))
 286                ((arg . args)
 287                 (or (maybe-load-constant n arg)
 288                     (maybe-mov n (slot arg)))
 289                 (lp (1+ n) args)))))))
 290       (maybe-jump k))
 291
 292     (match (lookup-cont k cont-table)
 293       (($ $ktail) (emit-tail))
 294       (($ $kargs (name) (sym)) (emit-val sym))
 295       (($ $kargs () ()) (emit-seq))
 296       (($ $kargs names syms) (emit-vals syms))
 297       (($ $kargs (name) (sym)) (emit-val sym))
 298       (($ $kif kt kf) (emit-test kt kf))
 299       (($ $ktrunc ($ $arity req () rest () #f) k)
 300        (emit-trunc (length req) (and rest #t) k))))
 301
 302   (define (collect-exps k src cont tail)
 303     (define (find-exp k src term)
 304       (match term
 305         (($ $continue exp-k exp)
 306          (cons (list k src exp-k exp) tail))
 307         (($ $letk conts body)
 308          (find-exp k src body))))
 309     (match cont
 310       (($ $kargs names syms body)
 311        (find-exp k src body))
 312       (_ tail)))
 313
 314   (let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
 315     (match exps
 316       (() #t)
 317       (((k src exp-k exp) . exps)
 318        (let ((next-label (match exps
 319                            (((k . _) . _) k)
 320                            (() #f))))
 321          (emit-label asm k)
 322          (when src
 323            (emit-source asm src))
 324          (emit-rtl k exp-k exp next-label)
 325          (lp exps))))))
 326
 327 (define (compile-fun f asm)
 328   (let ((allocation (allocate-slots f))
 329         (cont-table (match f
 330                       (($ $fun meta free body)
 331                        (build-local-cont-table body)))))
 332     (define (emit-fun-clause clause alternate)
 333       (match clause
 334         (($ $cont k src
 335             ($ $kclause ($ $arity req opt rest kw allow-other-keys?)
 336                body))
 337          (let ((kw-indices (map (match-lambda
 338                                  ((key name sym)
 339                                   (cons key (lookup-slot sym allocation))))
 340                                 kw))
 341                (nlocals (lookup-nlocals k allocation)))
 342            (emit-label asm k)
 343            (when src
 344              (emit-source asm src))
 345            (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
 346                                 nlocals alternate)
 347            (emit-rtl-sequence asm body allocation nlocals cont-table)
 348            (emit-end-arity asm)))))
 349
 350     (define (emit-fun-clauses clauses)
 351       (match clauses
 352         ((clause . clauses)
 353          (let ((kalternate (match clauses
 354                              (() #f)
 355                              ((($ $cont k) . _) k))))
 356            (emit-fun-clause clause kalternate)
 357            (when kalternate
 358              (emit-fun-clauses clauses))))))
 359
 360     (match f
 361       (($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
 362        (emit-begin-program asm k (or meta '()))
 363        (when src
 364          (emit-source asm src))
 365        (emit-fun-clauses clauses)
 366        (emit-end-program asm)))))
 367
 368 (define (compile-rtl exp env opts)
 369   (let* ((exp (fix-arities exp))
 370          (exp (optimize exp opts))
 371          (exp (convert-closures exp))
 372          (exp (reify-primitives exp))
 373          (asm (make-assembler)))
 374     (visit-funs (lambda (fun)
 375                   (compile-fun fun asm))
 376                 exp)
 377     (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
 378             env
 379             env)))