mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-22 03:30:22 +02:00
Replace $letrec with $rec
* module/language/cps.scm ($rec): Replace $letrec with $rec, which is an expression, not a term. This means that the names bound by the letrec appear twice: once in the $rec term, and once in the continuation. This is not very elegant, but the situation is better than it was before. Adapt all callers. * doc/ref/compiler.texi (CPS in Guile): Incomplete documentation updates. I'll update these later when the IL settles down.
This commit is contained in:
Andy Wingo
parent
4ce1857019
commit
34ff3af9f0
21 changed files with 361 additions and 384 deletions
|
|
@ -113,7 +113,7 @@
|
|||
make-$arity
|
||||
|
||||
;; Terms.
|
||||
$letk $continue $letrec
|
||||
$letk $continue
|
||||
|
||||
;; Continuations.
|
||||
$cont
|
||||
|
|
@ -122,7 +122,7 @@
|
|||
$kreceive $kargs $kfun $ktail $kclause
|
||||
|
||||
;; Expressions.
|
||||
$const $prim $fun $closure $branch
|
||||
$const $prim $fun $rec $closure $branch
|
||||
$call $callk $primcall $values $prompt
|
||||
|
||||
;; First-order CPS root.
|
||||
|
|
@ -177,7 +177,6 @@
|
|||
;; Terms.
|
||||
(define-cps-type $letk conts body)
|
||||
(define-cps-type $continue k src exp)
|
||||
(define-cps-type $letrec names syms funs body) ; Higher-order.
|
||||
|
||||
;; Continuations
|
||||
(define-cps-type $cont k cont)
|
||||
|
|
@ -191,6 +190,7 @@
|
|||
(define-cps-type $const val)
|
||||
(define-cps-type $prim name)
|
||||
(define-cps-type $fun free body) ; Higher-order.
|
||||
(define-cps-type $rec names syms funs) ; Higher-order.
|
||||
(define-cps-type $closure label nfree) ; First-order.
|
||||
(define-cps-type $branch k exp)
|
||||
(define-cps-type $call proc args)
|
||||
|
|
@ -263,12 +263,13 @@
|
|||
|
||||
(define-syntax build-cps-exp
|
||||
(syntax-rules (unquote
|
||||
$const $prim $fun $closure $branch
|
||||
$const $prim $fun $rec $closure $branch
|
||||
$call $callk $primcall $values $prompt)
|
||||
((_ (unquote exp)) exp)
|
||||
((_ ($const val)) (make-$const val))
|
||||
((_ ($prim name)) (make-$prim name))
|
||||
((_ ($fun free body)) (make-$fun free (build-cps-cont body)))
|
||||
((_ ($rec names gensyms funs)) (make-$rec names gensyms funs))
|
||||
((_ ($closure k nfree)) (make-$closure k nfree))
|
||||
((_ ($call proc (unquote args))) (make-$call proc args))
|
||||
((_ ($call proc (arg ...))) (make-$call proc (list arg ...)))
|
||||
|
|
@ -287,7 +288,7 @@
|
|||
(make-$prompt escape? tag handler))))
|
||||
|
||||
(define-syntax build-cps-term
|
||||
(syntax-rules (unquote $letk $letk* $letconst $letrec $program $continue)
|
||||
(syntax-rules (unquote $letk $letk* $letconst $program $continue)
|
||||
((_ (unquote exp))
|
||||
exp)
|
||||
((_ ($letk (unquote conts) body))
|
||||
|
|
@ -308,8 +309,6 @@
|
|||
($continue kconst (let ((props (source-properties val)))
|
||||
(and (pair? props) props))
|
||||
($const val))))))
|
||||
((_ ($letrec names gensyms funs body))
|
||||
(make-$letrec names gensyms funs (build-cps-term body)))
|
||||
((_ ($program (unquote conts)))
|
||||
(make-$program conts))
|
||||
((_ ($program (cont ...)))
|
||||
|
|
@ -386,9 +385,8 @@
|
|||
(build-cps-exp ($fun free ,(parse-cps body))))
|
||||
(('closure k nfree)
|
||||
(build-cps-exp ($closure k nfree)))
|
||||
(('letrec ((name sym fun) ...) body)
|
||||
(build-cps-term
|
||||
($letrec name sym (map parse-cps fun) ,(parse-cps body))))
|
||||
(('rec (name sym fun) ...)
|
||||
(build-cps-exp ($rec name sym (map parse-cps fun))))
|
||||
(('program (cont ...))
|
||||
(build-cps-term ($program ,(map parse-cps cont))))
|
||||
(('call proc arg ...)
|
||||
|
|
@ -445,11 +443,10 @@
|
|||
`(fun ,free ,(unparse-cps body)))
|
||||
(($ $closure k nfree)
|
||||
`(closure ,k ,nfree))
|
||||
(($ $letrec names syms funs body)
|
||||
`(letrec ,(map (lambda (name sym fun)
|
||||
(list name sym (unparse-cps fun)))
|
||||
names syms funs)
|
||||
,(unparse-cps body)))
|
||||
(($ $rec names syms funs)
|
||||
`(rec ,@(map (lambda (name sym fun)
|
||||
(list name sym (unparse-cps fun)))
|
||||
names syms funs)))
|
||||
(($ $program conts)
|
||||
`(program ,(map unparse-cps conts)))
|
||||
(($ $call proc args)
|
||||
|
|
@ -509,15 +506,13 @@
|
|||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $fun) (fun-folder exp seed ...))
|
||||
(_ (values seed ...))))
|
||||
|
||||
(($ $letrec names syms funs body)
|
||||
(let-values (((seed ...) (term-folder body seed ...)))
|
||||
(let lp ((funs funs) (seed seed) ...)
|
||||
(if (null? funs)
|
||||
(values seed ...)
|
||||
(let-values (((seed ...) (fun-folder (car funs) seed ...)))
|
||||
(lp (cdr funs) seed ...))))))))
|
||||
(($ $rec names syms funs)
|
||||
(let lp ((funs funs) (seed seed) ...)
|
||||
(if (null? funs)
|
||||
(values seed ...)
|
||||
(let-values (((seed ...) (fun-folder (car funs) seed ...)))
|
||||
(lp (cdr funs) seed ...)))))
|
||||
(_ (values seed ...))))))
|
||||
|
||||
(cont-folder cont seed ...)))
|
||||
|
||||
|
|
@ -541,7 +536,6 @@
|
|||
((cont . conts)
|
||||
(let-values (((seed ...) (cont-folder cont seed ...)))
|
||||
(lp conts seed ...)))))))
|
||||
(($ $letrec names syms funs body) (term-folder body seed ...))
|
||||
(_ (values seed ...))))
|
||||
(define (clause-folder clause seed ...)
|
||||
(match clause
|
||||
|
|
@ -567,12 +561,7 @@
|
|||
(values (max label max-label)
|
||||
(match cont
|
||||
(($ $kargs names vars body)
|
||||
(let lp ((body body) (max-var (fold max max-var vars)))
|
||||
(match body
|
||||
(($ $letk conts body) (lp body max-var))
|
||||
(($ $letrec names vars funs body)
|
||||
(lp body (fold max max-var vars)))
|
||||
(_ max-var))))
|
||||
(fold max max-var vars))
|
||||
(($ $kfun src meta self)
|
||||
(max self max-var))
|
||||
(_ max-var))))
|
||||
|
|
@ -612,7 +601,6 @@
|
|||
(let lp ((body body))
|
||||
(match body
|
||||
(($ $letk conts body) (lp body))
|
||||
(($ $letrec names vars funs body) (lp body))
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler) (proc k handler))
|
||||
|
|
|
|||
|
|
@ -40,13 +40,6 @@
|
|||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map (lambda (fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun free body)
|
||||
($fun free ,(fix-arities* body dfg)))))
|
||||
funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src exp)
|
||||
,(visit-exp k src exp))))
|
||||
|
||||
|
|
@ -143,6 +136,14 @@
|
|||
(($ $fun free body)
|
||||
,(adapt-exp 1 k src (build-cps-exp
|
||||
($fun free ,(fix-arities* body dfg)))))
|
||||
(($ $rec names syms funs)
|
||||
;; Assume $rec expressions have the correct arity.
|
||||
($continue k src
|
||||
($rec names syms (map (lambda (fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun free body)
|
||||
($fun free ,(fix-arities* body dfg)))))
|
||||
funs))))
|
||||
((or ($ $call) ($ $callk))
|
||||
;; In general, calls have unknown return arity. For that
|
||||
;; reason every non-tail call has a $kreceive continuation to
|
||||
|
|
|
|||
|
|
@ -23,15 +23,16 @@
|
|||
;;; make-closure primcalls, and free variables are referenced through
|
||||
;;; the closure.
|
||||
;;;
|
||||
;;; Closure conversion also removes any $letrec forms that contification
|
||||
;;; did not handle. See (language cps) for a further discussion of
|
||||
;;; $letrec.
|
||||
;;; Closure conversion also removes any $rec expressions that
|
||||
;;; contification did not handle. See (language cps) for a further
|
||||
;;; discussion of $rec.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (language cps closure-conversion)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module ((srfi srfi-1) #:select (fold
|
||||
filter-map
|
||||
lset-union lset-difference
|
||||
list-index))
|
||||
#:use-module (srfi srfi-9)
|
||||
|
|
@ -48,7 +49,8 @@
|
|||
(let ((bound-vars (make-hash-table))
|
||||
(free-vars (make-hash-table))
|
||||
(named-funs (make-hash-table))
|
||||
(well-known-vars (make-bitvector (var-counter) #t)))
|
||||
(well-known-vars (make-bitvector (var-counter) #t))
|
||||
(letrec-conts (make-hash-table)))
|
||||
(define (add-named-fun! var cont)
|
||||
(hashq-set! named-funs var cont)
|
||||
(match cont
|
||||
|
|
@ -97,13 +99,6 @@
|
|||
(union (visit-cont cont bound) free))
|
||||
(visit-term body bound)
|
||||
conts))
|
||||
(($ $letrec names vars (($ $fun () cont) ...) body)
|
||||
(let ((bound (append vars bound)))
|
||||
(for-each add-named-fun! vars cont)
|
||||
(fold (lambda (cont free)
|
||||
(union (visit-cont cont bound) free))
|
||||
(visit-term body bound)
|
||||
cont)))
|
||||
(($ $continue k src ($ $fun () body))
|
||||
(match (lookup-predecessors k dfg)
|
||||
((_) (match (lookup-cont k dfg)
|
||||
|
|
@ -111,6 +106,14 @@
|
|||
(add-named-fun! var body))))
|
||||
(_ #f))
|
||||
(visit-cont body bound))
|
||||
(($ $continue k src ($ $rec names vars (($ $fun () cont) ...)))
|
||||
(hashq-set! letrec-conts k (lookup-cont k dfg))
|
||||
(let ((bound (append vars bound)))
|
||||
(for-each add-named-fun! vars cont)
|
||||
(fold (lambda (cont free)
|
||||
(union (visit-cont cont bound) free))
|
||||
'()
|
||||
cont)))
|
||||
(($ $continue k src exp)
|
||||
(visit-exp exp bound))))
|
||||
(define (visit-exp exp bound)
|
||||
|
|
@ -138,7 +141,8 @@
|
|||
(let ((free (visit-cont exp '())))
|
||||
(unless (null? free)
|
||||
(error "Expected no free vars in toplevel thunk" free exp))
|
||||
(values bound-vars free-vars named-funs (compute-well-known-labels)))))
|
||||
(values bound-vars free-vars named-funs (compute-well-known-labels)
|
||||
letrec-conts))))
|
||||
|
||||
(define (prune-free-vars free-vars named-funs well-known var-aliases)
|
||||
(define (well-known? label)
|
||||
|
|
@ -229,7 +233,8 @@
|
|||
(vector-set! var-aliases var alias))))))
|
||||
named-funs)))
|
||||
|
||||
(define (convert-one bound label fun free-vars named-funs well-known aliases)
|
||||
(define (convert-one bound label fun free-vars named-funs well-known aliases
|
||||
letrec-conts)
|
||||
(define (well-known? label)
|
||||
(bitvector-ref well-known label))
|
||||
|
||||
|
|
@ -422,31 +427,18 @@ bound to @var{var}, and continue with @var{body}."
|
|||
(label ($kclause ,arity ,(visit-cont body)
|
||||
,(and alternate (visit-cont alternate)))))
|
||||
(($ $cont) ,cont)))
|
||||
(define (maybe-visit-cont cont)
|
||||
(match cont
|
||||
;; We will inline the $kargs that binds letrec vars in place of
|
||||
;; the $rec expression.
|
||||
(($ $cont label)
|
||||
(and (not (hashq-ref letrec-conts label))
|
||||
(visit-cont cont)))))
|
||||
(define (visit-term term)
|
||||
(match term
|
||||
(($ $letk conts body)
|
||||
(build-cps-term
|
||||
($letk ,(map visit-cont conts) ,(visit-term body))))
|
||||
|
||||
;; Remove letrec.
|
||||
(($ $letrec names vars funs body)
|
||||
(let lp ((in (map list names vars funs))
|
||||
(bindings (lambda (body) body))
|
||||
(body (visit-term body)))
|
||||
(match in
|
||||
(() (bindings body))
|
||||
(((name var ($ $fun ()
|
||||
(and fun-body
|
||||
($ $cont kfun ($ $kfun src))))) . in)
|
||||
(let ((fun-free (hashq-ref free-vars kfun)))
|
||||
(lp in
|
||||
(lambda (body)
|
||||
(allocate-closure
|
||||
src name var kfun (well-known? kfun) fun-free
|
||||
(bindings body)))
|
||||
(init-closure
|
||||
src var (well-known? kfun) fun-free
|
||||
body)))))))
|
||||
($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body))))
|
||||
|
||||
(($ $continue k src (or ($ $const) ($ $prim)))
|
||||
term)
|
||||
|
|
@ -475,6 +467,31 @@ bound to @var{var}, and continue with @var{body}."
|
|||
src var (well-known? kfun) fun-free
|
||||
(build-cps-term ($continue k src ($values (var)))))))))))
|
||||
|
||||
;; Remove letrec.
|
||||
(($ $continue k src ($ $rec names vars funs))
|
||||
(let lp ((in (map list names vars funs))
|
||||
(bindings (lambda (body) body))
|
||||
(body (match (hashq-ref letrec-conts k)
|
||||
;; Remove these letrec bindings, as we're
|
||||
;; going to inline the body after building
|
||||
;; each closure separately.
|
||||
(($ $kargs names syms body)
|
||||
(visit-term body)))))
|
||||
(match in
|
||||
(() (bindings body))
|
||||
(((name var ($ $fun ()
|
||||
(and fun-body
|
||||
($ $cont kfun ($ $kfun src))))) . in)
|
||||
(let ((fun-free (hashq-ref free-vars kfun)))
|
||||
(lp in
|
||||
(lambda (body)
|
||||
(allocate-closure
|
||||
src name var kfun (well-known? kfun) fun-free
|
||||
(bindings body)))
|
||||
(init-closure
|
||||
src var (well-known? kfun) fun-free
|
||||
body)))))))
|
||||
|
||||
(($ $continue k src ($ $call proc args))
|
||||
(match (hashq-ref named-funs proc)
|
||||
(($ $cont kfun)
|
||||
|
|
@ -534,7 +551,7 @@ and allocate and initialize flat closures."
|
|||
(let ((dfg (compute-dfg fun)))
|
||||
(with-fresh-name-state-from-dfg dfg
|
||||
(call-with-values (lambda () (analyze-closures fun dfg))
|
||||
(lambda (bound-vars free-vars named-funs well-known)
|
||||
(lambda (bound-vars free-vars named-funs well-known letrec-conts)
|
||||
(let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <))
|
||||
(aliases (make-vector (var-counter) #f)))
|
||||
(prune-free-vars free-vars named-funs well-known aliases)
|
||||
|
|
@ -543,5 +560,6 @@ and allocate and initialize flat closures."
|
|||
,(map (lambda (label)
|
||||
(convert-one (hashq-ref bound-vars label) label
|
||||
(lookup-cont label dfg)
|
||||
free-vars named-funs well-known aliases))
|
||||
free-vars named-funs well-known aliases
|
||||
letrec-conts))
|
||||
labels)))))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015 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
|
||||
|
|
@ -46,9 +46,6 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src ($ $primcall 'list args))
|
||||
,(let-fresh (kvalues) (val)
|
||||
(build-cps-term
|
||||
|
|
@ -91,6 +88,8 @@
|
|||
($primcall 'make-vector (len init))))))))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
($continue k src ($rec names syms (map visit-fun funs))))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
(define (visit-fun fun)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015 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
|
||||
|
|
@ -43,14 +43,11 @@
|
|||
(scope-table (make-hash-table))
|
||||
(call-substs '())
|
||||
(cont-substs '())
|
||||
(fun-elisions '())
|
||||
(cont-splices (make-hash-table)))
|
||||
(define (subst-call! sym arities body-ks)
|
||||
(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
|
||||
(define (subst-return! old-tail new-tail)
|
||||
(set! cont-substs (acons old-tail new-tail cont-substs)))
|
||||
(define (elide-function! k cont)
|
||||
(set! fun-elisions (acons k cont fun-elisions)))
|
||||
(define (splice-conts! scope conts)
|
||||
(for-each (match-lambda
|
||||
(($ $cont k) (hashq-set! scope-table k scope)))
|
||||
|
|
@ -237,45 +234,6 @@
|
|||
(($ $letk conts body)
|
||||
(for-each visit-cont conts)
|
||||
(visit-term body term-k))
|
||||
(($ $letrec names syms funs body)
|
||||
(define (split-components nsf)
|
||||
;; FIXME: Compute strongly-connected components. Currently
|
||||
;; we just put non-recursive functions in their own
|
||||
;; components, and lump everything else in the remaining
|
||||
;; component.
|
||||
(define (recursive? k)
|
||||
(or-map (cut variable-free-in? <> k dfg) syms))
|
||||
(let lp ((nsf nsf) (rec '()))
|
||||
(match nsf
|
||||
(()
|
||||
(if (null? rec)
|
||||
'()
|
||||
(list rec)))
|
||||
(((and elt (n s ($ $fun free ($ $cont kfun))))
|
||||
. nsf)
|
||||
(if (recursive? kfun)
|
||||
(lp nsf (cons elt rec))
|
||||
(cons (list elt) (lp nsf rec)))))))
|
||||
(define (extract-arities+bodies clauses)
|
||||
(values (map extract-arities clauses)
|
||||
(map extract-bodies clauses)))
|
||||
(define (visit-component component)
|
||||
(match component
|
||||
(((name sym fun) ...)
|
||||
(match fun
|
||||
((($ $fun free
|
||||
($ $cont fun-k
|
||||
($ $kfun src meta self ($ $cont tail-k ($ $ktail))
|
||||
clause)))
|
||||
...)
|
||||
(call-with-values (lambda () (extract-arities+bodies clause))
|
||||
(lambda (arities bodies)
|
||||
(if (contify-funs term-k sym self tail-k arities bodies)
|
||||
(for-each (cut for-each visit-cont <>) bodies)
|
||||
(for-each visit-fun fun)))))))))
|
||||
(visit-term body term-k)
|
||||
(for-each visit-component
|
||||
(split-components (map list names syms funs))))
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $fun free
|
||||
|
|
@ -287,15 +245,60 @@
|
|||
(extract-arities clause)
|
||||
(extract-bodies clause))))
|
||||
(begin
|
||||
(elide-function! k (lookup-cont k dfg))
|
||||
(for-each visit-cont (extract-bodies clause)))
|
||||
(visit-fun exp)))
|
||||
(($ $rec names syms funs)
|
||||
(define (split-components nsf)
|
||||
;; FIXME: Compute strongly-connected components. Currently
|
||||
;; we just put non-recursive functions in their own
|
||||
;; components, and lump everything else in the remaining
|
||||
;; component.
|
||||
(define (recursive? k)
|
||||
(or-map (cut variable-free-in? <> k dfg) syms))
|
||||
(let lp ((nsf nsf) (rec '()))
|
||||
(match nsf
|
||||
(()
|
||||
(if (null? rec)
|
||||
'()
|
||||
(list rec)))
|
||||
(((and elt (n s ($ $fun free ($ $cont kfun))))
|
||||
. nsf)
|
||||
(if (recursive? kfun)
|
||||
(lp nsf (cons elt rec))
|
||||
(cons (list elt) (lp nsf rec)))))))
|
||||
(define (extract-arities+bodies clauses)
|
||||
(values (map extract-arities clauses)
|
||||
(map extract-bodies clauses)))
|
||||
(define (visit-component component)
|
||||
(match component
|
||||
(((name sym fun) ...)
|
||||
(match fun
|
||||
((($ $fun free
|
||||
($ $cont fun-k
|
||||
($ $kfun src meta self ($ $cont tail-k ($ $ktail))
|
||||
clause)))
|
||||
...)
|
||||
(call-with-values (lambda () (extract-arities+bodies clause))
|
||||
(lambda (arities bodies)
|
||||
;; Technically the procedures are created in
|
||||
;; term-k but bound for use in k. But, there is
|
||||
;; a tight link between term-k and k, as they
|
||||
;; are in the same block. Mark k as the
|
||||
;; contification scope, because that's where
|
||||
;; they'll be used. Perhaps we can fix this
|
||||
;; with the new CPS dialect that doesn't have
|
||||
;; $letk.
|
||||
(if (contify-funs k sym self tail-k arities bodies)
|
||||
(for-each (cut for-each visit-cont <>) bodies)
|
||||
(for-each visit-fun fun)))))))))
|
||||
(for-each visit-component
|
||||
(split-components (map list names syms funs))))
|
||||
(_ #t)))))
|
||||
|
||||
(visit-cont fun)
|
||||
(values call-substs cont-substs fun-elisions cont-splices)))
|
||||
(values call-substs cont-substs cont-splices)))
|
||||
|
||||
(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
|
||||
(define (apply-contification fun call-substs cont-substs cont-splices)
|
||||
(define (contify-call src proc args)
|
||||
(and=> (assq-ref call-substs proc)
|
||||
(lambda (clauses)
|
||||
|
|
@ -331,8 +334,6 @@
|
|||
((cont ...)
|
||||
(let lp ((term term))
|
||||
(rewrite-cps-term term
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms funs ,(lp body)))
|
||||
(($ $letk conts* body)
|
||||
($letk ,(append conts* (filter-map visit-cont cont))
|
||||
,body))
|
||||
|
|
@ -345,16 +346,18 @@
|
|||
($fun free ,(visit-cont body)))))
|
||||
(define (visit-cont cont)
|
||||
(rewrite-cps-cont cont
|
||||
(($ $cont (? (cut assq <> fun-elisions)))
|
||||
;; This cont gets inlined in place of the $fun.
|
||||
,#f)
|
||||
(($ $cont sym ($ $kargs names syms body))
|
||||
(sym ($kargs names syms ,(visit-term body sym))))
|
||||
(($ $cont sym ($ $kfun src meta self tail clause))
|
||||
(sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
|
||||
(($ $cont sym ($ $kclause arity body alternate))
|
||||
(sym ($kclause ,arity ,(visit-cont body)
|
||||
,(and alternate (visit-cont alternate)))))
|
||||
(($ $cont label ($ $kargs names syms body))
|
||||
;; Remove bindings for functions that have been contified.
|
||||
,(rewrite-cps-cont (filter (match-lambda
|
||||
((name sym) (not (assq sym call-substs))))
|
||||
(map list names syms))
|
||||
(((names syms) ...)
|
||||
(label ($kargs names syms ,(visit-term body label))))))
|
||||
(($ $cont label ($ $kfun src meta self tail clause))
|
||||
(label ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
|
||||
(($ $cont label ($ $kclause arity body alternate))
|
||||
(label ($kclause ,arity ,(visit-cont body)
|
||||
,(and alternate (visit-cont alternate)))))
|
||||
(($ $cont)
|
||||
,cont)))
|
||||
(define (visit-term term term-k)
|
||||
|
|
@ -364,37 +367,37 @@
|
|||
(let lp ((body (visit-term body term-k)))
|
||||
;; Because we attach contified functions on a particular
|
||||
;; term-k, and one term-k can correspond to an arbitrarily
|
||||
;; nested sequence of $letrec and $letk instances, normalize
|
||||
;; so that all continuations are bound by one $letk --
|
||||
;; guaranteeing that they are in the same scope.
|
||||
;; nested sequence of $letk instances, normalize so that all
|
||||
;; continuations are bound by one $letk -- guaranteeing that
|
||||
;; they are in the same scope.
|
||||
(rewrite-cps-term body
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms funs ,(lp body)))
|
||||
(($ $letk conts* body)
|
||||
($letk ,(append conts* (filter-map visit-cont conts))
|
||||
,body))
|
||||
(body
|
||||
($letk ,(filter-map visit-cont conts)
|
||||
,body)))))
|
||||
(($ $letrec names syms funs body)
|
||||
(rewrite-cps-term (filter (match-lambda
|
||||
((n s f) (not (assq s call-substs))))
|
||||
(map list names syms funs))
|
||||
(((names syms funs) ...)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body term-k)))))
|
||||
(($ $continue k src exp)
|
||||
(splice-continuations
|
||||
term-k
|
||||
(match exp
|
||||
(($ $fun)
|
||||
(cond
|
||||
((assq-ref fun-elisions k)
|
||||
=> (match-lambda
|
||||
(($ $kargs (_) (_) body)
|
||||
(visit-term body k))))
|
||||
(else
|
||||
(continue k src (visit-fun exp)))))
|
||||
(($ $fun free
|
||||
($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k))))
|
||||
;; If the function's tail continuation has been substituted,
|
||||
;; that means it has been contified.
|
||||
(continue k src
|
||||
(if (assq tail-k cont-substs)
|
||||
(build-cps-exp ($values ()))
|
||||
(visit-fun exp))))
|
||||
(($ $rec names syms funs)
|
||||
(match (filter (match-lambda
|
||||
((n s f) (not (assq s call-substs))))
|
||||
(map list names syms funs))
|
||||
(() (continue k src (build-cps-exp ($values ()))))
|
||||
(((names syms funs) ...)
|
||||
(continue k src
|
||||
(build-cps-exp
|
||||
($rec names syms (map visit-fun funs)))))))
|
||||
(($ $call proc args)
|
||||
(or (contify-call src proc args)
|
||||
(continue k src exp)))
|
||||
|
|
@ -403,9 +406,9 @@
|
|||
|
||||
(define (contify fun)
|
||||
(call-with-values (lambda () (compute-contification fun))
|
||||
(lambda (call-substs cont-substs fun-elisions cont-splices)
|
||||
(lambda (call-substs cont-substs cont-splices)
|
||||
(if (null? call-substs)
|
||||
fun
|
||||
;; Iterate to fixed point.
|
||||
(contify
|
||||
(apply-contification fun call-substs cont-substs fun-elisions cont-splices))))))
|
||||
(apply-contification fun call-substs cont-substs cont-splices))))))
|
||||
|
|
|
|||
|
|
@ -39,7 +39,6 @@
|
|||
(let lp ((body body))
|
||||
(match body
|
||||
(($ $letk conts body) (lp body))
|
||||
(($ $letrec names vars funs body) (lp body))
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler) (list k handler))
|
||||
|
|
@ -246,16 +245,8 @@ could be that both true and false proofs are available."
|
|||
(label-count (1+ label-count)))
|
||||
(match cont
|
||||
(($ $kargs names vars body)
|
||||
(let lp ((body body)
|
||||
(min-var (fold min min-var vars))
|
||||
(var-count (+ var-count (length vars))))
|
||||
(match body
|
||||
(($ $letrec names vars funs body)
|
||||
(lp body
|
||||
(fold min min-var vars)
|
||||
(+ var-count (length vars))))
|
||||
(($ $letk conts body) (lp body min-var var-count))
|
||||
(_ (values min-label label-count min-var var-count)))))
|
||||
(values min-label label-count
|
||||
(fold min min-var vars) (+ var-count (length vars))))
|
||||
(($ $kfun src meta self)
|
||||
(values min-label label-count (min self min-var) (1+ var-count)))
|
||||
(_
|
||||
|
|
@ -297,6 +288,7 @@ could be that both true and false proofs are available."
|
|||
(($ $const val) (cons 'const val))
|
||||
(($ $prim name) (cons 'prim name))
|
||||
(($ $fun free body) #f)
|
||||
(($ $rec names syms funs) #f)
|
||||
(($ $call proc args) #f)
|
||||
(($ $callk k proc args) #f)
|
||||
(($ $primcall name args)
|
||||
|
|
@ -475,12 +467,19 @@ could be that both true and false proofs are available."
|
|||
(($ $prompt escape? tag handler)
|
||||
($prompt escape? (subst-var tag) handler))))
|
||||
|
||||
(define (visit-fun fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun free body)
|
||||
($fun (map subst-var free) ,(cse body dfg)))))
|
||||
|
||||
(define (visit-exp* k src exp)
|
||||
(match exp
|
||||
(($ $fun free body)
|
||||
(($ $fun)
|
||||
(build-cps-term
|
||||
($continue k src
|
||||
($fun (map subst-var free) ,(cse body dfg)))))
|
||||
($continue k src ,(visit-fun exp))))
|
||||
(($ $rec names syms funs)
|
||||
(build-cps-term
|
||||
($continue k src ($rec names syms (map visit-fun funs)))))
|
||||
(_
|
||||
(cond
|
||||
((vector-ref equiv-labels (label->idx label))
|
||||
|
|
@ -523,14 +522,6 @@ could be that both true and false proofs are available."
|
|||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
,(visit-term body label))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms
|
||||
(map (lambda (fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun free body)
|
||||
($fun (map subst-var free) ,(cse body dfg)))))
|
||||
funs)
|
||||
,(visit-term body label)))
|
||||
(($ $continue k src exp)
|
||||
,(let ((conts (append-map visit-dom-conts
|
||||
(vector-ref doms (label->idx label)))))
|
||||
|
|
|
|||
|
|
@ -190,14 +190,6 @@
|
|||
(let lp ((body body))
|
||||
(match body
|
||||
(($ $letk conts body) (lp body))
|
||||
(($ $letrec names syms funs body)
|
||||
(lp body)
|
||||
(for-each (lambda (sym fun)
|
||||
(when (value-live? sym)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(visit-fun body)))))
|
||||
syms funs))
|
||||
(($ $continue k src exp)
|
||||
(unless (bitvector-ref live-conts n)
|
||||
(when (visit-grey-exp n exp)
|
||||
|
|
@ -209,6 +201,13 @@
|
|||
#f)
|
||||
(($ $fun free body)
|
||||
(visit-fun body))
|
||||
(($ $rec names syms funs)
|
||||
(for-each (lambda (sym fun)
|
||||
(when (value-live? sym)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(visit-fun body)))))
|
||||
syms funs))
|
||||
(($ $prompt escape? tag handler)
|
||||
(mark-live! tag))
|
||||
(($ $call proc args)
|
||||
|
|
@ -309,22 +308,6 @@
|
|||
(match (visit-conts conts)
|
||||
(() body)
|
||||
(conts (build-cps-term ($letk ,conts ,body))))))
|
||||
(($ $letrec names syms funs body)
|
||||
(let ((body (visit-term body term-k)))
|
||||
(match (filter-map
|
||||
(lambda (name sym fun)
|
||||
(and (value-live? sym)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(list name
|
||||
sym
|
||||
(build-cps-exp
|
||||
($fun free ,(visit-fun body))))))))
|
||||
names syms funs)
|
||||
(() body)
|
||||
(((names syms funs) ...)
|
||||
(build-cps-term
|
||||
($letrec names syms funs ,body))))))
|
||||
(($ $continue k src ($ $values args))
|
||||
(match (vector-ref defs (label->idx term-k))
|
||||
(#f term)
|
||||
|
|
@ -336,19 +319,36 @@
|
|||
($continue k src ($values args)))))))
|
||||
(($ $continue k src exp)
|
||||
(if (bitvector-ref live-conts (label->idx term-k))
|
||||
(rewrite-cps-term exp
|
||||
(match exp
|
||||
(($ $fun free body)
|
||||
($continue k src ($fun free ,(visit-fun body))))
|
||||
(build-cps-term
|
||||
($continue k src ($fun free ,(visit-fun body)))))
|
||||
(($ $rec names syms funs)
|
||||
(rewrite-cps-term
|
||||
(filter-map
|
||||
(lambda (name sym fun)
|
||||
(and (value-live? sym)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(list name
|
||||
sym
|
||||
(build-cps-exp
|
||||
($fun free ,(visit-fun body))))))))
|
||||
names syms funs)
|
||||
(()
|
||||
($continue k src ($values ())))
|
||||
(((names syms funs) ...)
|
||||
($continue k src ($rec names syms funs)))))
|
||||
(_
|
||||
,(match (vector-ref defs (label->idx term-k))
|
||||
((or #f ((? value-live?) ...))
|
||||
(build-cps-term
|
||||
($continue k src ,exp)))
|
||||
(syms
|
||||
(let-fresh (adapt) ()
|
||||
(build-cps-term
|
||||
($letk (,(make-adaptor adapt k syms))
|
||||
($continue adapt src ,exp))))))))
|
||||
(match (vector-ref defs (label->idx term-k))
|
||||
((or #f ((? value-live?) ...))
|
||||
(build-cps-term
|
||||
($continue k src ,exp)))
|
||||
(syms
|
||||
(let-fresh (adapt) ()
|
||||
(build-cps-term
|
||||
($letk (,(make-adaptor adapt k syms))
|
||||
($continue adapt src ,exp))))))))
|
||||
(build-cps-term ($continue k src ($values ())))))))
|
||||
(visit-cont fun))))
|
||||
(visit-fun fun))
|
||||
|
|
|
|||
|
|
@ -566,32 +566,14 @@ body continuation in the prompt."
|
|||
min-var max-var var-count)
|
||||
(let ((min-label (min* label min-label))
|
||||
(max-label (max label max-label)))
|
||||
(define (visit-letrec body min-var max-var var-count)
|
||||
(match body
|
||||
(($ $letk conts body)
|
||||
(visit-letrec body min-var max-var var-count))
|
||||
(($ $letrec names vars funs body)
|
||||
(visit-letrec body
|
||||
(cond (min-var (fold min min-var vars))
|
||||
((pair? vars) (fold min (car vars) (cdr vars)))
|
||||
(else min-var))
|
||||
(fold max max-var vars)
|
||||
(+ var-count (length vars))))
|
||||
(($ $continue) (values min-var max-var var-count))))
|
||||
(match cont
|
||||
(($ $kargs names vars body)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(if global?
|
||||
(visit-letrec body min-var max-var var-count)
|
||||
(values min-var max-var var-count)))
|
||||
(lambda (min-var max-var var-count)
|
||||
(values min-label max-label (1+ label-count)
|
||||
(cond (min-var (fold min min-var vars))
|
||||
((pair? vars) (fold min (car vars) (cdr vars)))
|
||||
(else min-var))
|
||||
(fold max max-var vars)
|
||||
(+ var-count (length vars))))))
|
||||
(values min-label max-label (1+ label-count)
|
||||
(cond (min-var (fold min min-var vars))
|
||||
((pair? vars) (fold min (car vars) (cdr vars)))
|
||||
(else min-var))
|
||||
(fold max max-var vars)
|
||||
(+ var-count (length vars))))
|
||||
(($ $kfun src meta self)
|
||||
(values min-label max-label (1+ label-count)
|
||||
(min* self min-var) (max self max-var) (1+ var-count)))
|
||||
|
|
@ -653,16 +635,6 @@ body continuation in the prompt."
|
|||
cont k)
|
||||
(for-each/2 visit-cont cont k)
|
||||
(visit-term body label))
|
||||
(($ $letrec names syms funs body)
|
||||
(unless global?
|
||||
(error "$letrec should not be present when building a local DFG"))
|
||||
(for-each (cut add-def! <> label) syms)
|
||||
(for-each (lambda (fun)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(visit-fun body))))
|
||||
funs)
|
||||
(visit-term body label))
|
||||
(($ $continue k src exp)
|
||||
(link-blocks! label k)
|
||||
(visit-exp exp label))))
|
||||
|
|
@ -690,7 +662,15 @@ body continuation in the prompt."
|
|||
(link-blocks! label handler))
|
||||
(($ $fun free body)
|
||||
(when global?
|
||||
(visit-fun body)))))
|
||||
(visit-fun body)))
|
||||
(($ $rec names syms funs)
|
||||
(unless global?
|
||||
(error "$rec should not be present when building a local DFG"))
|
||||
(for-each (lambda (fun)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(visit-fun body))))
|
||||
funs))))
|
||||
|
||||
(define (visit-clause clause kfun)
|
||||
(match clause
|
||||
|
|
@ -769,6 +749,7 @@ body continuation in the prompt."
|
|||
(($ $const val) (format port "const ~@y" val))
|
||||
(($ $prim name) (format port "prim ~a" name))
|
||||
(($ $fun free ($ $cont kbody)) (format port "fun k~a" kbody))
|
||||
(($ $rec names syms funs) (format port "rec~{ v~a~}" syms))
|
||||
(($ $closure label nfree) (format port "closure k~a (~a free)" label nfree))
|
||||
(($ $call proc args) (format port "call~{ v~a~}" (cons proc args)))
|
||||
(($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args)))
|
||||
|
|
@ -820,7 +801,6 @@ body continuation in the prompt."
|
|||
(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)
|
||||
|
|
|
|||
|
|
@ -443,7 +443,7 @@ is or might be a read or a write to the same location as A."
|
|||
(match exp
|
||||
((or ($ $const) ($ $prim) ($ $values))
|
||||
&no-effects)
|
||||
(($ $fun)
|
||||
((or ($ $fun) ($ $rec))
|
||||
(&allocate &unknown-memory-kinds))
|
||||
(($ $prompt)
|
||||
(&write-object &prompt))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015 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
|
||||
|
|
@ -52,9 +52,6 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src ($ $primcall 'values vals))
|
||||
,(rewrite-cps-term (vector-ref conts k)
|
||||
(($ $ktail)
|
||||
|
|
@ -95,6 +92,8 @@
|
|||
($continue k src ($values vals))))))))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
($continue k src ($rec names syms (map visit-fun funs))))
|
||||
(($ $continue)
|
||||
,term)))
|
||||
(define (visit-fun fun)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013, 2014, 2015 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
|
||||
|
|
@ -60,9 +60,6 @@
|
|||
|
||||
(define (visit-term term ktail)
|
||||
(rewrite-cps-term term
|
||||
(($ $letrec names vars funs body)
|
||||
($letrec names vars (map visit-fun funs)
|
||||
,(visit-term body ktail)))
|
||||
(($ $letk conts body)
|
||||
($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts)
|
||||
,(visit-term body ktail)))
|
||||
|
|
@ -72,6 +69,8 @@
|
|||
(define (visit-exp k src exp ktail)
|
||||
(rewrite-cps-term exp
|
||||
(($ $fun) ($continue k src ,(visit-fun exp)))
|
||||
(($ $rec names vars funs)
|
||||
($continue k src ($rec names vars (map visit-fun funs))))
|
||||
(($ $primcall (and name (or 'error 'scm-error 'throw)) args)
|
||||
,(if (eq? k ktail)
|
||||
(build-cps-term ($continue k src ,exp))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2014, 2015 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
|
||||
|
|
@ -53,12 +53,11 @@
|
|||
(($ $letk conts body)
|
||||
(for-each visit-cont conts)
|
||||
(visit-term body))
|
||||
(($ $letrec names syms funs body)
|
||||
(for-each visit-fun funs)
|
||||
(visit-term body))
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $fun) (visit-fun exp))
|
||||
(($ $rec names syms funs)
|
||||
(for-each visit-fun funs))
|
||||
(($ $primcall 'cached-toplevel-box (scope name bound?))
|
||||
(hashq-set! scope-var->used? scope #t))
|
||||
(($ $primcall 'cache-current-module! (module scope))
|
||||
|
|
@ -105,8 +104,6 @@
|
|||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts) ,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms funs ,(visit-term body)))
|
||||
(($ $continue k src
|
||||
(and ($ $primcall 'cache-current-module! (module scope))
|
||||
(? (lambda _
|
||||
|
|
|
|||
|
|
@ -52,7 +52,6 @@
|
|||
(let lp ((body body))
|
||||
(match body
|
||||
(($ $letk conts body) (lp body))
|
||||
(($ $letrec names syms funs body) (lp body))
|
||||
(($ $continue k src exp)
|
||||
(match exp
|
||||
(($ $prompt escape? tag handler)
|
||||
|
|
@ -168,8 +167,6 @@
|
|||
(visit-cont (car conts))
|
||||
(lp (cdr conts))))
|
||||
(visit-term body label))
|
||||
(($ $letrec names syms funs body)
|
||||
(visit-term body label))
|
||||
(($ $continue k src exp)
|
||||
(add-predecessor! label k)
|
||||
(match exp
|
||||
|
|
@ -222,19 +219,17 @@
|
|||
(($ $letk conts body)
|
||||
(for-each visit-cont conts)
|
||||
(visit-term body reachable?))
|
||||
(($ $letrec names syms funs body)
|
||||
(($ $continue k src ($ $fun free body))
|
||||
(when reachable?
|
||||
(set! queue (cons body queue))))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
(when reachable?
|
||||
(for-each rename! syms)
|
||||
(set! queue (fold (lambda (fun queue)
|
||||
(match fun
|
||||
(($ $fun free body)
|
||||
(cons body queue))))
|
||||
queue
|
||||
funs)))
|
||||
(visit-term body reachable?))
|
||||
(($ $continue k src ($ $fun free body))
|
||||
(when reachable?
|
||||
(set! queue (cons body queue))))
|
||||
funs))))
|
||||
(($ $continue) #f)))
|
||||
|
||||
(match fun
|
||||
|
|
@ -301,9 +296,6 @@
|
|||
,(match (visit-conts conts)
|
||||
(() (visit-term body))
|
||||
(conts (build-cps-term ($letk ,conts ,(visit-term body))))))
|
||||
(($ $letrec names vars funs body)
|
||||
($letrec names (map rename vars) (map visit-fun funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src exp)
|
||||
($continue (relabel k) src ,(visit-exp exp)))))
|
||||
(define (visit-exp exp)
|
||||
|
|
@ -314,6 +306,8 @@
|
|||
(build-cps-exp ($closure (relabel k) nfree)))
|
||||
(($ $fun)
|
||||
(visit-fun exp))
|
||||
(($ $rec names vars funs)
|
||||
(build-cps-exp ($rec names (map rename vars) (map visit-fun funs))))
|
||||
(($ $values args)
|
||||
(let ((args (map rename args)))
|
||||
(build-cps-exp ($values args))))
|
||||
|
|
|
|||
|
|
@ -45,9 +45,6 @@
|
|||
|
||||
(define (visit-term term)
|
||||
(rewrite-cps-term term
|
||||
(($ $letrec names vars funs body)
|
||||
($letrec names vars (map visit-recursive-fun funs vars)
|
||||
,(visit-term body)))
|
||||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
|
|
@ -59,6 +56,8 @@
|
|||
((or ($ $const) ($ $prim)) ,exp)
|
||||
(($ $fun free body)
|
||||
($fun free ,(resolve-self-references body env)))
|
||||
(($ $rec names vars funs)
|
||||
($rec names vars (map visit-recursive-fun funs vars)))
|
||||
(($ $call proc args)
|
||||
($call (subst proc) ,(map subst args)))
|
||||
(($ $callk k proc args)
|
||||
|
|
|
|||
|
|
@ -50,14 +50,13 @@
|
|||
(($ $letk conts body)
|
||||
(for-each visit-cont conts)
|
||||
(visit-term body term-k term-args))
|
||||
(($ $letrec names syms funs body)
|
||||
(for-each visit-fun funs)
|
||||
(visit-term body term-k term-args))
|
||||
(($ $continue k src ($ $values args))
|
||||
(when (and (equal? term-args args) (not (eq? k term-k)))
|
||||
(hashq-set! table term-k k)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
(visit-fun fun))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
(for-each visit-fun funs))
|
||||
(($ $continue k src _)
|
||||
#f)))
|
||||
(define (visit-fun fun)
|
||||
|
|
@ -126,13 +125,12 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map (cut visit-cont <> scope) conts)
|
||||
,(visit-term body scope)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body scope)))
|
||||
(($ $continue k src ($ $values args))
|
||||
($continue (reduce-values k scope) src ($values args)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue (reduce k scope) src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
($continue k src ($rec names syms (map visit-fun funs))))
|
||||
(($ $continue k src ($ $const const))
|
||||
,(let ((k (reduce k scope)))
|
||||
(or (reduce-const k src scope const)
|
||||
|
|
@ -168,9 +166,6 @@
|
|||
(($ $letk conts body)
|
||||
(for-each visit-cont conts)
|
||||
(visit-term body))
|
||||
(($ $letrec names syms funs body)
|
||||
(for-each visit-fun funs)
|
||||
(visit-term body))
|
||||
(($ $continue k src ($ $values args))
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs names syms body)
|
||||
|
|
@ -188,6 +183,8 @@
|
|||
(_ #f)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
(visit-fun fun))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
(for-each visit-fun funs))
|
||||
(($ $continue k src _)
|
||||
#f)))
|
||||
(define (visit-fun fun)
|
||||
|
|
@ -227,10 +224,6 @@
|
|||
(() (visit-term body))
|
||||
(conts (build-cps-term
|
||||
($letk ,conts ,(visit-term body))))))
|
||||
(($ $letrec names syms funs body)
|
||||
(build-cps-term
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body))))
|
||||
(($ $continue k src exp)
|
||||
(cond
|
||||
((hashq-ref k-table k) => visit-term)
|
||||
|
|
@ -240,6 +233,8 @@
|
|||
(match exp
|
||||
((or ($ $const) ($ $prim)) exp)
|
||||
(($ $fun) (visit-fun exp))
|
||||
(($ $rec names syms funs)
|
||||
(build-cps-exp ($rec names (map subst syms) (map visit-fun funs))))
|
||||
(($ $call proc args)
|
||||
(let ((args (map subst args)))
|
||||
(build-cps-exp ($call (subst proc) args))))
|
||||
|
|
@ -284,10 +279,17 @@
|
|||
(label ($kargs names vars ,(visit-term body label))))
|
||||
(_ (label ,cont))))
|
||||
|
||||
(define (visit-fun fun)
|
||||
(rewrite-cps-exp fun
|
||||
(($ $fun free body)
|
||||
($fun free ,(visit-fun-cont body)))))
|
||||
|
||||
(define (visit-exp k src exp)
|
||||
(rewrite-cps-term exp
|
||||
(($ $fun free body)
|
||||
($continue k src ($fun free ,(visit-fun-cont body))))
|
||||
($continue k src ,(visit-fun exp)))
|
||||
(($ $rec names syms funs)
|
||||
($continue k src ($rec names syms (map visit-fun funs))))
|
||||
(_
|
||||
($continue k src ,exp))))
|
||||
|
||||
|
|
@ -311,15 +313,6 @@
|
|||
(rewrite-cps-term term
|
||||
(($ $letk conts body)
|
||||
,(visit-term body label))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (let lp ((funs funs))
|
||||
(match funs
|
||||
(() '())
|
||||
((($ $fun free body) . funs)
|
||||
(cons (build-cps-exp
|
||||
($fun free ,(visit-fun-cont body)))
|
||||
(lp funs)))))
|
||||
,(visit-term body label)))
|
||||
(($ $continue k src exp)
|
||||
,(let ((conts (visit-dom-conts* (vector-ref doms label))))
|
||||
(if (null? conts)
|
||||
|
|
|
|||
|
|
@ -54,11 +54,10 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body)))
|
||||
(($ $letrec names syms funs body)
|
||||
($letrec names syms (map visit-fun funs)
|
||||
,(visit-term body)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $rec names syms funs))
|
||||
($continue k src ($rec names syms (map visit-fun funs))))
|
||||
(($ $continue k src ($ $primcall name args))
|
||||
,(visit-primcall k src name args))
|
||||
(($ $continue)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; Abstract constant folding on CPS
|
||||
;;; Copyright (C) 2014 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2014, 2015 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
|
||||
|
|
@ -356,8 +356,6 @@
|
|||
(($ $letk conts body)
|
||||
(for-each visit-cont conts)
|
||||
(visit-term body label))
|
||||
(($ $letrec _ _ _ body)
|
||||
(visit-term body label))
|
||||
(($ $continue k src ($ $primcall name args))
|
||||
;; We might be able to fold primcalls that define a value.
|
||||
(match (lookup-cont k dfg)
|
||||
|
|
@ -402,11 +400,10 @@
|
|||
(($ $letk conts body)
|
||||
($letk ,(map visit-cont conts)
|
||||
,(visit-term body label)))
|
||||
(($ $letrec names vars funs body)
|
||||
($letrec names vars (map visit-fun funs)
|
||||
,(visit-term body label)))
|
||||
(($ $continue k src (and fun ($ $fun)))
|
||||
($continue k src ,(visit-fun fun)))
|
||||
(($ $continue k src ($ $rec names vars funs))
|
||||
($continue k src ($rec names vars (map visit-fun funs))))
|
||||
(($ $continue k src (and primcall ($ $primcall name args)))
|
||||
,(cond
|
||||
((bitvector-ref folded? (label->idx label))
|
||||
|
|
|
|||
|
|
@ -1304,6 +1304,9 @@ mapping symbols to types."
|
|||
(propagate! 0 k types))))
|
||||
((or ($ $call) ($ $callk))
|
||||
(propagate! 0 k types))
|
||||
(($ $rec names vars funs)
|
||||
(let ((proc-type (make-type-entry &procedure -inf.0 +inf.0)))
|
||||
(propagate! 0 k (adjoin-vars types vars proc-type))))
|
||||
(_
|
||||
(match (lookup-cont k dfg)
|
||||
(($ $kargs (_) (var))
|
||||
|
|
@ -1333,11 +1336,6 @@ mapping symbols to types."
|
|||
(($ $kargs names vars term)
|
||||
(let visit-term ((term term) (types types))
|
||||
(match term
|
||||
(($ $letrec names vars funs term)
|
||||
(visit-term term
|
||||
(adjoin-vars types vars
|
||||
(make-type-entry &procedure
|
||||
-inf.0 +inf.0))))
|
||||
(($ $letk conts term)
|
||||
(visit-term term types))
|
||||
(($ $continue k src exp)
|
||||
|
|
|
|||
|
|
@ -143,6 +143,13 @@
|
|||
#t)
|
||||
(($ $fun)
|
||||
(visit-fun exp k-env v-env))
|
||||
(($ $rec (name ...) (sym ...) (fun ...))
|
||||
(unless (= (length name) (length sym) (length fun))
|
||||
(error "letrec syms, names, and funs not same length" term))
|
||||
;; FIXME: syms added in two places (here in $rec versus also in
|
||||
;; target $kargs)
|
||||
(let ((v-env (add-vars sym v-env)))
|
||||
(for-each (cut visit-fun <> k-env v-env) fun)))
|
||||
(($ $call proc (arg ...))
|
||||
(check-var proc v-env)
|
||||
(for-each (cut check-var <> v-env) arg))
|
||||
|
|
@ -177,13 +184,6 @@
|
|||
(for-each (cut visit-cont-body <> k-env v-env) cont)
|
||||
(visit-term body k-env v-env)))
|
||||
|
||||
(($ $letrec (name ...) (sym ...) (fun ...) body)
|
||||
(unless (= (length name) (length sym) (length fun))
|
||||
(error "letrec syms, names, and funs not same length" term))
|
||||
(let ((v-env (add-vars sym v-env)))
|
||||
(for-each (cut visit-fun <> k-env v-env) fun)
|
||||
(visit-term body k-env v-env)))
|
||||
|
||||
(($ $continue k src exp)
|
||||
(check-label k k-env)
|
||||
(check-src src)
|
||||
|
|
|
|||
|
|
@ -524,16 +524,18 @@
|
|||
(($ <fix> src names gensyms funs body)
|
||||
;; Some letrecs can be contified; that happens later.
|
||||
(if (current-topbox-scope)
|
||||
(let-fresh () (self)
|
||||
(build-cps-term
|
||||
($letrec names
|
||||
(map bound-var gensyms)
|
||||
(map (lambda (fun)
|
||||
(match (convert fun k subst)
|
||||
(($ $continue _ _ (and fun ($ $fun)))
|
||||
fun)))
|
||||
funs)
|
||||
,(convert body k subst))))
|
||||
(let ((vars (map bound-var gensyms)))
|
||||
(let-fresh (krec) ()
|
||||
(build-cps-term
|
||||
($letk ((krec ($kargs names vars
|
||||
,(convert body k subst))))
|
||||
($continue krec src
|
||||
($rec names vars
|
||||
(map (lambda (fun)
|
||||
(match (convert fun k subst)
|
||||
(($ $continue _ _ (and fun ($ $fun)))
|
||||
fun)))
|
||||
funs)))))))
|
||||
(let ((scope-id (fresh-scope-id)))
|
||||
(let-fresh (kscope) ()
|
||||
(build-cps-term
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue