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

Add compiler support for eliding closure bindings

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2019-06-07 15:37:20 +02:00
parent f07fadc72e
commit f6c07e4eb2
12 changed files with 131 additions and 57 deletions
Download patch file Download diff file Expand all files Collapse all files

72
module/language/cps/closure-conversion.scm
View file

@ -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.
;; 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))))))
($ (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)))))

13
module/language/cps/compile-bytecode.scm
View file

@ -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)))

2
module/language/cps/cse.scm
View file

@ -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)))

5
module/language/cps/dce.scm
View file

@ -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))

6
module/language/cps/renumber.scm
View file

@ -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)

21
module/language/cps/slot-allocation.scm
View file

@ -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,14 +640,19 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-fold measure-cont cps minimum-frame-size))
(define (allocate-args cps)
(match (intmap-ref cps (intmap-next cps))
(($ $kfun _ _ has-self?)
(intmap-fold (lambda (label cont slots)
(match cont
(($ $kfun src meta self)
(intmap-add! slots self 0))
(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 1))
(let lp ((vars vars) (slots slots)
(n (if has-self? 1 0)))
(match vars
(() slots)
((var . vars)
@ -655,7 +660,7 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-add! slots var n)
(1+ n))))))))
(_ slots)))
cps empty-intmap))
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))

6
module/language/cps/specialize-numbers.scm
View file

@ -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))

4
module/language/cps/split-rec.scm
View file

@ -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))

6
module/language/cps/types.scm
View file

@ -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)

2
module/language/cps/utils.scm
View file

@ -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

6
module/language/cps/verify.scm
View file

@ -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))))

15
module/system/vm/assembler.scm
View file

@ -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)))