[Guile-commits] 05/06: Add support no closure in $callk

[Andy Wingo]

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)