[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/06: Add compiler support for eliding closure bindings
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/06: Add compiler support for eliding closure bindings |
|
Date: |
Fri, 7 Jun 2019 11:06:13 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit f6c07e4eb2212656fc6acb6c031b74237847eb42
Author: Andy Wingo <address@hidden>
Date: Fri Jun 7 15:37:20 2019 +0200
Add compiler support for eliding closure bindings
* module/language/cps/closure-conversion.scm (compute-elidable-closures):
New function.
(convert-one, convert-closures): Add ability to set "self" variable of
$kfun to $f, hopefully avoiding passing that argument in some cases.
* module/language/cps/compile-bytecode.scm (compile-function): Pass the
has-closure? bit on through to the assembler.
* module/system/vm/assembler.scm (begin-standard-arity)
(begin-opt-arity, begin-kw-arity): Only reserve space for the closure
as appropriate.
* module/language/cps/slot-allocation.scm (allocate-args)
(compute-defs-and-uses, compute-needs-slot)
(compute-var-representations): Allow for closure slot allocation
differences.
* module/language/cps/cse.scm (compute-defs):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/renumber.scm (renumber, compute-renaming):
(allocate-args):
* module/language/cps/specialize-numbers.scm (compute-significant-bits):
(compute-defs):
* module/language/cps/split-rec.scm (compute-free-vars):
* module/language/cps/types.scm (infer-types):
* module/language/cps/utils.scm (compute-max-label-and-var):
* module/language/cps/verify.scm (check-distinct-vars):
(compute-available-definitions): Allow closure to be #f.
---
module/language/cps/closure-conversion.scm | 76 ++++++++++++++++++++++++++----
module/language/cps/compile-bytecode.scm | 13 +++--
module/language/cps/cse.scm | 2 +-
module/language/cps/dce.scm | 5 +-
module/language/cps/renumber.scm | 6 +--
module/language/cps/slot-allocation.scm | 47 ++++++++++--------
module/language/cps/specialize-numbers.scm | 6 +--
module/language/cps/split-rec.scm | 4 +-
module/language/cps/types.scm | 6 ++-
module/language/cps/utils.scm | 2 +-
module/language/cps/verify.scm | 6 +--
module/system/vm/assembler.scm | 15 +++---
12 files changed, 131 insertions(+), 57 deletions(-)
diff --git a/module/language/cps/closure-conversion.scm
b/module/language/cps/closure-conversion.scm
index 77c8fae..0dfd25d 100644
--- a/module/language/cps/closure-conversion.scm
+++ b/module/language/cps/closure-conversion.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -26,6 +26,10 @@
;;; contification did not handle. See (language cps) for a further
;;; discussion of $rec.
;;;
+;;; Before closure conversion, function self variables are always bound.
+;;; After closure conversion, well-known functions with no free
+;;; variables may have no self reference.
+;;;
;;; Code:
(define-module (language cps closure-conversion)
@@ -451,7 +455,50 @@ variable, until we reach a fixed point on the free-vars
map."
(define (intset-count set)
(intset-fold (lambda (_ count) (1+ count)) set 0))
-(define (convert-one cps label body free-vars bound->label well-known shared)
+(define (compute-elidable-closures cps well-known shared free-vars)
+ "Compute the set of well-known callees with no free variables. Calls
+to these functions can avoid passing a closure parameter. Note however
+that we have to exclude well-known callees that are part of a shared
+closure that contains any not-well-known member."
+ (define (intset-map f set)
+ (persistent-intset
+ (intset-fold (lambda (i out) (if (f i) (intset-add! out i) out))
+ set
+ empty-intset)))
+
+ (let ((no-free-vars (persistent-intset
+ (intmap-fold (lambda (label free out)
+ (if (eq? empty-intset free)
+ (intset-add! out label)
+ out))
+ free-vars empty-intset)))
+ (shared
+ (intmap-fold
+ (lambda (label cont out)
+ (match cont
+ (($ $kargs _ _
+ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...))))
+ ;; Either all of these functions share a closure, in
+ ;; which all or all except one of them are well-known, or
+ ;; none of the functions share a closure.
+ (if (intmap-ref shared (car kfuns) (lambda (_) #f))
+ (let* ((scc (fold intset-cons empty-intset kfuns)))
+ (intset-fold (lambda (label out)
+ (intmap-add out label scc))
+ scc out))
+ out))
+ (_ out)))
+ cps
+ empty-intmap)))
+ (intmap-fold (lambda (label labels elidable)
+ (if (eq? labels (intset-intersect labels well-known))
+ elidable
+ (intset-subtract elidable labels)))
+ shared
+ (intset-intersect well-known no-free-vars))))
+
+(define (convert-one cps label body free-vars bound->label well-known shared
+ elidable)
(define (well-known? label)
(intset-ref well-known label))
@@ -650,11 +697,14 @@ bound to @var{var}, and continue to @var{k}."
($continue k src ($callk label closure args)))))))
(cond
((eq? (intmap-ref free-vars label) empty-intset)
- ;; Known call, no free variables; no closure needed.
- ;; Pass #f as closure argument.
- (with-cps cps
- ($ (with-cps-constants ((false #f))
- ($ (have-closure false))))))
+ ;; Known call, no free variables; no closure needed. If the
+ ;; callee is well-known, elide the closure argument entirely.
+ ;; Otherwise pass #f.
+ (if (and (intset-ref elidable label) #f) ; Disabled temporarily.
+ (have-closure cps #f)
+ (with-cps cps
+ ($ (with-cps-constants ((false #f))
+ ($ (have-closure false)))))))
((and (well-known? (closure-label label shared bound->label))
(trivial-intset (intmap-ref free-vars label)))
;; Well-known closures with one free variable are
@@ -796,6 +846,11 @@ bound to @var{var}, and continue to @var{k}."
(with-cps cps
(let$ term (visit-term term))
(setk label ($kargs names vars ,term))))
+ (($ $kfun src meta self ktail kclause)
+ (if (and (intset-ref elidable label) #f)
+ (with-cps cps
+ (setk label ($kfun src meta #f ktail kclause)))
+ cps))
(_ cps)))
body
cps)))
@@ -819,7 +874,9 @@ and allocate and initialize flat closures."
kfun))
;; label -> free-var...
(free-vars (compute-free-vars cps kfun shared))
- (free-vars (prune-free-vars free-vars bound->label well-known
shared)))
+ (free-vars (prune-free-vars free-vars bound->label well-known shared))
+ ;; label...
+ (elidable (compute-elidable-closures cps well-known shared
free-vars)))
(let ((free-in-program (intmap-ref free-vars kfun)))
(unless (eq? empty-intset free-in-program)
(error "Expected no free vars in program" free-in-program)))
@@ -827,7 +884,8 @@ and allocate and initialize flat closures."
(persistent-intmap
(intmap-fold
(lambda (label body cps)
- (convert-one cps label body free-vars bound->label well-known
shared))
+ (convert-one cps label body free-vars bound->label well-known shared
+ elidable))
functions
cps)))))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index ad43eeb..434a9b3 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -624,6 +624,8 @@
(let ((first? (match (intmap-ref cps (1- label))
(($ $kfun) #t)
(_ #f)))
+ (has-closure? (match (intmap-ref cps (intmap-next cps))
+ (($ $kfun src meta self tail) (->bool self))))
(kw-indices (map (match-lambda
((key name sym)
(cons key (lookup-slot sym allocation))))
@@ -631,10 +633,11 @@
(unless first?
(emit-end-arity asm))
(emit-label asm label)
- (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
- frame-size alt)
- ;; All arities define a closure binding in slot 0.
- (emit-definition asm 'closure 0 'scm)
+ (emit-begin-kw-arity asm has-closure? req opt rest kw-indices
+ allow-other-keys? frame-size alt)
+ (when has-closure?
+ ;; Most arities define a closure binding in slot 0.
+ (emit-definition asm 'closure 0 'scm))
;; Usually we just fall through, but it could be the body is
;; contified into another clause.
(let ((body (forward-label body)))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 70b3ad3..5f8fa46 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -152,7 +152,7 @@ false. It could be that both true and false proofs are
available."
(intset-map (lambda (label)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
- (list self))
+ (if self (list self) '()))
(($ $kclause arity body alt)
(match (intmap-ref conts body)
(($ $kargs names vars) vars)))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 6fc885e..91a7895 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -251,7 +251,8 @@ sites."
(($ $kclause arity kargs kalt)
(values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
- (values live-labels (adjoin-var self live-vars)))
+ (values live-labels
+ (if self (adjoin-var self live-vars) live-vars)))
(($ $ktail)
(values live-labels live-vars))))
conts label live-labels live-vars))
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 2b48479..ca43ad2 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -127,7 +127,7 @@
(match (intmap-ref conts label)
(($ $kargs names syms exp)
(fold1 rename-var syms vars))
- (($ $kfun src meta self tail clause)
+ (($ $kfun src meta (and self (not #f)) tail clause)
(rename-var self vars))
(_ vars))))
(define (maybe-visit-fun kfun labels vars)
@@ -220,7 +220,7 @@
(($ $ktail)
($ktail))
(($ $kfun src meta self tail clause)
- ($kfun src meta (rename-var self) (rename-label tail)
+ ($kfun src meta (and self (rename-var self)) (rename-label tail)
(and clause (rename-label clause))))
(($ $kclause arity body alternate)
($kclause ,(rename-arity arity) (rename-label body)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 7ce886d..a894706 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -1,6 +1,6 @@
;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -143,7 +143,7 @@ by a label, respectively."
(intmap-add! uses label u)))
(match cont
(($ $kfun src meta self)
- (return (intset self) empty-intset))
+ (return (if self (intset self) empty-intset) empty-intset))
(($ $kargs _ _ ($ $continue k src exp))
(match exp
((or ($ $const) ($ $const-fun) ($ $code))
@@ -324,7 +324,7 @@ the definitions that are live before and after LABEL, as
intsets."
(($ $kclause arity body alternate)
(get-defs label))
(($ $kfun src meta self)
- (intset self))
+ (if self (intset self) empty-intset))
(($ $ktail)
empty-intset))))
cps
@@ -640,22 +640,27 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-fold measure-cont cps minimum-frame-size))
(define (allocate-args cps)
- (intmap-fold (lambda (label cont slots)
- (match cont
- (($ $kfun src meta self)
- (intmap-add! slots self 0))
- (($ $kclause arity body alt)
- (match (intmap-ref cps body)
- (($ $kargs names vars)
- (let lp ((vars vars) (slots slots) (n 1))
- (match vars
- (() slots)
- ((var . vars)
- (lp vars
- (intmap-add! slots var n)
- (1+ n))))))))
- (_ slots)))
- cps empty-intmap))
+ (match (intmap-ref cps (intmap-next cps))
+ (($ $kfun _ _ has-self?)
+ (intmap-fold (lambda (label cont slots)
+ (match cont
+ (($ $kfun src meta self)
+ (if has-self?
+ (intmap-add! slots self 0)
+ slots))
+ (($ $kclause arity body alt)
+ (match (intmap-ref cps body)
+ (($ $kargs names vars)
+ (let lp ((vars vars) (slots slots)
+ (n (if has-self? 1 0)))
+ (match vars
+ (() slots)
+ ((var . vars)
+ (lp vars
+ (intmap-add! slots var n)
+ (1+ n))))))))
+ (_ slots)))
+ cps empty-intmap))))
(define-inlinable (add-live-slot slot live-slots)
(logior live-slots (ash 1 slot)))
@@ -784,7 +789,9 @@ are comparable with eqv?. A tmp slot may be used."
(($ $kargs _ _ (or ($ $branch) ($ $prompt) ($ $throw)))
representations)
(($ $kfun src meta self)
- (intmap-add representations self 'scm))
+ (if self
+ (intmap-add representations self 'scm)
+ representations))
(($ $kclause arity body alt)
(fold1 (lambda (var representations)
(intmap-add representations var 'scm))
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 3bc9295..edbd9ad 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2015, 2016, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2015, 2016, 2017, 2018, 2019 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
@@ -305,7 +305,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(continue
(match (intmap-ref cps label)
(($ $kfun src meta self)
- (add-def out self))
+ (if self (add-def out self) out))
(($ $kargs names vars term)
(let ((out (add-defs out vars)))
(match term
@@ -670,7 +670,7 @@ BITS indicating the significant bits needed for a variable.
BITS may be
(lambda (label defs)
(match (intmap-ref conts label)
(($ $kfun src meta self tail clause)
- (intmap-add defs self label))
+ (if self (intmap-add defs self label) defs))
(($ $kargs names vars)
(fold1 (lambda (var defs)
(intmap-add defs var label))
diff --git a/module/language/cps/split-rec.scm
b/module/language/cps/split-rec.scm
index d58db16..ee5f2f2 100644
--- a/module/language/cps/split-rec.scm
+++ b/module/language/cps/split-rec.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2019 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
@@ -97,7 +97,7 @@ references."
(add-use tag uses))
(($ $throw src op param args)
(add-uses args uses)))))
- (($ $kfun src meta self)
+ (($ $kfun src meta (and self (not #f)))
(values (add-def self defs) uses))
(_ (values defs uses))))
body empty-intset empty-intset))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 2e73705..bcf22d3 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1,5 +1,5 @@
;;; Type analysis on CPS
-;;; Copyright (C) 2014-2015,2017-2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2019 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
@@ -1935,7 +1935,9 @@ maximum, where type is a bitset as a fixnum."
(propagate1 k (adjoin-vars types vars all-types-entry)))))
(($ $kfun src meta self tail clause)
(if clause
- (propagate1 clause (adjoin-var types self all-types-entry))
+ (propagate1 clause (if self
+ (adjoin-var types self all-types-entry)
+ types))
(propagate0)))
(($ $kclause arity kbody kalt)
(match (intmap-ref conts kbody)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index a634d9a..9359f0c 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -92,7 +92,7 @@
(match cont
(($ $kargs names syms body)
(apply max max-var syms))
- (($ $kfun src meta self)
+ (($ $kfun src meta (and self (not #f)))
(max max-var self))
(_ max-var)))
conts
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 6a0b564..af8d452 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -1,5 +1,5 @@
;;; Diagnostic checker for CPS
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2019 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
@@ -64,7 +64,7 @@
(match (intmap-ref conts label)
(($ $kargs names vars term)
(fold1 adjoin-def vars seen))
- (($ $kfun src meta self tail clause)
+ (($ $kfun src meta (and self (not #f)) tail clause)
(adjoin-def self seen))
(_ seen))
)
@@ -113,7 +113,7 @@ definitions that are available at LABEL."
(($ $kreceive arity k)
(propagate1 k in))
(($ $kfun src meta self tail clause)
- (let ((out (adjoin-def self in)))
+ (let ((out (if self (adjoin-def self in) in)))
(if clause
(propagate1 clause out)
(propagate0 out))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 9477cb9..c9e9f5f 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1412,13 +1412,15 @@ returned instead."
(meta-jit-data-label meta)
(asm-constants asm)))))
-(define-macro-assembler (begin-standard-arity asm req nlocals alternate)
- (emit-begin-opt-arity asm req '() #f nlocals alternate))
+(define-macro-assembler (begin-standard-arity asm has-closure? req nlocals
+ alternate)
+ (emit-begin-opt-arity asm has-closure? req '() #f nlocals alternate))
-(define-macro-assembler (begin-opt-arity asm req opt rest nlocals alternate)
- (emit-begin-kw-arity asm req opt rest '() #f nlocals alternate))
+(define-macro-assembler (begin-opt-arity asm has-closure? req opt rest nlocals
+ alternate)
+ (emit-begin-kw-arity asm has-closure? req opt rest '() #f nlocals alternate))
-(define-macro-assembler (begin-kw-arity asm req opt rest kw-indices
+(define-macro-assembler (begin-kw-arity asm has-closure? req opt rest
kw-indices
allow-other-keys? nlocals alternate)
(assert-match req ((? symbol?) ...) "list of symbols")
(assert-match opt ((? symbol?) ...) "list of symbols")
@@ -1439,7 +1441,8 @@ returned instead."
;; The procedure itself is in slot 0, in the standard calling
;; convention. For procedure prologues, nreq includes the
;; procedure, so here we add 1.
- (nreq (1+ (length req)))
+ (nclosure (if has-closure? 1 0))
+ (nreq (+ nclosure (length req)))
(nopt (length opt))
(rest? (->bool rest)))
(set-meta-arities! meta (cons arity (meta-arities meta)))
- [Guile-commits] branch master updated (12d6e43 -> 3bbdf22), Andy Wingo, 2019/06/07
- [Guile-commits] 03/06: VM does not initialize stack frames, Andy Wingo, 2019/06/07
- [Guile-commits] 01/06: Add bind-optionals instruction, Andy Wingo, 2019/06/07
- [Guile-commits] 02/06: Allow for bind-optionals without alloc-frame, Andy Wingo, 2019/06/07
- [Guile-commits] 05/06: Add support no closure in $callk, Andy Wingo, 2019/06/07
- [Guile-commits] 04/06: Add compiler support for eliding closure bindings,
Andy Wingo <=
- [Guile-commits] 06/06: Enable closure elision., Andy Wingo, 2019/06/07