;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (language cps closure-conversion)
#:use-module (language cps contification)
#:use-module (language cps constructors)
+ #:use-module (language cps cse)
+ #:use-module (language cps dce)
#:use-module (language cps dfg)
#:use-module (language cps elide-values)
#:use-module (language cps primitives)
+ #:use-module (language cps prune-bailouts)
+ #:use-module (language cps prune-top-level-scopes)
#:use-module (language cps reify-primitives)
+ #:use-module (language cps renumber)
+ #:use-module (language cps self-references)
+ #:use-module (language cps simplify)
#:use-module (language cps slot-allocation)
#:use-module (language cps specialize-primcalls)
+ #:use-module (language cps type-fold)
#:use-module (system vm assembler)
#:export (compile-bytecode))
(pass exp)
exp))
- ;; Calls to source-to-source optimization passes go here.
- (let* ((exp (run-pass exp contify #:contify? #t))
+ ;; The first DCE pass is mainly to eliminate functions that aren't
+ ;; called. The last is mainly to eliminate rest parameters that
+ ;; aren't used, and thus shouldn't be consed.
+
+ (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+ (exp (run-pass exp prune-top-level-scopes #:prune-top-level-scopes? #t))
+ (exp (run-pass exp simplify #:simplify? #t))
+ (exp (run-pass exp contify #:contify? #t))
(exp (run-pass exp inline-constructors #:inline-constructors? #t))
(exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
- (exp (run-pass exp elide-values #:elide-values? #t)))
+ (exp (run-pass exp elide-values #:elide-values? #t))
+ (exp (run-pass exp prune-bailouts #:prune-bailouts? #t))
+ (exp (run-pass exp eliminate-common-subexpressions #:cse? #t))
+ (exp (run-pass exp type-fold #:type-fold? #t))
+ (exp (run-pass exp resolve-self-references #:resolve-self-references? #t))
+ (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
+ (exp (run-pass exp simplify #:simplify? #t)))
;; Passes that are needed:
;;
;; * Abort contification: turning abort primcalls into continuation
;; calls, and eliding prompts if possible.
;;
- ;; * Common subexpression elimination. Desperately needed. Requires
- ;; effects analysis.
- ;;
;; * Loop peeling. Unrolls the first round through a loop if the
;; loop has effects that CSE can work on. Requires effects
;; analysis. When run before CSE, loop peeling is the equivalent
;; of loop-invariant code motion (LICM).
- ;;
- ;; * Generic simplification pass, to be run as needed. Used to
- ;; "clean up", both on the original raw input and after specific
- ;; optimization passes.
exp))
-(define (collect-conts f cfa)
- (let ((contv (make-vector (cfa-k-count cfa) #f)))
- (fold-local-conts
- (lambda (k cont tail)
- (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
- (when idx
- (vector-set! contv idx cont))))
- '()
- (match f
- (($ $fun src meta free entry)
- entry)))
- contv))
-
(define (compile-fun f asm)
(let* ((dfg (compute-dfg f #:global? #f))
- (cfa (analyze-control-flow f dfg))
- (allocation (allocate-slots f dfg))
- (contv (collect-conts f cfa)))
- (define (lookup-cont k)
- (vector-ref contv (cfa-k-idx cfa k)))
-
+ (allocation (allocate-slots f dfg)))
(define (maybe-slot sym)
(lookup-maybe-slot sym allocation))
(emit-load-constant asm slot val)
#t)))))
- (define (compile-entry meta)
- (match (vector-ref contv 0)
- (($ $kentry self tail clauses)
- (emit-begin-program asm (cfa-k-sym cfa 0) meta)
- (let lp ((n 1)
- (ks (map (match-lambda (($ $cont k) k)) clauses)))
- (match ks
- (()
- (unless (= n (vector-length contv))
- (error "unexpected end of clauses"))
- (emit-end-program asm))
- ((k . ks)
- (unless (eq? (cfa-k-sym cfa n) k)
- (error "unexpected k" k))
- (lp (compile-clause n (and (pair? ks) (car ks)))
- ks)))))))
-
- (define (compile-clause n alternate)
- (match (vector-ref contv n)
- (($ $kclause ($ $arity req opt rest kw allow-other-keys?))
+ (define (compile-entry)
+ (let ((label (dfg-min-label dfg)))
+ (match (lookup-cont label dfg)
+ (($ $kfun src meta self tail clause)
+ (when src
+ (emit-source asm src))
+ (emit-begin-program asm label meta)
+ (compile-clause (1+ label))
+ (emit-end-program asm)))))
+
+ (define (compile-clause label)
+ (match (lookup-cont label dfg)
+ (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
+ body alternate)
(let* ((kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
kw))
- (k (cfa-k-sym cfa n))
- (nlocals (lookup-nlocals k allocation)))
- (emit-label asm k)
- (emit-begin-kw-arity asm req opt rest kw-indices
- allow-other-keys? nlocals alternate)
- (let ((next (compile-body (1+ n) nlocals)))
+ (nlocals (lookup-nlocals label allocation)))
+ (emit-label asm label)
+ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
+ nlocals
+ (match alternate (#f #f) (($ $cont alt) alt)))
+ (let ((next (compile-body (1+ label) nlocals)))
(emit-end-arity asm)
- next)))))
-
- (define (compile-body n nlocals)
- (let compile-cont ((n n))
- (if (= n (vector-length contv))
- n
- (match (vector-ref contv n)
- (($ $kclause) n)
- (($ $kargs _ _ term)
- (emit-label asm (cfa-k-sym cfa n))
+ (match alternate
+ (($ $cont alt)
+ (unless (eq? next alt)
+ (error "unexpected k" alt))
+ (compile-clause next))
+ (#f
+ (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg)))
+ (error "unexpected end of clauses")))))))))
+
+ (define (compile-body label nlocals)
+ (let compile-cont ((label label))
+ (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg)))
+ label
+ (match (lookup-cont label dfg)
+ (($ $kclause) label)
+ (($ $kargs names vars term)
+ (emit-label asm label)
+ (for-each (lambda (name var)
+ (let ((slot (maybe-slot var)))
+ (when slot
+ (emit-definition asm name slot))))
+ names vars)
(let find-exp ((term term))
(match term
(($ $letk conts term)
(($ $continue k src exp)
(when src
(emit-source asm src))
- (compile-expression n k exp nlocals)
- (compile-cont (1+ n))))))
+ (compile-expression label k exp nlocals)
+ (compile-cont (1+ label))))))
(_
- (emit-label asm (cfa-k-sym cfa n))
- (compile-cont (1+ n)))))))
+ (emit-label asm label)
+ (compile-cont (1+ label)))))))
- (define (compile-expression n k exp nlocals)
- (let* ((label (cfa-k-sym cfa n))
- (k-idx (cfa-k-idx cfa k))
- (fallthrough? (= k-idx (1+ n))))
+ (define (compile-expression label k exp nlocals)
+ (let* ((fallthrough? (= k (1+ label))))
(define (maybe-emit-jump)
- (unless (= k-idx (1+ n))
+ (unless fallthrough?
(emit-br asm k)))
- (match (vector-ref contv k-idx)
+ (match (lookup-cont k dfg)
(($ $ktail)
(compile-tail label exp))
(($ $kargs (name) (sym))
(compile-value label exp dst nlocals)))
(maybe-emit-jump))
(($ $kargs () ())
- (compile-effect label exp k nlocals)
- (maybe-emit-jump))
+ (match exp
+ (($ $branch kt exp)
+ (compile-test label exp kt k (1+ label)))
+ (_
+ (compile-effect label exp k nlocals)
+ (maybe-emit-jump))))
(($ $kargs names syms)
(compile-values label exp syms)
(maybe-emit-jump))
- (($ $kif kt kf)
- (compile-test label exp kt kf
- (and (= k-idx (1+ n))
- (< (+ n 2) (cfa-k-count cfa))
- (cfa-k-sym cfa (+ n 2)))))
- (($ $ktrunc ($ $arity req () rest () #f) kargs)
+ (($ $kreceive ($ $arity req () rest () #f) kargs)
(compile-trunc label k exp (length req)
(and rest
- (match (vector-ref contv (cfa-k-idx cfa kargs))
+ (match (lookup-cont kargs dfg)
(($ $kargs names (_ ... rest)) rest)))
nlocals)
- (unless (and (= k-idx (1+ n))
- (< (+ n 2) (cfa-k-count cfa))
- (eq? (cfa-k-sym cfa (+ n 2)) kargs))
+ (unless (and fallthrough? (= kargs (1+ k)))
(emit-br asm kargs))))))
(define (compile-tail label exp)
(let ((tail-slots (cdr (iota (1+ (length args))))))
(for-each maybe-load-constant tail-slots args))
(emit-tail-call asm (1+ (length args))))
+ (($ $callk k proc args)
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (let ((tail-slots (cdr (iota (1+ (length args))))))
+ (for-each maybe-load-constant tail-slots args))
+ (emit-tail-call-label asm (1+ (length args)) k))
(($ $values ())
(emit-reset-frame asm 1)
(emit-return-values asm))
(emit-load-constant asm dst *unspecified*))
(($ $const exp)
(emit-load-constant asm dst exp))
- (($ $fun src meta () ($ $cont k))
+ (($ $closure k 0)
(emit-load-static-procedure asm dst k))
- (($ $fun src meta free ($ $cont k))
- (emit-make-closure asm dst k (length free)))
- (($ $call proc args)
- (let* ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (1+ (length args)))
- (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant arg-slots (cons proc args))
- (emit-call asm proc-slot nargs)
- (cond
- (dst
- (emit-receive asm dst proc-slot nlocals))
- (else
- ;; FIXME: Only allow more values if there is a rest arg.
- ;; Express values truncation by the presence of an
- ;; unused rest arg instead of implicitly.
- (emit-receive-values asm proc-slot #t 1)
- (emit-reset-frame asm nlocals)))))
+ (($ $closure k nfree)
+ (emit-make-closure asm dst k nfree))
(($ $primcall 'current-module)
(emit-current-module asm dst))
(($ $primcall 'cached-toplevel-box (scope name bound?))
(emit-free-ref asm dst (slot closure) (constant idx)))
(($ $primcall 'vector-ref (vector index))
(emit-vector-ref asm dst (slot vector) (slot index)))
+ (($ $primcall 'make-vector (length init))
+ (emit-make-vector asm dst (slot length) (slot init)))
(($ $primcall 'make-vector/immediate (length init))
(emit-make-vector/immediate asm dst (constant length) (slot init)))
(($ $primcall 'vector-ref/immediate (vector index))
(emit-builtin-ref asm dst (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
(emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+ (($ $primcall 'bv-s8-ref (bv idx))
+ (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-u16-ref (bv idx))
(emit-bv-u16-ref asm dst (slot bv) (slot idx)))
(($ $primcall 'bv-s16-ref (bv idx))
(define (compile-effect label exp k nlocals)
(match exp
(($ $values ()) #f)
- (($ $prompt escape? tag handler pop)
- (match (lookup-cont handler)
- (($ $ktrunc ($ $arity req () rest () #f) khandler-body)
+ (($ $prompt escape? tag handler)
+ (match (lookup-cont handler dfg)
+ (($ $kreceive ($ $arity req () rest () #f) khandler-body)
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot handler allocation)))
(emit-prompt asm (slot tag) escape? proc-slot receive-args)
(emit-br asm k)
(emit-label asm receive-args)
- (emit-receive-values asm proc-slot (->bool rest) nreq)
+ (unless (and rest (zero? nreq))
+ (emit-receive-values asm proc-slot (->bool rest) nreq))
(when (and rest
- (match (vector-ref contv (cfa-k-idx cfa khandler-body))
+ (match (lookup-cont khandler-body dfg)
(($ $kargs names (_ ... rest))
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(($ $primcall 'vector-set!/immediate (vector index value))
(emit-vector-set!/immediate asm (slot vector) (constant index)
(slot value)))
- (($ $primcall 'variable-set! (var val))
- (emit-box-set! asm (slot var) (slot val)))
(($ $primcall 'set-car! (pair value))
(emit-set-car! asm (slot pair) (slot value)))
(($ $primcall 'set-cdr! (pair value))
(emit-wind asm (slot winder) (slot unwinder)))
(($ $primcall 'bv-u8-set! (bv idx val))
(emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+ (($ $primcall 'bv-s8-set! (bv idx val))
+ (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-u16-set! (bv idx val))
(emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
(($ $primcall 'bv-s16-set! (bv idx val))
(unless (eq? kf next-label)
(emit-br asm kf)))))
(match exp
- (($ $values (sym)) (unary emit-br-if-true sym))
+ (($ $values (sym))
+ (call-with-values (lambda ()
+ (lookup-maybe-constant-value sym allocation))
+ (lambda (has-const? val)
+ (if has-const?
+ (if val
+ (unless (eq? kt next-label)
+ (emit-br asm kt))
+ (unless (eq? kf next-label)
+ (emit-br asm kf)))
+ (unary emit-br-if-true sym)))))
(($ $primcall 'null? (a)) (unary emit-br-if-null a))
(($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
- (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
+ (($ $primcall '> (a b)) (binary emit-br-if-< b a))
+ (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
(define (compile-trunc label k exp nreq rest-var nlocals)
+ (define (do-call proc args emit-call)
+ (let* ((proc-slot (lookup-call-proc-slot label allocation))
+ (nargs (1+ (length args)))
+ (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves label allocation))
+ (for-each maybe-load-constant arg-slots (cons proc args))
+ (emit-call asm proc-slot nargs)
+ (emit-dead-slot-map asm proc-slot
+ (lookup-dead-slot-map label allocation))
+ (cond
+ ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
+ (match (lookup-parallel-moves k allocation)
+ ((((? (lambda (src) (= src (1+ proc-slot))) src)
+ . dst)) dst)
+ (_ #f)))
+ ;; The usual case: one required live return value, ignoring
+ ;; any additional values.
+ => (lambda (dst)
+ (emit-receive asm dst proc-slot nlocals)))
+ (else
+ (unless (and (zero? nreq) rest-var)
+ (emit-receive-values asm proc-slot (->bool rest-var) nreq))
+ (when (and rest-var (maybe-slot rest-var))
+ (emit-bind-rest asm (+ proc-slot 1 nreq)))
+ (for-each (match-lambda
+ ((src . dst) (emit-mov asm dst src)))
+ (lookup-parallel-moves k allocation))
+ (emit-reset-frame asm nlocals)))))
(match exp
(($ $call proc args)
- (let* ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (1+ (length args)))
- (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves label allocation))
- (for-each maybe-load-constant arg-slots (cons proc args))
- (emit-call asm proc-slot nargs)
- ;; FIXME: Only allow more values if there is a rest arg.
- ;; Express values truncation by the presence of an
- ;; unused rest arg instead of implicitly.
- (emit-receive-values asm proc-slot #t nreq)
- (when (and rest-var (maybe-slot rest-var))
- (emit-bind-rest asm (+ proc-slot 1 nreq)))
- (for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
- (lookup-parallel-moves k allocation))
- (emit-reset-frame asm nlocals)))))
+ (do-call proc args
+ (lambda (asm proc-slot nargs)
+ (emit-call asm proc-slot nargs))))
+ (($ $callk k proc args)
+ (do-call proc args
+ (lambda (asm proc-slot nargs)
+ (emit-call-label asm proc-slot nargs k))))))
(match f
- (($ $fun src meta free ($ $cont k ($ $kentry self tail clauses)))
- ;; FIXME: src on kentry instead?
- (when src
- (emit-source asm src))
- (compile-entry (or meta '()))))))
-
-(define (visit-funs proc exp)
- (match exp
- (($ $continue _ _ exp)
- (visit-funs proc exp))
-
- (($ $fun src meta free body)
- (proc exp)
- (visit-funs proc body))
-
- (($ $letk conts body)
- (visit-funs proc body)
- (for-each (lambda (cont) (visit-funs proc cont)) conts))
-
- (($ $cont sym ($ $kargs names syms body))
- (visit-funs proc body))
-
- (($ $cont sym ($ $kclause arity body))
- (visit-funs proc body))
-
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each (lambda (clause) (visit-funs proc clause)) clauses))
-
- (_ (values))))
+ (($ $cont k ($ $kfun src meta self tail clause))
+ (compile-entry)))))
(define (compile-bytecode exp env opts)
(let* ((exp (fix-arities exp))
(exp (optimize exp opts))
(exp (convert-closures exp))
+ ;; first-order optimization should go here
(exp (reify-primitives exp))
+ (exp (renumber exp))
(asm (make-assembler)))
- (visit-funs (lambda (fun)
- (compile-fun fun asm))
- exp)
+ (match exp
+ (($ $program funs)
+ (for-each (lambda (fun) (compile-fun fun asm))
+ funs)))
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
env
env)))
HCoop / bpt / guile.git / blobdiff