mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Contification also inlines "elide-values" pass

Browse source 
* module/language/cps/contification.scm (apply-contification): Inline
  returns to the corresponding $kargs.
* module/language/cps/licm.scm (loop-invariant?): Remove handling of
  "values" primcall, as this doesn't exist any more.
This commit is contained in:
Andy Wingo 2017-12-27 10:57:04 +01:00
parent c9efff30de
commit cf1611ef38
2 changed files with 76 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

116
module/language/cps/contification.scm
View file

@ -37,6 +37,7 @@
#:use-module (language cps utils) #:use-module (language cps utils)
#:use-module (language cps intmap) #:use-module (language cps intmap)
#:use-module (language cps intset) #:use-module (language cps intset)
#:use-module (language cps with-cps)
#:export (contify)) #:export (contify))
(define (compute-singly-referenced-labels conts) (define (compute-singly-referenced-labels conts)
@ -369,72 +370,107 @@ function set."
(if (arity-matches? arity nargs) (if (arity-matches? arity nargs)
body body
(lp alt)))))))) (lp alt))))))))
(define (continue k src exp) (define (inline-return cps k* kargs src nreq rest vals)
(define (build-list cps k src vals)
(match vals
(()
(with-cps cps
(build-term ($continue k src ($const '())))))
((v . vals)
(with-cps cps
(letv tail)
(letk ktail ($kargs ('tail) (tail)
($continue k src ($primcall 'cons #f (v tail)))))
($ (build-list ktail src vals))))))
(cond
((and (not rest) (eqv? (length vals) nreq))
(with-cps cps
(build-term ($continue kargs src ($values vals)))))
((and rest (<= nreq (length vals)))
(with-cps cps
(letv rest)
(letk krest ($kargs ('rest) (rest)
($continue kargs src
($values ,(append (list-head vals nreq)
(list rest))))))
($ (build-list krest src (list-tail vals nreq)))))
(else
;; Fallback case if values don't match.
(with-cps cps
(letv prim)
(letk kprim ($kargs ('prim) (prim)
($continue k* src ($call prim vals))))
(build-term ($continue kprim src ($prim 'values)))))))
(define (continue cps k src exp)
(define (lookup-return-cont k) (define (lookup-return-cont k)
(match (return-subst k) (match (return-subst k)
(#f k) (#f k)
(k (lookup-return-cont k)))) (k (lookup-return-cont k))))
(let ((k* (lookup-return-cont k))) (let ((k* (lookup-return-cont k)))
(if (eq? k k*) (if (eq? k k*)
(build-term ($continue k src ,exp)) (with-cps cps (build-term ($continue k src ,exp)))
;; We are contifying this return. It must be a call, a ;; We are contifying this return. It must be a call, a
;; $values expression, or a return primcall. k* will be ;; $primcall that can continue to $ktail (basically this is
;; either a $ktail or a $kreceive continuation. CPS has this ;; only "throw" and friends), or a $values expression. k*
;; thing though where $kreceive can't be the target of a ;; will be either a $ktail or a $kreceive continuation.
;; $values expression, and "return" can only continue to a (match (intmap-ref conts k*)
;; tail continuation, so we might have to rewrite to a (($ $kreceive ($ $arity req () rest () #f) kargs)
;; "values" primcall. (match exp
(build-term (($ $call)
($continue k* src (with-cps cps (build-term ($continue k* src ,exp))))
,(match (intmap-ref conts k*) ;; A primcall that can continue to $ktail can also
(($ $kreceive) ;; continue to $kreceive.
(match exp (($ $primcall)
(($ $call) exp) (with-cps cps (build-term ($continue k* src ,exp))))
;; A primcall that can continue to $ktail can also ;; We need to punch through the $kreceive; otherwise we'd
;; continue to $kreceive. ;; have to rewrite as a call to the 'values primitive.
(($ $primcall) exp) (($ $values vals)
(($ $values vals) (inline-return cps k* kargs src (length req) rest vals))))
(build-exp ($primcall 'values #f vals))))) (($ $ktail)
(($ $ktail) exp))))))) (with-cps cps (build-term ($continue k* src ,exp))))))))
(define (visit-exp k src exp) (define (visit-exp cps k src exp)
(match exp (match exp
(($ $call proc args) (($ $call proc args)
;; If proc is contifiable, replace call with jump. ;; If proc is contifiable, replace call with jump.
(match (call-subst proc) (match (call-subst proc)
(#f (continue k src exp)) (#f (continue cps k src exp))
(kfun (kfun
(let ((body (find-body kfun (length args)))) (let ((body (find-body kfun (length args))))
(build-term ($continue body src ($values args))))))) (with-cps cps
(build-term ($continue body src ($values args))))))))
(($ $fun kfun) (($ $fun kfun)
;; If the function's tail continuation has been ;; If the function's tail continuation has been
;; substituted, that means it has been contified. ;; substituted, that means it has been contified.
(if (return-subst (tail-label conts kfun)) (if (return-subst (tail-label conts kfun))
(continue k src (build-exp ($values ()))) (continue cps k src (build-exp ($values ())))
(continue k src exp))) (continue cps k src exp)))
(($ $rec names vars funs) (($ $rec names vars funs)
(match (filter (match-lambda ((n v f) (not (call-subst v)))) (match (filter (match-lambda ((n v f) (not (call-subst v))))
(map list names vars funs)) (map list names vars funs))
(() (continue k src (build-exp ($values ())))) (() (continue cps k src (build-exp ($values ()))))
(((names vars funs) ...) (((names vars funs) ...)
(continue k src (build-exp ($rec names vars funs)))))) (continue cps k src (build-exp ($rec names vars funs))))))
(_ (continue k src exp)))) (_ (continue cps k src exp))))
;; Renumbering is not strictly necessary but some passes may not be ;; Renumbering is not strictly necessary but some passes may not be
;; equipped to deal with stale $kfun nodes whose bodies have been ;; equipped to deal with stale $kfun nodes whose bodies have been
;; wired into other functions. ;; wired into other functions.
(renumber (renumber
(intmap-map (with-fresh-name-state conts
(lambda (label cont) (intmap-fold
(match cont (lambda (label cont out)
(($ $kargs names vars ($ $continue k src exp)) (match cont
;; Remove bindings for functions that have been contified. (($ $kargs names vars ($ $continue k src exp))
(match (filter (match-lambda ((name var) (not (call-subst var)))) ;; Remove bindings for functions that have been contified.
(map list names vars)) (match (filter (match-lambda ((name var) (not (call-subst var))))
(((names vars) ...) (map list names vars))
(build-cont (((names vars) ...)
($kargs names vars ,(visit-exp k src exp)))))) (with-cps out
(_ cont))) (let$ term (visit-exp k src exp))
conts))) (setk label ($kargs names vars ,term))))))
(_ out)))
conts
conts))))
(define (contify conts) (define (contify conts)
;; FIXME: Renumbering isn't really needed but dead continuations may ;; FIXME: Renumbering isn't really needed but dead continuations may

1
module/language/cps/licm.scm
View file

@ -70,7 +70,6 @@
((or ($ $const) ($ $prim) ($ $closure)) #t) ((or ($ $const) ($ $prim) ($ $closure)) #t)
(($ $prompt) #f) ;; ? (($ $prompt) #f) ;; ?
(($ $branch) #f) (($ $branch) #f)
(($ $primcall 'values #f) #f)
(($ $primcall name param args) (($ $primcall name param args)
(and-map (lambda (arg) (not (intset-ref loop-vars arg))) (and-map (lambda (arg) (not (intset-ref loop-vars arg)))
args)) args))