[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/06: Add support no closure in $callk
From: |
Andy Wingo |
Subject: |
[Guile-commits] 05/06: Add support no closure in $callk |
Date: |
Fri, 7 Jun 2019 11:06:14 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 73a769fc2b09e047397f3a72ebd06b1aff1177c2
Author: Andy Wingo <address@hidden>
Date: Fri Jun 7 16:08:23 2019 +0200
Add support no closure in $callk
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/contification.scm (compute-contification-candidates):
* module/language/cps/cse.scm (apply-cse):
* module/language/cps/dce.scm (compute-live-code):
* module/language/cps/devirtualize-integers.scm (compute-use-counts):
* module/language/cps/peel-loops.scm (rename-cont):
* module/language/cps/renumber.scm (renumber):
* module/language/cps/rotate-loops.scm (rotate-loop):
* module/language/cps/simplify.scm (compute-singly-referenced-vars):
(beta-reduce):
* module/language/cps/slot-allocation.scm (compute-defs-and-uses):
(compute-lazy-vars):
(compute-shuffles):
(compute-frame-size):
(allocate-lazy-vars):
(allocate-slots):
* module/language/cps/specialize-numbers.scm (compute-significant-bits):
* module/language/cps/verify.scm (check-valid-var-uses): Allow for the
$callk proc to be #f.
* module/language/cps/compile-bytecode.scm (compile-function): Reset
frame to appropriate size.
---
module/language/cps/compile-bytecode.scm | 6 ++++--
module/language/cps/contification.scm | 4 ++--
module/language/cps/cse.scm | 2 +-
module/language/cps/dce.scm | 4 +++-
module/language/cps/devirtualize-integers.scm | 4 ++--
module/language/cps/peel-loops.scm | 4 ++--
module/language/cps/renumber.scm | 3 ++-
module/language/cps/rotate-loops.scm | 4 ++--
module/language/cps/self-references.scm | 2 +-
module/language/cps/simplify.scm | 4 ++--
module/language/cps/slot-allocation.scm | 18 +++++++++++-------
module/language/cps/specialize-numbers.scm | 5 ++++-
module/language/cps/verify.scm | 4 ++--
13 files changed, 38 insertions(+), 26 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 434a9b3..669be8c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -125,7 +125,8 @@
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
- (maybe-reset-frame (1+ (length args)))
+ (let ((nclosure (if proc 1 0)))
+ (maybe-reset-frame (+ nclosure (length args))))
(emit-handle-interrupts asm)
(emit-tail-call-label asm k))
(($ $values args)
@@ -519,7 +520,8 @@
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
(let* ((proc-slot (lookup-call-proc-slot label allocation))
- (nargs (1+ (length args)))
+ (nclosure (if proc 1 0))
+ (nargs (+ nclosure (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 43a58a1..7587fa3 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, 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
@@ -188,7 +188,7 @@ $call, and are always called with a compatible arity."
;; compiler handles this fine though, so we allow it.
(restrict-arity functions proc (length args))))
(($ $callk k proc args)
- (exclude-vars functions (cons proc args)))
+ (exclude-vars functions (if proc (cons proc args) args)))
(($ $primcall name param args)
(exclude-vars functions args))))
(($ $kargs _ _ ($ $branch kf kt src op param args))
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 5f8fa46..9f3b3da 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -365,7 +365,7 @@ false. It could be that both true and false proofs are
available."
(($ $call proc args)
($call (subst-var proc) ,(map subst-var args)))
(($ $callk k proc args)
- ($callk k (subst-var proc) ,(map subst-var args)))
+ ($callk k (and proc (subst-var proc)) ,(map subst-var args)))
(($ $primcall name param args)
($primcall name param ,(map subst-var args)))
(($ $values args)
diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 91a7895..5be573d 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -153,7 +153,9 @@ sites."
(values live-labels (adjoin-vars args (adjoin-var proc live-vars))))
(($ $callk kfun proc args)
(values (intset-add live-labels kfun)
- (adjoin-vars args (adjoin-var proc live-vars))))
+ (adjoin-vars args (if proc
+ (adjoin-var proc live-vars)
+ live-vars))))
(($ $primcall name param args)
(values live-labels (adjoin-vars args live-vars)))
(($ $values args)
diff --git a/module/language/cps/devirtualize-integers.scm
b/module/language/cps/devirtualize-integers.scm
index 71f4389..e7efd21 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2017-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
@@ -70,7 +70,7 @@
(($ $call proc args)
(add-uses (add-use use-counts proc) args))
(($ $callk kfun proc args)
- (add-uses (add-use use-counts proc) args))
+ (add-uses (if proc (add-use use-counts proc) use-counts) args))
(($ $primcall name param args)
(add-uses use-counts args))))
(($ $branch kf kt src op param args)
diff --git a/module/language/cps/peel-loops.scm
b/module/language/cps/peel-loops.scm
index 33d247f..b1bb396 100644
--- a/module/language/cps/peel-loops.scm
+++ b/module/language/cps/peel-loops.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
@@ -148,7 +148,7 @@
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
- ($callk k (rename-var proc) ,(map rename-var args)))
+ ($callk k (and proc (rename-var proc)) ,(map rename-var args)))
(($ $primcall name param args)
($primcall name param ,(map rename-var args)))))
(define (rename-term term)
diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index ca43ad2..7200a5f 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -182,7 +182,8 @@
(($ $call proc args)
($call (rename-var proc) ,(map rename-var args)))
(($ $callk k proc args)
- ($callk (rename-label k) (rename-var proc) ,(map rename-var args)))
+ ($callk (rename-label k) (and proc (rename-var proc))
+ ,(map rename-var args)))
(($ $primcall name param args)
($primcall name param ,(map rename-var args)))))
(define (rename-arity arity)
diff --git a/module/language/cps/rotate-loops.scm
b/module/language/cps/rotate-loops.scm
index 355a818..d80a272 100644
--- a/module/language/cps/rotate-loops.scm
+++ b/module/language/cps/rotate-loops.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
@@ -116,7 +116,7 @@ corresponding var from REPLACEMENTS; otherwise return VAR."
(($ $call proc args)
($call (rename proc) ,(rename* args)))
(($ $callk k proc args)
- ($callk k (rename proc) ,(rename* args)))
+ ($callk k (and proc (rename proc)) ,(rename* args)))
(($ $primcall name param args)
($primcall name param ,(rename* args))))))
(($ $branch kf kt src op param args)
diff --git a/module/language/cps/self-references.scm
b/module/language/cps/self-references.scm
index 63c9d61..8f67861 100644
--- a/module/language/cps/self-references.scm
+++ b/module/language/cps/self-references.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
diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm
index accdbb1..5bb8f4b 100644
--- a/module/language/cps/simplify.scm
+++ b/module/language/cps/simplify.scm
@@ -73,7 +73,7 @@
(($ $call proc args)
(ref* (cons proc args)))
(($ $callk k proc args)
- (ref* (cons proc args)))
+ (ref* (if proc (cons proc args) args)))
(($ $primcall name param args)
(ref* args))
(($ $values args)
@@ -259,7 +259,7 @@
(($ $call proc args)
($call (subst proc) ,(map subst args)))
(($ $callk k proc args)
- ($callk k (subst proc) ,(map subst args)))
+ ($callk k (and proc (subst proc)) ,(map subst args)))
(($ $primcall name param args)
($primcall name param ,(map subst args)))
(($ $values args)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index a894706..247d648 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -151,7 +151,8 @@ by a label, respectively."
(($ $call proc args)
(return (get-defs k) (intset-add (vars->intset args) proc)))
(($ $callk _ proc args)
- (return (get-defs k) (intset-add (vars->intset args) proc)))
+ (let ((args (vars->intset args)))
+ (return (get-defs k) (if proc (intset-add args proc) args))))
(($ $primcall name param args)
(return (get-defs k) (vars->intset args)))
(($ $values args)
@@ -350,8 +351,9 @@ is an active call."
(intset-subtract (intset-add (list->intset args) proc)
(intmap-ref live-out label)))
(($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args)))
- (intset-subtract (intset-add (list->intset args) proc)
- (intmap-ref live-out label)))
+ (let ((args (list->intset args)))
+ (intset-subtract (if proc (intset-add args proc) args)
+ (intmap-ref live-out label))))
(($ $kargs _ _ ($ $continue k _($ $values args)))
(match (intmap-ref cps k)
(($ $ktail) (list->intset args))
@@ -587,7 +589,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $call proc args)
(add-call-shuffles label k (cons proc args) shuffles))
(($ $callk _ proc args)
- (add-call-shuffles label k (cons proc args) shuffles))
+ (add-call-shuffles label k (if proc (cons proc args) args) shuffles))
(($ $values args)
(add-values-shuffles label k args shuffles))
(_ shuffles)))
@@ -629,7 +631,8 @@ are comparable with eqv?. A tmp slot may be used."
(($ $continue _ _ ($ $call proc args))
(call-size label (1+ (length args)) size))
(($ $continue _ _ ($ $callk _ proc args))
- (call-size label (1+ (length args)) size))
+ (let ((nclosure (if proc 1 0)))
+ (call-size label (+ nclosure (length args)) size)))
(($ $continue _ _ ($ $values args))
(shuffle-size (get-shuffles label) size))
(_ size))))
@@ -724,7 +727,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $call proc args)
(allocate-call label (cons proc args) slots))
(($ $callk _ proc args)
- (allocate-call label (cons proc args) slots))
+ (allocate-call label (if proc (cons proc args) args) slots))
(($ $values args)
(allocate-values label k args slots))
(_ slots)))
@@ -987,7 +990,8 @@ are comparable with eqv?. A tmp slot may be used."
(($ $continue k src ($ $call proc args))
(allocate-call label k (cons proc args) slots call-allocs live))
(($ $continue k src ($ $callk _ proc args))
- (allocate-call label k (cons proc args) slots call-allocs live))
+ (allocate-call label k (if proc (cons proc args) args)
+ slots call-allocs live))
(($ $continue k src ($ $values args))
(allocate-values label k args slots call-allocs))
(($ $prompt k kh src escape? tag)
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index edbd9ad..dc8e26f 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -329,7 +329,10 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(($ $call proc args)
(add-unknown-use (add-unknown-uses out args) proc))
(($ $callk label proc args)
- (add-unknown-use (add-unknown-uses out args) proc))
+ (let ((out (add-unknown-uses out args)))
+ (if proc
+ (add-unknown-use out proc)
+ out)))
(($ $primcall name param args)
(let ((h (significant-bits-handler name)))
(if h
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index af8d452..cacde9e 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -162,7 +162,7 @@ definitions that are available at LABEL."
(for-each check-use args)
first-order)
(($ $callk kfun proc args)
- (check-use proc)
+ (when proc (check-use proc))
(for-each check-use args)
(visit-first-order kfun))
(($ $primcall name param args)
@@ -199,7 +199,7 @@ definitions that are available at LABEL."
(for-each check-use args)
first-order)
(($ $callk kfun proc args)
- (check-use proc)
+ (when proc (check-use proc))
(for-each check-use args)
(visit-first-order kfun))
(($ $primcall name param args)
- [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 <=
- [Guile-commits] 04/06: Add compiler support for eliding closure bindings, Andy Wingo, 2019/06/07
- [Guile-commits] 06/06: Enable closure elision., Andy Wingo, 2019/06/07