mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 03:00:25 +02:00
Add CPS -> RTL compiler
* module/Makefile.am: * module/language/cps/compile-rtl.scm: * module/language/cps/dfg.scm: * module/language/cps/slot-allocation.scm: New modules. * module/language/cps/spec.scm: Register the compiler. * test-suite/Makefile.am: * test-suite/tests/rtl-compilation.test: Add tests.
This commit is contained in:
Andy Wingo
parent
934e6b9515
commit
6e8ad82335
7 changed files with 1428 additions and 1 deletions
|
|
@ -122,8 +122,11 @@ CPS_LANG_SOURCES = \
|
|||
language/cps.scm \
|
||||
language/cps/arities.scm \
|
||||
language/cps/closure-conversion.scm \
|
||||
language/cps/compile-rtl.scm \
|
||||
language/cps/dfg.scm \
|
||||
language/cps/primitives.scm \
|
||||
language/cps/reify-primitives.scm \
|
||||
language/cps/slot-allocation.scm \
|
||||
language/cps/spec.scm \
|
||||
language/cps/verify.scm
|
||||
|
||||
|
|
|
|||
371
module/language/cps/compile-rtl.scm
Normal file
371
module/language/cps/compile-rtl.scm
Normal file
|
|
@ -0,0 +1,371 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013 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
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Compiling CPS to RTL. The result is in the RTL language, which
|
||||
;;; happens to be an ELF image as a bytecode.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps compile-rtl)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (language cps)
|
||||
#:use-module (language cps arities)
|
||||
#:use-module (language cps closure-conversion)
|
||||
#:use-module (language cps dfg)
|
||||
#:use-module (language cps primitives)
|
||||
#:use-module (language cps reify-primitives)
|
||||
#:use-module (language cps slot-allocation)
|
||||
#:use-module (system vm assembler)
|
||||
#:export (compile-rtl))
|
||||
|
||||
;; TODO: Source info, local var names. Needs work in the linker and the
|
||||
;; debugger.
|
||||
|
||||
(define (kw-arg-ref args kw default)
|
||||
(match (memq kw args)
|
||||
((_ val . _) val)
|
||||
(_ default)))
|
||||
|
||||
(define (optimize exp opts)
|
||||
(define (run-pass exp pass kw default)
|
||||
(if (kw-arg-ref opts kw default)
|
||||
(pass exp)
|
||||
exp))
|
||||
|
||||
;; Calls to source-to-source optimization passes go here.
|
||||
(let* ()
|
||||
;; Passes that are needed:
|
||||
;;
|
||||
;; * Contification: turning $letrec-bound $funs into $letk-bound $conts.
|
||||
;;
|
||||
;; * 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 (visit-funs proc exp)
|
||||
(match exp
|
||||
(($ $continue _ exp)
|
||||
(visit-funs proc exp))
|
||||
|
||||
(($ $fun 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 src ($ $kargs names syms body))
|
||||
(visit-funs proc body))
|
||||
|
||||
(($ $cont sym src ($ $kclause arity body))
|
||||
(visit-funs proc body))
|
||||
|
||||
(($ $cont sym src ($ $kentry self tail clauses))
|
||||
(for-each (lambda (clause) (visit-funs proc clause)) clauses))
|
||||
|
||||
(_ (values))))
|
||||
|
||||
(define (emit-rtl-sequence asm exp allocation nlocals cont-table)
|
||||
(define (slot sym)
|
||||
(lookup-slot sym allocation))
|
||||
|
||||
(define (constant sym)
|
||||
(lookup-constant-value sym allocation))
|
||||
|
||||
(define (emit-rtl label k exp next-label)
|
||||
(define (maybe-mov dst src)
|
||||
(unless (= dst src)
|
||||
(emit-mov asm dst src)))
|
||||
|
||||
(define (maybe-jump label)
|
||||
(unless (eq? label next-label)
|
||||
(emit-br asm label)))
|
||||
|
||||
(define (maybe-load-constant slot src)
|
||||
(call-with-values (lambda ()
|
||||
(lookup-maybe-constant-value src allocation))
|
||||
(lambda (has-const? val)
|
||||
(and has-const?
|
||||
(begin
|
||||
(emit-load-constant asm slot val)
|
||||
#t)))))
|
||||
|
||||
(define (emit-tail)
|
||||
;; There are only three kinds of expressions in tail position:
|
||||
;; tail calls, multiple-value returns, and single-value returns.
|
||||
(match exp
|
||||
(($ $call 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 asm (1+ (length args))))
|
||||
(($ $values args)
|
||||
(let ((tail-slots (cdr (iota (1+ (length args))))))
|
||||
(for-each (match-lambda
|
||||
((src . dst) (emit-mov asm dst src)))
|
||||
(lookup-parallel-moves label allocation))
|
||||
(for-each maybe-load-constant tail-slots args))
|
||||
(emit-reset-frame asm (1+ (length args)))
|
||||
(emit-return-values asm))
|
||||
(($ $primcall 'return (arg))
|
||||
(emit-return asm (slot arg)))))
|
||||
|
||||
(define (emit-val sym)
|
||||
(let ((dst (slot sym)))
|
||||
(match exp
|
||||
(($ $var sym)
|
||||
(maybe-mov dst (slot sym)))
|
||||
(($ $void)
|
||||
(when dst
|
||||
(emit-load-constant asm dst *unspecified*)))
|
||||
(($ $const exp)
|
||||
(when dst
|
||||
(emit-load-constant asm dst exp)))
|
||||
(($ $fun meta () ($ $cont k))
|
||||
(emit-load-static-procedure asm dst k))
|
||||
(($ $fun 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 (length args)))
|
||||
(or (maybe-load-constant proc-slot proc)
|
||||
(maybe-mov proc-slot (slot proc)))
|
||||
(let lp ((n (1+ proc-slot)) (args args))
|
||||
(match args
|
||||
(()
|
||||
(emit-call asm proc-slot (+ nargs 1))
|
||||
(emit-receive asm dst proc-slot nlocals))
|
||||
((arg . args)
|
||||
(or (maybe-load-constant n arg)
|
||||
(maybe-mov n (slot arg)))
|
||||
(lp (1+ n) args))))))
|
||||
(($ $primcall 'current-module)
|
||||
(emit-current-module asm dst))
|
||||
(($ $primcall 'cached-toplevel-box (scope name bound?))
|
||||
(emit-cached-toplevel-box asm dst (constant scope) (constant name)
|
||||
(constant bound?)))
|
||||
(($ $primcall 'cached-module-box (mod name public? bound?))
|
||||
(emit-cached-module-box asm dst (constant mod) (constant name)
|
||||
(constant public?) (constant bound?)))
|
||||
(($ $primcall 'resolve (name bound?))
|
||||
(emit-resolve asm dst (constant bound?) (slot name)))
|
||||
(($ $primcall 'free-ref (closure idx))
|
||||
(emit-free-ref asm dst (slot closure) (constant idx)))
|
||||
(($ $primcall name args)
|
||||
;; FIXME: Inline all the cases.
|
||||
(let ((inst (prim-rtl-instruction name)))
|
||||
(emit-text asm `((,inst ,dst ,@(map slot args))))))
|
||||
(($ $values (arg))
|
||||
(or (maybe-load-constant dst arg)
|
||||
(maybe-mov dst (slot arg))))
|
||||
(($ $prompt escape? tag handler)
|
||||
(emit-prompt asm escape? tag handler)))
|
||||
(maybe-jump k)))
|
||||
|
||||
(define (emit-vals syms)
|
||||
(match exp
|
||||
(($ $primcall name args)
|
||||
(error "unimplemented primcall in values context" name))
|
||||
(($ $values args)
|
||||
(for-each (match-lambda
|
||||
((src . dst) (emit-mov asm dst src)))
|
||||
(lookup-parallel-moves label allocation))
|
||||
(for-each maybe-load-constant (map slot syms) args)))
|
||||
(maybe-jump k))
|
||||
|
||||
(define (emit-seq)
|
||||
(match exp
|
||||
(($ $primcall 'cache-current-module! (sym scope))
|
||||
(emit-cache-current-module! asm (slot sym) (constant scope)))
|
||||
(($ $primcall 'free-set! (closure idx value))
|
||||
(emit-free-set! asm (slot closure) (slot value) (constant idx)))
|
||||
(($ $primcall 'box-set! (box value))
|
||||
(emit-box-set! asm (slot box) (slot value)))
|
||||
(($ $primcall 'struct-set! (struct index value))
|
||||
(emit-struct-set! asm (slot struct) (slot index) (slot value)))
|
||||
(($ $primcall 'vector-set! (vector index value))
|
||||
(emit-vector-set asm (slot vector) (slot index) (slot value)))
|
||||
(($ $primcall 'set-car! (pair value))
|
||||
(emit-set-car! asm (slot pair) (slot value)))
|
||||
(($ $primcall 'set-cdr! (pair value))
|
||||
(emit-set-cdr! asm (slot pair) (slot value)))
|
||||
(($ $primcall 'define! (sym value))
|
||||
(emit-define asm (slot sym) (slot value)))
|
||||
(($ $primcall name args)
|
||||
(error "unhandled primcall in seq context" name))
|
||||
(($ $values ()) #f))
|
||||
(maybe-jump k))
|
||||
|
||||
(define (emit-test kt kf)
|
||||
(define (unary op sym)
|
||||
(cond
|
||||
((eq? kt next-label)
|
||||
(op asm (slot sym) #t kf))
|
||||
(else
|
||||
(op asm (slot sym) #f kt)
|
||||
(maybe-jump kf))))
|
||||
(define (binary op a b)
|
||||
(cond
|
||||
((eq? kt next-label)
|
||||
(op asm (slot a) (slot b) #t kf))
|
||||
(else
|
||||
(op asm (slot a) (slot b) #f kt)
|
||||
(maybe-jump kf))))
|
||||
(match exp
|
||||
(($ $var sym) (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 'struct? (a)) (unary emit-br-if-struct a))
|
||||
(($ $primcall 'char? (a)) (unary emit-br-if-char a))
|
||||
;; Add TC7 tests here
|
||||
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
|
||||
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
|
||||
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
|
||||
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
|
||||
(($ $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-= a b))
|
||||
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
|
||||
(($ $primcall '> (a b)) (binary emit-br-if-< b a))))
|
||||
|
||||
(define (emit-trunc nreq rest? k)
|
||||
(match exp
|
||||
(($ $call proc args)
|
||||
(let ((proc-slot (lookup-call-proc-slot label allocation))
|
||||
(nargs (length args)))
|
||||
(or (maybe-load-constant proc-slot proc)
|
||||
(maybe-mov proc-slot (slot proc)))
|
||||
(let lp ((n (1+ proc-slot)) (args args))
|
||||
(match args
|
||||
(()
|
||||
(emit-call asm proc-slot (+ nargs 1))
|
||||
(emit-receive-values asm proc-slot nreq)
|
||||
(when rest?
|
||||
(emit-bind-rest asm (+ proc-slot 1 nreq)))
|
||||
(for-each (match-lambda
|
||||
((src . dst) (emit-mov asm dst src)))
|
||||
(lookup-parallel-moves label allocation))
|
||||
(emit-reset-frame asm nlocals))
|
||||
((arg . args)
|
||||
(or (maybe-load-constant n arg)
|
||||
(maybe-mov n (slot arg)))
|
||||
(lp (1+ n) args)))))))
|
||||
(maybe-jump k))
|
||||
|
||||
(match (lookup-cont k cont-table)
|
||||
(($ $ktail) (emit-tail))
|
||||
(($ $kargs (name) (sym)) (emit-val sym))
|
||||
(($ $kargs () ()) (emit-seq))
|
||||
(($ $kargs names syms) (emit-vals syms))
|
||||
(($ $kargs (name) (sym)) (emit-val sym))
|
||||
(($ $kif kt kf) (emit-test kt kf))
|
||||
(($ $ktrunc ($ $arity req () rest () #f) k)
|
||||
(emit-trunc (length req) (and rest #t) k))))
|
||||
|
||||
(define (collect-exps k src cont tail)
|
||||
(define (find-exp k src term)
|
||||
(match term
|
||||
(($ $continue exp-k exp)
|
||||
(cons (list k src exp-k exp) tail))
|
||||
(($ $letk conts body)
|
||||
(find-exp k src body))))
|
||||
(match cont
|
||||
(($ $kargs names syms body)
|
||||
(find-exp k src body))
|
||||
(_ tail)))
|
||||
|
||||
(let lp ((exps (reverse (fold-local-conts collect-exps '() exp))))
|
||||
(match exps
|
||||
(() #t)
|
||||
(((k src exp-k exp) . exps)
|
||||
(let ((next-label (match exps
|
||||
(((k . _) . _) k)
|
||||
(() #f))))
|
||||
(emit-label asm k)
|
||||
(emit-rtl k exp-k exp next-label)
|
||||
(lp exps))))))
|
||||
|
||||
(define (compile-fun f asm)
|
||||
(let ((allocation (allocate-slots f))
|
||||
(cont-table (match f
|
||||
(($ $fun meta free body)
|
||||
(build-local-cont-table body)))))
|
||||
(define (emit-fun-clause clause alternate)
|
||||
(match clause
|
||||
(($ $cont k src
|
||||
($ $kclause ($ $arity req opt rest kw allow-other-keys?)
|
||||
body))
|
||||
(let ((kw-indices (map (match-lambda
|
||||
((key name sym)
|
||||
(cons key (lookup-slot sym allocation))))
|
||||
kw))
|
||||
(nlocals (lookup-nlocals k allocation)))
|
||||
(emit-label asm k)
|
||||
(emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
|
||||
nlocals alternate)
|
||||
(emit-rtl-sequence asm body allocation nlocals cont-table)
|
||||
(emit-end-arity asm)))))
|
||||
|
||||
(define (emit-fun-clauses clauses)
|
||||
(match clauses
|
||||
((clause . clauses)
|
||||
(let ((kalternate (match clauses
|
||||
(() #f)
|
||||
((($ $cont k) . _) k))))
|
||||
(emit-fun-clause clause kalternate)
|
||||
(when kalternate
|
||||
(emit-fun-clauses clauses))))))
|
||||
|
||||
(match f
|
||||
(($ $fun meta free ($ $cont k src ($ $kentry self tail clauses)))
|
||||
(emit-begin-program asm k (or meta '()))
|
||||
(emit-fun-clauses clauses)
|
||||
(emit-end-program asm)))))
|
||||
|
||||
(define (compile-rtl exp env opts)
|
||||
(let* ((exp (fix-arities exp))
|
||||
(exp (optimize exp opts))
|
||||
(exp (convert-closures exp))
|
||||
(exp (reify-primitives exp))
|
||||
(asm (make-assembler)))
|
||||
(visit-funs (lambda (fun)
|
||||
(compile-fun fun asm))
|
||||
exp)
|
||||
(values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
|
||||
env
|
||||
env)))
|
||||
432
module/language/cps/dfg.scm
Normal file
432
module/language/cps/dfg.scm
Normal file
|
|
@ -0,0 +1,432 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013 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
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Many passes rely on a local or global static analysis of a function.
|
||||
;;; This module implements a simple data-flow graph (DFG) analysis,
|
||||
;;; tracking the definitions and uses of variables and continuations.
|
||||
;;; It also builds a table of continuations and parent links, to be able
|
||||
;;; to easily determine if one continuation is in the scope of another,
|
||||
;;; and to get to the expression inside a continuation.
|
||||
;;;
|
||||
;;; Note that the data-flow graph of continuation labels is a
|
||||
;;; control-flow graph.
|
||||
;;;
|
||||
;;; We currently don't expose details of the DFG type outside this
|
||||
;;; module, preferring to only expose accessors. That may change in the
|
||||
;;; future but it seems to work for now.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps dfg)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (language cps)
|
||||
#:export (build-cont-table
|
||||
build-local-cont-table
|
||||
lookup-cont
|
||||
|
||||
compute-dfg
|
||||
dfg-cont-table
|
||||
lookup-def
|
||||
lookup-uses
|
||||
find-call
|
||||
call-expression
|
||||
find-expression
|
||||
find-defining-expression
|
||||
find-constant-value
|
||||
lift-definition!
|
||||
variable-used-in?
|
||||
constant-needs-allocation?
|
||||
dead-after-def?
|
||||
dead-after-use?
|
||||
branch?
|
||||
find-other-branches
|
||||
dead-after-branch?
|
||||
lookup-bound-syms))
|
||||
|
||||
(define (build-cont-table fun)
|
||||
(fold-conts (lambda (k src cont table)
|
||||
(hashq-set! table k cont)
|
||||
table)
|
||||
(make-hash-table)
|
||||
fun))
|
||||
|
||||
(define (build-local-cont-table cont)
|
||||
(fold-local-conts (lambda (k src cont table)
|
||||
(hashq-set! table k cont)
|
||||
table)
|
||||
(make-hash-table)
|
||||
cont))
|
||||
|
||||
(define (lookup-cont sym conts)
|
||||
(let ((res (hashq-ref conts sym)))
|
||||
(unless res
|
||||
(error "Unknown continuation!" sym (hash-fold acons '() conts)))
|
||||
res))
|
||||
|
||||
;; Data-flow graph for CPS: both for values and continuations.
|
||||
(define-record-type $dfg
|
||||
(make-dfg conts use-maps uplinks)
|
||||
dfg?
|
||||
;; hash table of sym -> $kargs, $kif, etc
|
||||
(conts dfg-cont-table)
|
||||
;; hash table of sym -> $use-map
|
||||
(use-maps dfg-use-maps)
|
||||
;; hash table of sym -> $parent-link
|
||||
(uplinks dfg-uplinks))
|
||||
|
||||
(define-record-type $use-map
|
||||
(make-use-map sym def uses)
|
||||
use-map?
|
||||
(sym use-map-sym)
|
||||
(def use-map-def)
|
||||
(uses use-map-uses set-use-map-uses!))
|
||||
|
||||
(define-record-type $uplink
|
||||
(make-uplink parent level)
|
||||
uplink?
|
||||
(parent uplink-parent)
|
||||
(level uplink-level))
|
||||
|
||||
(define (visit-fun fun conts use-maps uplinks global?)
|
||||
(define (add-def! sym def-k)
|
||||
(unless def-k
|
||||
(error "Term outside labelled continuation?"))
|
||||
(hashq-set! use-maps sym (make-use-map sym def-k '())))
|
||||
|
||||
(define (add-use! sym use-k)
|
||||
(match (hashq-ref use-maps sym)
|
||||
(#f (error "Symbol out of scope?" sym))
|
||||
((and use-map ($ $use-map sym def uses))
|
||||
(set-use-map-uses! use-map (cons use-k uses)))))
|
||||
|
||||
(define (link-parent! k parent)
|
||||
(match (hashq-ref uplinks parent)
|
||||
(($ $uplink _ level)
|
||||
(hashq-set! uplinks k (make-uplink parent (1+ level))))))
|
||||
|
||||
(define (visit exp exp-k)
|
||||
(define (def! sym)
|
||||
(add-def! sym exp-k))
|
||||
(define (use! sym)
|
||||
(add-use! sym exp-k))
|
||||
(define (recur exp)
|
||||
(visit exp exp-k))
|
||||
(match exp
|
||||
(($ $letk (($ $cont k src cont) ...) body)
|
||||
;; Set up recursive environment before visiting cont bodies.
|
||||
(for-each (lambda (cont k)
|
||||
(def! k)
|
||||
(hashq-set! conts k cont)
|
||||
(link-parent! k exp-k))
|
||||
cont k)
|
||||
(for-each visit cont k)
|
||||
(recur body))
|
||||
|
||||
(($ $kargs names syms body)
|
||||
(for-each def! syms)
|
||||
(recur body))
|
||||
|
||||
(($ $kif kt kf)
|
||||
(use! kt)
|
||||
(use! kf))
|
||||
|
||||
(($ $ktrunc arity k)
|
||||
(use! k))
|
||||
|
||||
(($ $letrec names syms funs body)
|
||||
(unless global?
|
||||
(error "$letrec should not be present when building a local DFG"))
|
||||
(for-each def! syms)
|
||||
(for-each (cut visit-fun <> conts use-maps uplinks global?) funs)
|
||||
(visit body exp-k))
|
||||
|
||||
(($ $continue k exp)
|
||||
(use! k)
|
||||
(match exp
|
||||
(($ $var sym)
|
||||
(use! sym))
|
||||
|
||||
(($ $call proc args)
|
||||
(use! proc)
|
||||
(for-each use! args))
|
||||
|
||||
(($ $primcall name args)
|
||||
(for-each use! args))
|
||||
|
||||
(($ $values args)
|
||||
(for-each use! args))
|
||||
|
||||
(($ $prompt escape? tag handler)
|
||||
(use! tag)
|
||||
(use! handler))
|
||||
|
||||
(($ $fun)
|
||||
(when global?
|
||||
(visit-fun exp conts use-maps uplinks global?)))
|
||||
|
||||
(_ #f)))))
|
||||
|
||||
(match fun
|
||||
(($ $fun meta free
|
||||
($ $cont kentry src
|
||||
(and entry
|
||||
($ $kentry self ($ $cont ktail _ tail) clauses))))
|
||||
;; Treat the fun continuation as its own parent.
|
||||
(add-def! kentry kentry)
|
||||
(add-def! self kentry)
|
||||
(hashq-set! uplinks kentry (make-uplink #f 0))
|
||||
(hashq-set! conts kentry entry)
|
||||
|
||||
(add-def! ktail kentry)
|
||||
(hashq-set! conts ktail tail)
|
||||
(link-parent! ktail kentry)
|
||||
|
||||
(for-each
|
||||
(match-lambda
|
||||
(($ $cont kclause _
|
||||
(and clause ($ $kclause arity ($ $cont kbody _ body))))
|
||||
(add-def! kclause kentry)
|
||||
(hashq-set! conts kclause clause)
|
||||
(link-parent! kclause kentry)
|
||||
|
||||
(add-def! kbody kclause)
|
||||
(hashq-set! conts kbody body)
|
||||
(link-parent! kbody kclause)
|
||||
|
||||
(visit body kbody)))
|
||||
clauses))))
|
||||
|
||||
(define* (compute-dfg fun #:key (global? #t))
|
||||
(let* ((conts (make-hash-table))
|
||||
(use-maps (make-hash-table))
|
||||
(uplinks (make-hash-table)))
|
||||
(visit-fun fun conts use-maps uplinks global?)
|
||||
(make-dfg conts use-maps uplinks)))
|
||||
|
||||
(define (lookup-uplink k uplinks)
|
||||
(let ((res (hashq-ref uplinks k)))
|
||||
(unless res
|
||||
(error "Unknown continuation!" k (hash-fold acons '() uplinks)))
|
||||
res))
|
||||
|
||||
(define (lookup-use-map sym use-maps)
|
||||
(let ((res (hashq-ref use-maps sym)))
|
||||
(unless res
|
||||
(error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
|
||||
res))
|
||||
|
||||
(define (lookup-def sym dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map sym use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
def)))))
|
||||
|
||||
(define (lookup-uses sym dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map sym use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
uses)))))
|
||||
|
||||
(define (find-defining-term sym dfg)
|
||||
(match (lookup-uses (lookup-def sym dfg) dfg)
|
||||
((def-exp-k)
|
||||
(lookup-cont def-exp-k (dfg-cont-table dfg)))
|
||||
(else #f)))
|
||||
|
||||
(define (find-call term)
|
||||
(match term
|
||||
(($ $kargs names syms body) (find-call body))
|
||||
(($ $letk conts body) (find-call body))
|
||||
(($ $letrec names syms funs body) (find-call body))
|
||||
(($ $continue) term)))
|
||||
|
||||
(define (call-expression call)
|
||||
(match call
|
||||
(($ $continue k exp) exp)))
|
||||
|
||||
(define (find-expression term)
|
||||
(call-expression (find-call term)))
|
||||
|
||||
(define (find-defining-expression sym dfg)
|
||||
(match (find-defining-term sym dfg)
|
||||
(#f #f)
|
||||
(($ $ktrunc) #f)
|
||||
(term (find-expression term))))
|
||||
|
||||
(define (find-constant-value sym dfg)
|
||||
(match (find-defining-expression sym dfg)
|
||||
(($ $const val)
|
||||
(values #t val))
|
||||
(($ $continue k ($ $void))
|
||||
(values #t *unspecified*))
|
||||
(else
|
||||
(values #f #f))))
|
||||
|
||||
(define (constant-needs-allocation? sym val dfg)
|
||||
(define (find-exp term)
|
||||
(match term
|
||||
(($ $kargs names syms body) (find-exp body))
|
||||
(($ $letk conts body) (find-exp body))
|
||||
(else term)))
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map sym use-maps)
|
||||
(($ $use-map _ def uses)
|
||||
(or-map
|
||||
(lambda (use)
|
||||
(match (find-expression (lookup-cont use conts))
|
||||
(($ $call) #f)
|
||||
(($ $values) #f)
|
||||
(($ $primcall 'free-ref (closure slot))
|
||||
(not (eq? sym slot)))
|
||||
(($ $primcall 'free-set! (closure slot value))
|
||||
(not (eq? sym slot)))
|
||||
(($ $primcall 'cache-current-module! (mod . _))
|
||||
(eq? sym mod))
|
||||
(($ $primcall 'cached-toplevel-box _)
|
||||
#f)
|
||||
(($ $primcall 'cached-module-box _)
|
||||
#f)
|
||||
(($ $primcall 'resolve (name bound?))
|
||||
(eq? sym name))
|
||||
(_ #t)))
|
||||
uses))))))
|
||||
|
||||
(define (continuation-scope-contains? parent-k k uplinks)
|
||||
(match (lookup-uplink parent-k uplinks)
|
||||
(($ $uplink _ parent-level)
|
||||
(let lp ((k k))
|
||||
(or (eq? parent-k k)
|
||||
(match (lookup-uplink k uplinks)
|
||||
(($ $uplink parent level)
|
||||
(and (< parent-level level)
|
||||
(lp parent)))))))))
|
||||
|
||||
(define (lift-definition! k parent-k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-uplink parent-k uplinks)
|
||||
(($ $uplink parent level)
|
||||
(hashq-set! uplinks k
|
||||
(make-uplink parent-k (1+ level)))
|
||||
;; Lift definitions of all conts in K.
|
||||
(let lp ((cont (lookup-cont k conts)))
|
||||
(match cont
|
||||
(($ $letk (($ $cont kid) ...) body)
|
||||
(for-each (cut lift-definition! <> k dfg) kid)
|
||||
(lp body))
|
||||
(($ $letrec names syms funs body)
|
||||
(lp body))
|
||||
(_ #t))))))))
|
||||
|
||||
(define (variable-used-in? var parent-k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(or-map (lambda (use)
|
||||
(continuation-scope-contains? parent-k use uplinks))
|
||||
(match (lookup-use-map var use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
uses))))))
|
||||
|
||||
;; Does k1 dominate k2?
|
||||
;;
|
||||
;; Note that this is a conservative predicate: a false return value does
|
||||
;; not indicate that k1 _doesn't_ dominate k2. The reason for this is
|
||||
;; that we are using the scope tree as an approximation of the dominator
|
||||
;; relationship. See
|
||||
;; http://mlton.org/pipermail/mlton/2003-January/023054.html for a
|
||||
;; deeper discussion.
|
||||
(define (conservatively-dominates? k1 k2 uplinks)
|
||||
(continuation-scope-contains? k1 k2 uplinks))
|
||||
|
||||
(define (dead-after-def? sym dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map sym use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
(null? uses))))))
|
||||
|
||||
(define (dead-after-use? sym use-k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map sym use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
;; If all other uses dominate this use, it is now dead. There
|
||||
;; are other ways for it to be dead, but this is an
|
||||
;; approximation. A better check would be if the successor
|
||||
;; post-dominates all uses.
|
||||
(and-map (cut conservatively-dominates? <> use-k uplinks)
|
||||
uses))))))
|
||||
|
||||
;; A continuation is a "branch" if all of its predecessors are $kif
|
||||
;; continuations.
|
||||
(define (branch? k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map k use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
(and (not (null? uses))
|
||||
(and-map (lambda (k)
|
||||
(match (lookup-cont k conts)
|
||||
(($ $kif) #t)
|
||||
(_ #f)))
|
||||
uses)))))))
|
||||
|
||||
(define (find-other-branches k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map k use-maps)
|
||||
(($ $use-map sym def (uses ..1))
|
||||
(map (lambda (kif)
|
||||
(match (lookup-cont kif conts)
|
||||
(($ $kif (? (cut eq? <> k)) kf)
|
||||
kf)
|
||||
(($ $kif kt (? (cut eq? <> k)))
|
||||
kt)
|
||||
(_ (error "Not all predecessors are branches"))))
|
||||
uses))))))
|
||||
|
||||
(define (dead-after-branch? sym branch other-branches dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-use-map sym use-maps)
|
||||
(($ $use-map sym def uses)
|
||||
(and-map
|
||||
(lambda (use-k)
|
||||
;; A symbol is dead after a branch if at least one of the
|
||||
;; other branches dominates a use of the symbol, and all
|
||||
;; other uses of the symbol dominate the test.
|
||||
(if (or-map (cut conservatively-dominates? <> use-k uplinks)
|
||||
other-branches)
|
||||
(not (conservatively-dominates? branch use-k uplinks))
|
||||
(conservatively-dominates? use-k branch uplinks)))
|
||||
uses))))))
|
||||
|
||||
(define (lookup-bound-syms k dfg)
|
||||
(match dfg
|
||||
(($ $dfg conts use-maps uplinks)
|
||||
(match (lookup-cont k conts)
|
||||
(($ $kargs names syms body)
|
||||
syms)))))
|
||||
419
module/language/cps/slot-allocation.scm
Normal file
419
module/language/cps/slot-allocation.scm
Normal file
|
|
@ -0,0 +1,419 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013 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
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; A module to assign stack slots to variables in a CPS term.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps slot-allocation)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (language cps)
|
||||
#:use-module (language cps dfg)
|
||||
#:export (allocate-slots
|
||||
lookup-slot
|
||||
lookup-constant-value
|
||||
lookup-maybe-constant-value
|
||||
lookup-nlocals
|
||||
lookup-call-proc-slot
|
||||
lookup-parallel-moves))
|
||||
|
||||
;; Continuations can bind variables. The $allocation structure
|
||||
;; represents the slot in which a variable is stored.
|
||||
;;
|
||||
;; Not all variables have slots allocated. Variables that are constant
|
||||
;; and that are only used by primcalls that can accept constants
|
||||
;; directly are not allocated to slots, and their SLOT value is false.
|
||||
;; Likewise constants that are only used by calls are not allocated into
|
||||
;; slots, to avoid needless copying. If a variable is constant, its
|
||||
;; constant value is set to the CONST slot and HAS-CONST? is set to a
|
||||
;; true value.
|
||||
;;
|
||||
;; DEF holds the label of the continuation that defines the variable,
|
||||
;; and DEAD is a list of continuations at which the variable becomes
|
||||
;; dead.
|
||||
(define-record-type $allocation
|
||||
(make-allocation def slot dead has-const? const)
|
||||
allocation?
|
||||
(def allocation-def)
|
||||
(slot allocation-slot)
|
||||
(dead allocation-dead set-allocation-dead!)
|
||||
(has-const? allocation-has-const?)
|
||||
(const allocation-const))
|
||||
|
||||
;; Continuations can also have associated allocation data. For example,
|
||||
;; when a call happens in a labelled continuation, we need to know what
|
||||
;; slot the procedure goes in. Likewise before branching to the target
|
||||
;; continuation, we might need to shuffle values into the right place: a
|
||||
;; parallel move. $cont-allocation stores allocation data keyed on the
|
||||
;; continuation label.
|
||||
(define-record-type $cont-allocation
|
||||
(make-cont-allocation call-proc-slot parallel-moves)
|
||||
cont-allocation?
|
||||
|
||||
;; Currently calls are allocated in the caller frame, above all locals
|
||||
;; that are live at the time of the call. Therefore there is no
|
||||
;; parallel move problem. We could be more clever here.
|
||||
(call-proc-slot cont-call-proc-slot)
|
||||
|
||||
;; Tail calls, multiple-value returns, and jumps to continuations with
|
||||
;; multiple arguments are forms of parallel assignment. A
|
||||
;; $parallel-move represents a specific solution to the parallel
|
||||
;; assignment problem, with an ordered list of (SRC . DST) moves. This
|
||||
;; may involve a temporary variable.
|
||||
;;
|
||||
;; ((src . dst) ...)
|
||||
(parallel-moves cont-parallel-moves))
|
||||
|
||||
(define (find-first-zero n)
|
||||
;; Naive implementation.
|
||||
(let lp ((slot 0))
|
||||
(if (logbit? slot n)
|
||||
(lp (1+ slot))
|
||||
slot)))
|
||||
|
||||
(define (find-first-trailing-zero n count)
|
||||
(let lp ((slot count))
|
||||
(if (or (zero? slot) (logbit? (1- slot) n))
|
||||
slot
|
||||
(lp (1- slot)))))
|
||||
|
||||
(define (lookup-allocation sym allocation)
|
||||
(let ((res (hashq-ref allocation sym)))
|
||||
(unless res
|
||||
(error "Variable or continuation not defined" sym))
|
||||
res))
|
||||
|
||||
(define (lookup-slot sym allocation)
|
||||
(match (lookup-allocation sym allocation)
|
||||
(($ $allocation def slot dead has-const? const) slot)))
|
||||
|
||||
(define (lookup-constant-value sym allocation)
|
||||
(match (lookup-allocation sym allocation)
|
||||
(($ $allocation def slot dead #t const) const)
|
||||
(_
|
||||
(error "Variable does not have constant value" sym))))
|
||||
|
||||
(define (lookup-maybe-constant-value sym allocation)
|
||||
(match (lookup-allocation sym allocation)
|
||||
(($ $allocation def slot dead has-const? const)
|
||||
(values has-const? const))))
|
||||
|
||||
(define (lookup-call-proc-slot k allocation)
|
||||
(match (lookup-allocation k allocation)
|
||||
(($ $cont-allocation proc-slot parallel-moves)
|
||||
(unless proc-slot
|
||||
(error "Continuation not a call" k))
|
||||
proc-slot)
|
||||
(_
|
||||
(error "Continuation not a call" k))))
|
||||
|
||||
(define (lookup-nlocals k allocation)
|
||||
(match (lookup-allocation k allocation)
|
||||
((? number? nlocals) nlocals)
|
||||
(_
|
||||
(error "Not a clause continuation" k))))
|
||||
|
||||
(define (lookup-parallel-moves k allocation)
|
||||
(match (lookup-allocation k allocation)
|
||||
(($ $cont-allocation proc-slot parallel-moves)
|
||||
(unless parallel-moves
|
||||
(error "Continuation does not have parallel moves" k))
|
||||
parallel-moves)
|
||||
(_
|
||||
(error "Continuation not a call" k))))
|
||||
|
||||
(define (solve-parallel-move src dst tmp)
|
||||
"Solve the parallel move problem between src and dst slot lists, which
|
||||
are comparable with eqv?. A tmp slot may be used."
|
||||
|
||||
;; This algorithm is taken from: "Tilting at windmills with Coq:
|
||||
;; formal verification of a compilation algorithm for parallel moves"
|
||||
;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy
|
||||
;; <http://gallium.inria.fr/~xleroy/publi/parallel-move.pdf>
|
||||
|
||||
(define (split-move moves reg)
|
||||
(let loop ((revhead '()) (tail moves))
|
||||
(match tail
|
||||
(((and s+d (s . d)) . rest)
|
||||
(if (eqv? s reg)
|
||||
(cons d (append-reverse revhead rest))
|
||||
(loop (cons s+d revhead) rest)))
|
||||
(_ #f))))
|
||||
|
||||
(define (replace-last-source reg moves)
|
||||
(match moves
|
||||
((moves ... (s . d))
|
||||
(append moves (list (cons reg d))))))
|
||||
|
||||
(let loop ((to-move (map cons src dst))
|
||||
(being-moved '())
|
||||
(moved '())
|
||||
(last-source #f))
|
||||
;; 'last-source' should always be equivalent to:
|
||||
;; (and (pair? being-moved) (car (last being-moved)))
|
||||
(match being-moved
|
||||
(() (match to-move
|
||||
(() (reverse moved))
|
||||
(((and s+d (s . d)) . t1)
|
||||
(if (or (eqv? s d) ; idempotent
|
||||
(not s)) ; src is a constant and can be loaded directly
|
||||
(loop t1 '() moved #f)
|
||||
(loop t1 (list s+d) moved s)))))
|
||||
(((and s+d (s . d)) . b)
|
||||
(match (split-move to-move d)
|
||||
((r . t1) (loop t1 (acons d r being-moved) moved last-source))
|
||||
(#f (match b
|
||||
(() (loop to-move '() (cons s+d moved) #f))
|
||||
(_ (if (eqv? d last-source)
|
||||
(loop to-move
|
||||
(replace-last-source tmp b)
|
||||
(cons s+d (acons d tmp moved))
|
||||
tmp)
|
||||
(loop to-move b (cons s+d moved) last-source))))))))))
|
||||
|
||||
(define (allocate-slots fun)
|
||||
(define (empty-live-set)
|
||||
(cons #b0 '()))
|
||||
|
||||
(define (add-live-variable sym slot live-set)
|
||||
(cons (logior (car live-set) (ash 1 slot))
|
||||
(acons sym slot (cdr live-set))))
|
||||
|
||||
(define (remove-live-variable sym slot live-set)
|
||||
(cons (logand (car live-set) (lognot (ash 1 slot)))
|
||||
(acons sym #f (cdr live-set))))
|
||||
|
||||
(define (fold-live-set proc seed live-set)
|
||||
(let lp ((bits (car live-set)) (clauses (cdr live-set)) (seed seed))
|
||||
(if (zero? bits)
|
||||
seed
|
||||
(match clauses
|
||||
(((sym . slot) . clauses)
|
||||
(if (and slot (logbit? slot bits))
|
||||
(lp (logand bits (lognot (ash 1 slot)))
|
||||
clauses
|
||||
(proc sym slot seed))
|
||||
(lp bits clauses seed)))))))
|
||||
|
||||
(define (compute-slot live-set hint)
|
||||
(if (and hint (not (logbit? hint (car live-set))))
|
||||
hint
|
||||
(find-first-zero (car live-set))))
|
||||
|
||||
(define (compute-call-proc-slot live-set nlocals)
|
||||
(+ 3 (find-first-trailing-zero (car live-set) nlocals)))
|
||||
|
||||
(define dfg (compute-dfg fun #:global? #f))
|
||||
(define allocation (make-hash-table))
|
||||
|
||||
(define (visit-clause clause live-set)
|
||||
(define nlocals (compute-slot live-set #f))
|
||||
(define nargs
|
||||
(match clause
|
||||
(($ $cont _ _ ($ $kclause _ ($ $cont _ _ ($ $kargs names syms))))
|
||||
(length syms))))
|
||||
|
||||
(define (allocate! sym k hint live-set)
|
||||
(match (hashq-ref allocation sym)
|
||||
(($ $allocation def slot dead has-const)
|
||||
;; Parallel move already allocated this one.
|
||||
(if slot
|
||||
(add-live-variable sym slot live-set)
|
||||
live-set))
|
||||
(_
|
||||
(call-with-values (lambda () (find-constant-value sym dfg))
|
||||
(lambda (has-const? const)
|
||||
(cond
|
||||
((and has-const? (not (constant-needs-allocation? sym const dfg)))
|
||||
(hashq-set! allocation sym
|
||||
(make-allocation k #f '() has-const? const))
|
||||
live-set)
|
||||
(else
|
||||
(let ((slot (compute-slot live-set hint)))
|
||||
(when (>= slot nlocals)
|
||||
(set! nlocals (+ slot 1)))
|
||||
(hashq-set! allocation sym
|
||||
(make-allocation k slot '() has-const? const))
|
||||
(add-live-variable sym slot live-set)))))))))
|
||||
|
||||
(define (dead sym k live-set)
|
||||
(match (lookup-allocation sym allocation)
|
||||
((and allocation ($ $allocation def slot dead has-const? const))
|
||||
(set-allocation-dead! allocation (cons k dead))
|
||||
(remove-live-variable sym slot live-set))))
|
||||
|
||||
(define (allocate-frame! k nargs live-set)
|
||||
(let ((proc-slot (compute-call-proc-slot live-set nlocals)))
|
||||
(set! nlocals (max nlocals (+ proc-slot 1 nargs)))
|
||||
(hashq-set! allocation k
|
||||
(make-cont-allocation
|
||||
proc-slot
|
||||
(match (hashq-ref allocation k)
|
||||
(($ $cont-allocation #f moves) moves)
|
||||
(#f #f))))
|
||||
live-set))
|
||||
|
||||
(define (parallel-move! src-k src-slots pre-live-set post-live-set dst-slots)
|
||||
(let* ((tmp-slot (find-first-zero (logior (car pre-live-set)
|
||||
(car post-live-set))))
|
||||
(moves (solve-parallel-move src-slots dst-slots tmp-slot)))
|
||||
(when (and (>= tmp-slot nlocals) (assv tmp-slot moves))
|
||||
(set! nlocals (+ tmp-slot 1)))
|
||||
(hashq-set! allocation src-k
|
||||
(make-cont-allocation
|
||||
(match (hashq-ref allocation src-k)
|
||||
(($ $cont-allocation proc-slot #f) proc-slot)
|
||||
(#f #f))
|
||||
moves))
|
||||
post-live-set))
|
||||
|
||||
(define (visit-cont cont label live-set)
|
||||
(define (maybe-kill-definition sym live-set)
|
||||
(if (and (lookup-slot sym allocation) (dead-after-def? sym dfg))
|
||||
(dead sym label live-set)
|
||||
live-set))
|
||||
|
||||
(define (kill-conditionally-dead live-set)
|
||||
(if (branch? label dfg)
|
||||
(let ((branches (find-other-branches label dfg)))
|
||||
(fold-live-set
|
||||
(lambda (sym slot live-set)
|
||||
(if (and (> slot nargs)
|
||||
(dead-after-branch? sym label branches dfg))
|
||||
(dead sym label live-set)
|
||||
live-set))
|
||||
live-set
|
||||
live-set))
|
||||
live-set))
|
||||
|
||||
(match cont
|
||||
(($ $kentry self tail clauses)
|
||||
(let ((live-set (allocate! self label 0 live-set)))
|
||||
(for-each (cut visit-cont <> label live-set) clauses))
|
||||
live-set)
|
||||
|
||||
(($ $kclause arity ($ $cont k src body))
|
||||
(visit-cont body k live-set))
|
||||
|
||||
(($ $kargs names syms body)
|
||||
(visit-term body label
|
||||
(kill-conditionally-dead
|
||||
(fold maybe-kill-definition
|
||||
(fold (cut allocate! <> label #f <>) live-set syms)
|
||||
syms))))
|
||||
|
||||
(($ $ktrunc) live-set)
|
||||
(($ $kif) live-set)))
|
||||
|
||||
(define (visit-term term label live-set)
|
||||
(match term
|
||||
(($ $letk conts body)
|
||||
(let ((live-set (visit-term body label live-set)))
|
||||
(for-each (match-lambda
|
||||
(($ $cont k src cont)
|
||||
(visit-cont cont k live-set)))
|
||||
conts))
|
||||
live-set)
|
||||
|
||||
(($ $continue k exp)
|
||||
(visit-exp exp label k live-set))))
|
||||
|
||||
(define (visit-exp exp label k live-set)
|
||||
(define (use sym live-set)
|
||||
(if (and (lookup-slot sym allocation) (dead-after-use? sym k dfg))
|
||||
(dead sym k live-set)
|
||||
live-set))
|
||||
|
||||
(match exp
|
||||
(($ $var sym)
|
||||
(use sym live-set))
|
||||
|
||||
(($ $call proc args)
|
||||
(match (lookup-cont k (dfg-cont-table dfg))
|
||||
(($ $ktail)
|
||||
(let ((tail-nlocals (1+ (length args))))
|
||||
(set! nlocals (max nlocals tail-nlocals))
|
||||
(parallel-move! label
|
||||
(map (cut lookup-slot <> allocation)
|
||||
(cons proc args))
|
||||
live-set (fold use live-set (cons proc args))
|
||||
(iota tail-nlocals))))
|
||||
(($ $ktrunc arity kargs)
|
||||
(let* ((live-set
|
||||
(fold use
|
||||
(use proc
|
||||
(allocate-frame! label (length args) live-set))
|
||||
args))
|
||||
(proc-slot (lookup-call-proc-slot label allocation))
|
||||
(dst-syms (lookup-bound-syms kargs dfg))
|
||||
(nvals (length dst-syms))
|
||||
(src-slots (map (cut + proc-slot 1 <>) (iota nvals)))
|
||||
(live-set* (fold (cut allocate! <> kargs <> <>)
|
||||
live-set dst-syms src-slots))
|
||||
(dst-slots (map (cut lookup-slot <> allocation)
|
||||
dst-syms)))
|
||||
(parallel-move! label src-slots live-set live-set* dst-slots)))
|
||||
(else
|
||||
(fold use
|
||||
(use proc (allocate-frame! label (length args) live-set))
|
||||
args))))
|
||||
|
||||
(($ $primcall name args)
|
||||
(fold use live-set args))
|
||||
|
||||
(($ $values args)
|
||||
(let ((live-set* (fold use live-set args)))
|
||||
(define (compute-dst-slots)
|
||||
(match (lookup-cont k (dfg-cont-table dfg))
|
||||
(($ $ktail)
|
||||
(let ((tail-nlocals (1+ (length args))))
|
||||
(set! nlocals (max nlocals tail-nlocals))
|
||||
(cdr (iota tail-nlocals))))
|
||||
(_
|
||||
(let* ((src-slots (map (cut lookup-slot <> allocation) args))
|
||||
(dst-syms (lookup-bound-syms k dfg))
|
||||
(dst-live-set (fold (cut allocate! <> k <> <>)
|
||||
live-set* dst-syms src-slots)))
|
||||
(map (cut lookup-slot <> allocation) dst-syms)))))
|
||||
|
||||
(parallel-move! label
|
||||
(map (cut lookup-slot <> allocation) args)
|
||||
live-set live-set*
|
||||
(compute-dst-slots))))
|
||||
|
||||
(($ $prompt escape? tag handler)
|
||||
(use tag live-set))
|
||||
|
||||
(_ live-set)))
|
||||
|
||||
(match clause
|
||||
(($ $cont k _ body)
|
||||
(visit-cont body k live-set)
|
||||
(hashq-set! allocation k nlocals))))
|
||||
|
||||
(match fun
|
||||
(($ $fun meta free ($ $cont k _ ($ $kentry self tail clauses)))
|
||||
(let ((live-set (add-live-variable self 0 (empty-live-set))))
|
||||
(hashq-set! allocation self (make-allocation k 0 '() #f #f))
|
||||
(for-each (cut visit-clause <> live-set) clauses)
|
||||
allocation))))
|
||||
|
|
@ -21,6 +21,7 @@
|
|||
(define-module (language cps spec)
|
||||
#:use-module (system base language)
|
||||
#:use-module (language cps)
|
||||
#:use-module (language cps compile-rtl)
|
||||
#:export (cps))
|
||||
|
||||
(define* (write-cps exp #:optional (port (current-output-port)))
|
||||
|
|
@ -31,6 +32,6 @@
|
|||
#:reader (lambda (port env) (read port))
|
||||
#:printer write-cps
|
||||
#:parser parse-cps
|
||||
#:compilers '()
|
||||
#:compilers `((rtl . ,compile-rtl))
|
||||
#:for-humans? #f
|
||||
)
|
||||
|
|
|
|||
|
|
@ -115,6 +115,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/receive.test \
|
||||
tests/regexp.test \
|
||||
tests/rtl.test \
|
||||
tests/rtl-compilation.test \
|
||||
tests/session.test \
|
||||
tests/signals.test \
|
||||
tests/srcprop.test \
|
||||
|
|
|
|||
200
test-suite/tests/rtl-compilation.test
Normal file
200
test-suite/tests/rtl-compilation.test
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
;;;; rtl-compilation.test --- test suite for compiling via rtl -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2013 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
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 3 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
|
||||
(define-module (test-suite rtl-compilation)
|
||||
#:use-module (test-suite lib)
|
||||
#:use-module (system base compile)
|
||||
#:use-module (system vm objcode))
|
||||
|
||||
(define* (compile-via-rtl exp #:key peval? cse? (env (make-fresh-user-module)))
|
||||
(load-thunk-from-memory
|
||||
(compile exp #:env env #:to 'rtl
|
||||
#:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
|
||||
|
||||
(define* (run-rtl exp #:key (env (make-fresh-user-module)))
|
||||
(let ((thunk (compile-via-rtl exp #:env env)))
|
||||
(save-module-excursion
|
||||
(lambda ()
|
||||
(set-current-module env)
|
||||
(thunk)))))
|
||||
|
||||
(with-test-prefix "tail context"
|
||||
(pass-if-equal 1
|
||||
(run-rtl '(let ((x 1)) x)))
|
||||
|
||||
(pass-if-equal 1
|
||||
(run-rtl 1))
|
||||
|
||||
(pass-if-equal (if #f #f)
|
||||
(run-rtl '(if #f #f)))
|
||||
|
||||
(pass-if-equal "top-level define"
|
||||
(list (if #f #f) 1)
|
||||
(let ((mod (make-fresh-user-module)))
|
||||
(let ((result (run-rtl '(define v 1) #:env mod)))
|
||||
(list result (module-ref mod 'v)))))
|
||||
|
||||
(pass-if-equal "top-level set!"
|
||||
(list (if #f #f) 1)
|
||||
(let ((mod (make-fresh-user-module)))
|
||||
(module-define! mod 'v #f)
|
||||
(let ((result (run-rtl '(set! v 1) #:env mod)))
|
||||
(list result (module-ref mod 'v)))))
|
||||
|
||||
(pass-if-equal "top-level apply [single value]"
|
||||
8
|
||||
(let ((mod (make-fresh-user-module)))
|
||||
(module-define! mod 'args '(2 3))
|
||||
(run-rtl '(apply expt args) #:env mod)))
|
||||
|
||||
(pass-if-equal "top-level apply [zero values]"
|
||||
'()
|
||||
(let ((mod (make-fresh-user-module)))
|
||||
(module-define! mod 'proc (lambda () (values)))
|
||||
(module-define! mod 'args '())
|
||||
(call-with-values
|
||||
(lambda () (run-rtl '(apply proc args) #:env mod))
|
||||
list)))
|
||||
|
||||
(pass-if-equal "top-level apply [two values]"
|
||||
'(1 2)
|
||||
(let ((mod (make-fresh-user-module)))
|
||||
(module-define! mod 'proc (lambda (n d) (floor/ n d)))
|
||||
(module-define! mod 'args '(5 3))
|
||||
(call-with-values
|
||||
(lambda () (run-rtl '(apply proc args) #:env mod))
|
||||
list)))
|
||||
|
||||
(pass-if-equal "call-with-values"
|
||||
'(1 2 3)
|
||||
((run-rtl '(lambda (n d)
|
||||
(call-with-values (lambda () (floor/ n d))
|
||||
(lambda (q r) (list q r (+ q r))))))
|
||||
5 3))
|
||||
|
||||
(pass-if-equal cons
|
||||
(run-rtl 'cons))
|
||||
|
||||
(pass-if-equal 1
|
||||
((run-rtl '(lambda () 1))))
|
||||
|
||||
(pass-if-equal 1
|
||||
((run-rtl '(lambda (x) 1)) 2))
|
||||
|
||||
(pass-if-equal 1
|
||||
((run-rtl '(lambda (x) x)) 1))
|
||||
|
||||
(pass-if-equal 6
|
||||
((((run-rtl '(lambda (x)
|
||||
(lambda (y)
|
||||
(lambda (z)
|
||||
(+ x y z))))) 1) 2) 3))
|
||||
|
||||
(pass-if-equal 1
|
||||
(run-rtl '(identity 1)))
|
||||
|
||||
(pass-if-equal '(1 . 2)
|
||||
(run-rtl '(cons 1 2)))
|
||||
|
||||
(pass-if-equal '(1 2)
|
||||
(call-with-values (lambda () (run-rtl '(values 1 2))) list))
|
||||
|
||||
(pass-if-equal 28
|
||||
((run-rtl '(lambda (x y z rest) (apply + x y z rest)))
|
||||
2 3 5 '(7 11)))
|
||||
|
||||
;; prompts
|
||||
)
|
||||
|
||||
(with-test-prefix "value context"
|
||||
1
|
||||
)
|
||||
|
||||
(with-test-prefix "drop context"
|
||||
1
|
||||
)
|
||||
|
||||
(with-test-prefix "test context"
|
||||
1
|
||||
)
|
||||
|
||||
(with-test-prefix "values context"
|
||||
(pass-if-equal '(3 . 1)
|
||||
(run-rtl
|
||||
'(let ((rat (lambda (n d)
|
||||
(call-with-values
|
||||
(lambda () (floor/ n d))
|
||||
(lambda (q r)
|
||||
(cons q r))))))
|
||||
(rat 10 3)))))
|
||||
|
||||
(with-test-prefix "contification"
|
||||
(pass-if ((run-rtl '(lambda (x)
|
||||
(define (even? x)
|
||||
(if (null? x) #t (odd? (cdr x))))
|
||||
(define (odd? x)
|
||||
(if (null? x) #f (even? (cdr x))))
|
||||
(even? x)))
|
||||
'(1 2 3 4)))
|
||||
|
||||
(pass-if (not ((run-rtl '(lambda (x)
|
||||
(define (even? x)
|
||||
(if (null? x) #t (odd? (cdr x))))
|
||||
(define (odd? x)
|
||||
(if (null? x) #f (even? (cdr x))))
|
||||
(even? x)))
|
||||
'(1 2 3)))))
|
||||
|
||||
(with-test-prefix "case-lambda"
|
||||
(pass-if-equal "simple"
|
||||
'(0 3 9 28)
|
||||
(let ((proc (run-rtl '(case-lambda
|
||||
(() 0)
|
||||
((x) x)
|
||||
((x y) (+ x y))
|
||||
((x y z . rest) (apply + x y z rest))))))
|
||||
(map (lambda (args) (apply proc args))
|
||||
'(() (3) (2 7) (2 3 5 7 11)))))
|
||||
|
||||
(pass-if-exception "no match"
|
||||
exception:wrong-num-args
|
||||
((run-rtl '(case-lambda ((x) x) ((x y) (+ x y))))
|
||||
1 2 3))
|
||||
|
||||
(pass-if-exception "zero clauses called with no args"
|
||||
exception:wrong-num-args
|
||||
((run-rtl '(case-lambda))))
|
||||
|
||||
(pass-if-exception "zero clauses called with args"
|
||||
exception:wrong-num-args
|
||||
((run-rtl '(case-lambda)) 1)))
|
||||
|
||||
(with-test-prefix "mixed contexts"
|
||||
(pass-if-equal "sequences" '(3 4 5)
|
||||
(let* ((pair (cons 1 2))
|
||||
(result ((run-rtl '(lambda (pair)
|
||||
(set-car! pair 3)
|
||||
(set-cdr! pair 4)
|
||||
5))
|
||||
pair)))
|
||||
(list (car pair)
|
||||
(cdr pair)
|
||||
result)))
|
||||
|
||||
(pass-if-equal "mutable lexicals" 2
|
||||
(run-rtl '(let ((n 1)) (set! n 2) n))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue