mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 22:40:34 +02:00
Code Activity

Allow $kargs as entry of $kfun

Browse source 
* module/language/cps.scm:
* module/language/cps/contification.scm:
* module/language/cps/cse.scm:
* module/language/cps/dce.scm:
* module/language/cps/simplify.scm:
* module/language/cps/slot-allocation.scm:
* module/language/cps/types.scm: Allow $kargs to follow $kfun.  In that
case, the function must be well-known and callers are responsible for
calling with the appropriate arity.
* module/language/cps/compile-bytecode.scm: Emit "unchecked-arity" for
$kargs following $kfun.
* module/system/vm/assembler.scm: Adapt.
This commit is contained in:
Andy Wingo 2021-04-20 20:18:10 +02:00
parent 58ce5fac7d
commit 8aacaad96a
9 changed files with 101 additions and 54 deletions
Download patch file Download diff file Expand all files Collapse all files

16
module/language/cps.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2015,2017-2018,2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2015,2017-2018,2020,2021 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
@ -173,7 +173,7 @@
;; Continuations
(define-cps-type $kreceive arity kbody)
(define-cps-type $kargs names syms term)
(define-cps-type $kfun src meta self ktail kclause)
(define-cps-type $kfun src meta self ktail kentry)
(define-cps-type $ktail)
(define-cps-type $kclause arity kbody kalternate)
@ -214,8 +214,8 @@
(make-$kargs (list name ...) (list sym ...) (build-term body)))
((_ ($kargs names syms body))
(make-$kargs names syms (build-term body)))
((_ ($kfun src meta self ktail kclause))
(make-$kfun src meta self ktail kclause))
((_ ($kfun src meta self ktail kentry))
(make-$kfun src meta self ktail kentry))
((_ ($ktail))
(make-$ktail))
((_ ($kclause arity kbody kalternate))
@ -288,8 +288,8 @@
(build-cont ($kreceive req rest k)))
(('kargs names syms body)
(build-cont ($kargs names syms ,(parse-cps body))))
(('kfun meta self ktail kclause)
(build-cont ($kfun (src exp) meta self ktail kclause)))
(('kfun meta self ktail kentry)
(build-cont ($kfun (src exp) meta self ktail kentry)))
(('ktail)
(build-cont ($ktail)))
(('kclause (req opt rest kw allow-other-keys?) kbody)
@ -342,8 +342,8 @@
`(kreceive ,req ,rest ,k))
(($ $kargs names syms body)
`(kargs ,names ,syms ,(unparse-cps body)))
(($ $kfun src meta self ktail kclause)
`(kfun ,meta ,self ,ktail ,kclause))
(($ $kfun src meta self ktail kentry)
`(kfun ,meta ,self ,ktail ,kentry))
(($ $ktail)
`(ktail))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate)

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2021 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
@ -638,10 +638,17 @@
(define (compile-cont label cont)
(match cont
(($ $kfun src meta self tail clause)
(($ $kfun src meta self tail entry)
(when src
(emit-source asm src))
(emit-begin-program asm label meta))
(emit-begin-program asm label meta)
;; If the function has a $kargs as entry, handle
(match (intmap-ref cps entry)
(($ $kclause) #t) ;; Leave arity handling to the
(($ $kargs names vars _)
(emit-begin-unchecked-arity asm (->bool self) names frame-size)
(when self
(emit-definition asm 'closure 0 'scm)))))
(($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
(let ((first? (match (intmap-ref cps (1- label))
(($ $kfun) #t)

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2021 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
@ -79,7 +79,9 @@ from label to arities."
(if clause
(match (intmap-ref conts clause)
(($ $kclause arity body alt)
(cons arity (clause-arities alt))))
(cons arity (clause-arities alt)))
(($ $kargs names vars _)
(list (make-$arity names '() #f '() #f))))
'()))
(intmap-map (lambda (label vars)
(match (intmap-ref conts label)
@ -346,7 +348,10 @@ function set."
(($ $kclause arity body alt)
(if (arity-matches? arity nargs)
body
(lp alt))))))))
(lp alt)))
(($ $kargs names)
(unless (= nargs (length names)) (error "what"))
clause))))))
(define (inline-return cps k* kargs src nreq rest vals)
(define (build-list cps k src vals)
(match vals

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2021 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
@ -287,7 +287,10 @@ for a label, it isn't known to be constant at that label."
($kreceive req rest (rename kbody)))
(($ $kclause arity kbody kalternate)
;; Can only be a body continuation.
($kclause ,arity (rename kbody) kalternate))))
($kclause ,arity (rename kbody) kalternate))
(($ $kfun src meta self tail kentry)
;; Can only be a $kargs clause continuation.
($kfun src meta self tail (rename kentry)))))
(define (elide-predecessor label pred out analysis)
(match analysis
@ -722,7 +725,7 @@ for a label, it isn't known to be constant at that label."
;; those as well.
(add-auxiliary-definitions! pred vars substs term-key)))
(visit-term-normally))
((or ($ $kclause) ($ $kreceive))
((or ($ $kclause) ($ $kfun) ($ $kreceive))
(visit-term-normally)))))
(else
(visit-term-normally)))))))

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2021 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
@ -88,8 +88,8 @@ sites."
(values known unknown))
(($ $kreceive arity kargs)
(values known (intset-add! unknown kargs)))
(($ $kfun src meta self tail clause)
(values known unknown))
(($ $kfun src meta self tail entry)
(values known (intset-add! unknown entry)))
(($ $kclause arity body alt)
(values known (intset-add! unknown body)))
(($ $ktail)
@ -267,9 +267,11 @@ sites."
(values live-labels live-vars))
(($ $kclause arity kargs kalt)
(values live-labels (adjoin-vars (cont-defs kargs) live-vars)))
(($ $kfun src meta self)
(($ $kfun src meta self tail entry)
(values live-labels
(if self (adjoin-var self live-vars) live-vars)))
(adjoin-vars
(or (cont-defs entry) '())
(if self (adjoin-var self live-vars) live-vars))))
(($ $ktail)
(values live-labels live-vars))))
conts label live-labels live-vars))

4
module/language/cps/simplify.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2015, 2017-2021 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
@ -177,6 +177,8 @@
($kreceive req rest (subst k)))
(($ $kclause arity body alt)
($kclause ,arity (subst body) alt))
(($ $kfun src meta self tail entry)
($kfun src meta self tail (subst entry)))
(_ ,cont))))
conts)))

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

@ -1,6 +1,6 @@
;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2020 Free Software Foundation, Inc.
;; Copyright (C) 2013-2021 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
@ -142,8 +142,11 @@ by a label, respectively."
(values (intmap-add! defs label d)
(intmap-add! uses label u)))
(match cont
(($ $kfun src meta self)
(return (if self (intset self) empty-intset) empty-intset))
(($ $kfun src meta self tail clause)
(return (intset-union
(if clause (get-defs clause) empty-intset)
(if self (intset self) empty-intset))
empty-intset))
(($ $kargs _ _ ($ $continue k src exp))
(match exp
((or ($ $const) ($ $const-fun) ($ $code))
@ -331,7 +334,7 @@ the definitions that are live before and after LABEL, as intsets."
(($ $kclause arity body alternate)
(get-defs label))
(($ $kfun src meta self)
(if self (intset self) empty-intset))
(get-defs label))
(($ $ktail)
empty-intset))))
cps
@ -657,27 +660,29 @@ 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)
(if has-self?
(intmap-add! slots self 0)
slots))
(define (add-clause entry first-slot slots)
(match (intmap-ref cps entry)
(($ $kclause arity body alt)
(match (intmap-ref cps body)
(let ((slots (add-clause body first-slot slots)))
(if alt
(add-clause alt first-slot slots)
slots)))
(($ $kargs names vars)
(let lp ((vars vars) (slots slots)
(n (if has-self? 1 0)))
(let lp ((vars vars) (n first-slot) (slots slots))
(match vars
(() slots)
((var . vars)
(lp vars
(intmap-add! slots var n)
(1+ n))))))))
(_ slots)))
cps empty-intmap))))
(1+ n)
(intmap-add slots var n))))))))
(match (intmap-ref cps (intmap-next cps))
(($ $kfun src meta self tail entry)
(add-clause
entry
(if self 1 0)
(if self
(intmap-add empty-intmap self 0)
empty-intmap)))))
(define (allocate-lazy-vars cps slots call-allocs live-in lazy)
(define (compute-live-slots slots label)
@ -796,10 +801,13 @@ are comparable with eqv?. A tmp slot may be used."
representations args vars))))))
(($ $kargs _ _ (or ($ $branch) ($ $switch) ($ $prompt) ($ $throw)))
representations)
(($ $kfun src meta self)
(if self
(($ $kfun src meta self tail entry)
(let ((representations (if self
(intmap-add representations self 'scm)
representations))
representations)))
(fold1 (lambda (var representations)
(intmap-add representations var 'scm))
(get-defs entry) representations)))
(($ $kclause arity body alt)
(fold1 (lambda (var representations)
(intmap-add representations var 'scm))

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

@ -2098,9 +2098,14 @@ 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 (if self
(let ((types (if self
(adjoin-var types self all-types-entry)
types))
types)))
(propagate1 clause
(match (intmap-ref conts clause)
(($ $kargs _ defs)
(adjoin-vars types defs all-types-entry))
(_ types))))
(propagate0)))
(($ $kclause arity kbody kalt)
(match (intmap-ref conts kbody)

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

@ -1640,11 +1640,26 @@ returned instead."
(else
(emit-standard-prelude asm nreq nlocals alternate)))))
(define-macro-assembler (begin-unchecked-arity asm has-closure? req nlocals)
(assert-match req ((? symbol?) ...) "list of symbols")
(assert-match nlocals (? integer?) "integer")
(let* ((meta (car (asm-meta asm)))
(arity (make-arity req '() #f '() #f has-closure?
(meta-low-pc meta) #f '()))
(nclosure (if has-closure? 1 0))
(nreq (+ nclosure (length req))))
(set-meta-arities! meta (cons arity (meta-arities meta)))
(emit-unchecked-prelude asm nreq nlocals)))
(define-macro-assembler (end-arity asm)
(let ((arity (car (meta-arities (car (asm-meta asm))))))
(set-arity-definitions! arity (reverse (arity-definitions arity)))
(set-arity-high-pc! arity (asm-start asm))))
(define-macro-assembler (unchecked-prelude asm nreq nlocals)
(unless (= nlocals nreq)
(emit-alloc-frame asm nlocals)))
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond
(alternate