[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 03/04: Allow $kargs as entry of $kfun
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 03/04: Allow $kargs as entry of $kfun |
|
Date: |
Thu, 22 Apr 2021 02:04:45 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 8aacaad96accf66b2235421832b6b57de832b234
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Apr 20 20:18:10 2021 +0200
Allow $kargs as entry of $kfun
* 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.
---
module/language/cps.scm | 16 ++++----
module/language/cps/compile-bytecode.scm | 13 +++++--
module/language/cps/contification.scm | 11 ++++--
module/language/cps/cse.scm | 9 +++--
module/language/cps/dce.scm | 12 +++---
module/language/cps/simplify.scm | 4 +-
module/language/cps/slot-allocation.scm | 64 ++++++++++++++++++--------------
module/language/cps/types.scm | 11 ++++--
module/system/vm/assembler.scm | 15 ++++++++
9 files changed, 101 insertions(+), 54 deletions(-)
diff --git a/module/language/cps.scm b/module/language/cps.scm
index 9682061..f83b625 100644
--- a/module/language/cps.scm
+++ b/module/language/cps.scm
@@ -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)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index e7d8abc..40cd904 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-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)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 664c4b3..7cea6b2 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -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
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index efa95cd..55cf549 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -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)))))))
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index aa52611..bc8345d 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-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))
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index b44c1e7..20c1279 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -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)))
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 6a90db0..ff32e1a 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-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)
+ (define (add-clause entry first-slot slots)
+ (match (intmap-ref cps entry)
+ (($ $kclause arity body alt)
+ (let ((slots (add-clause body first-slot slots)))
+ (if alt
+ (add-clause alt first-slot slots)
+ slots)))
+ (($ $kargs names vars)
+ (let lp ((vars vars) (n first-slot) (slots slots))
+ (match vars
+ (() slots)
+ ((var . vars)
+ (lp vars
+ (1+ n)
+ (intmap-add slots var n))))))))
(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))))
+ (($ $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
- (intmap-add representations self 'scm)
- representations))
+ (($ $kfun src meta self tail entry)
+ (let ((representations (if self
+ (intmap-add representations self 'scm)
+ 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))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 574c39b..7657bf4 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -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
- (adjoin-var types self all-types-entry)
- types))
+ (let ((types (if self
+ (adjoin-var types self all-types-entry)
+ 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)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8139263..c94cec3 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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