diff options
author | Andy Wingo <wingo@pobox.com> | 2019-06-07 15:37:20 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-06-07 17:01:37 +0200 |
commit | f6c07e4eb2212656fc6acb6c031b74237847eb42 (patch) | |
tree | 330ac8507238321e3b58e4d17c113d453224b429 /module | |
parent | f07fadc72e148d13bb4b42a3d9ecde6ab7a2296c (diff) | |
download | guile-f6c07e4eb2212656fc6acb6c031b74237847eb42.tar.gz |
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.
Diffstat (limited to 'module')
-rw-r--r-- | module/language/cps/closure-conversion.scm | 76 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 13 | ||||
-rw-r--r-- | module/language/cps/cse.scm | 2 | ||||
-rw-r--r-- | module/language/cps/dce.scm | 5 | ||||
-rw-r--r-- | module/language/cps/renumber.scm | 6 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 47 | ||||
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 6 | ||||
-rw-r--r-- | module/language/cps/split-rec.scm | 4 | ||||
-rw-r--r-- | module/language/cps/types.scm | 6 | ||||
-rw-r--r-- | module/language/cps/utils.scm | 2 | ||||
-rw-r--r-- | module/language/cps/verify.scm | 6 | ||||
-rw-r--r-- | 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 77c8faef3..0dfd25de4 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 ad43eebf5..434a9b3c5 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 70b3ad3e0..5f8fa460d 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 6fc885e7f..91a7895d8 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 2b4847926..ca43ad213 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 7ce886d48..a8947068b 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 3bc929514..edbd9adc2 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 d58db1652..ee5f2f2e4 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 2e73705d3..bcf22d391 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 a634d9ac4..9359f0cb7 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 6a0b564e2..af8d4525f 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 9477cb932..c9e9f5f7b 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))) |