[Guile-commits] 28/30: Refactor to finish the primcalls-take-parameters work

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 3600dbf0cc96a2c0752c1429631c7fbe96eeb501
Author: Andy Wingo <address@hidden>
Date:   Tue Nov 21 21:43:27 2017 +0100

    Refactor to finish the primcalls-take-parameters work
    
    * module/language/cps/compile-bytecode.scm (compile-function): Remove
      helper to look up constants now that primcalls can take parameters.
    * module/language/cps/devirtualize-integers.scm (peel-trace): Remove
      extra argument to expression-effects.
    * module/language/cps/effects-analysis.scm (constant?, indexed-field):
      Remove unused definitions.
      (expression-effects): Remove "constants" argument; constants come from
      primcall params.
      (compute-effects): Don't compute a constants table.
    * module/language/cps/slot-allocation.scm ($allocation): Remove
      "constant-values" field.
      (lookup-constant-value, lookup-maybe-constant-value): Remove; unused.
      (allocate-slots): Don't create a constants table.
    * module/language/cps/specialize-primcalls.scm
      (compute-defining-expressions, compute-constant-values): Move these
      definitions here, which were previously in utils.scm
    * module/language/cps/utils.scm: Remove moved definitions.
---
 module/language/cps/compile-bytecode.scm      |  3 --
 module/language/cps/devirtualize-integers.scm |  2 +-
 module/language/cps/effects-analysis.scm      | 46 ++++++++-------------
 module/language/cps/slot-allocation.scm       | 27 +------------
 module/language/cps/specialize-primcalls.scm  | 56 ++++++++++++++++++++++++++
 module/language/cps/utils.scm                 | 57 ---------------------------
 6 files changed, 76 insertions(+), 115 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index ad7e97a..8393138 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -99,9 +99,6 @@
     (define (slot sym)
       (lookup-slot sym allocation))
 
-    (define (constant sym)
-      (lookup-constant-value sym allocation))
-
     (define (from-sp var)
       (- frame-size 1 var))
 
diff --git a/module/language/cps/devirtualize-integers.scm 
b/module/language/cps/devirtualize-integers.scm
index 45db74a..1cedaea 100644
--- a/module/language/cps/devirtualize-integers.scm
+++ b/module/language/cps/devirtualize-integers.scm
@@ -169,7 +169,7 @@ the trace should be referenced outside of it."
                         (build-exp ($values ,(rename-uses args))))))
            (($ $primcall name param args)
             ;; exp is effect-free or var of interest in args
-            (let* ((fx (expression-effects exp #f))
+            (let* ((fx (expression-effects exp))
                    (uses-of-interest? (any-use-of-interest? args))
                    (live-vars (subtract-uses live-vars args)))
               ;; If the primcall uses a value of interest,
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 8c2fcd5..fd5e797 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -208,9 +208,6 @@
   (identifier-syntax
    (logior &all-effect-kinds (&object &unknown-memory-kinds))))
 
-(define-inlinable (constant? effects)
-  (zero? effects))
-
 (define-inlinable (causes-effect? x effects)
   (not (zero? (logand x effects))))
 
@@ -233,12 +230,6 @@ is or might be a read or a write to the same location as 
A."
        (not (zero? (logand b (logior &read &write))))
        (locations-same?)))
 
-(define-inlinable (indexed-field kind var constants)
-  (let ((val (intmap-ref constants var (lambda (_) #f))))
-    (if (and (exact-integer? val) (<= 0 val))
-        (&field kind val)
-        (&object kind))))
-
 (define *primitive-effects* (make-hash-table))
 
 (define-syntax-rule (define-primitive-effects* param
@@ -513,7 +504,7 @@ is or might be a read or a write to the same location as A."
         (apply proc param args)
         &all-effects)))
 
-(define (expression-effects exp constants)
+(define (expression-effects exp)
   (match exp
     ((or ($ $const) ($ $prim) ($ $values))
      &no-effects)
@@ -529,28 +520,25 @@ is or might be a read or a write to the same location as 
A."
     ((or ($ $call) ($ $callk))
      &all-effects)
     (($ $branch k exp)
-     (expression-effects exp constants))
+     (expression-effects exp))
     (($ $primcall name param args)
-     ;; FIXME: hack to still support constants table while migrating
-     ;; to immediate parameters.
-     (primitive-effects (or param constants) name args))))
+     (primitive-effects param name args))))
 
 (define (compute-effects conts)
-  (let ((constants (compute-constant-values conts)))
-    (intmap-map
-     (lambda (label cont)
-       (match cont
-         (($ $kargs names syms ($ $continue k src exp))
-          (expression-effects exp constants))
-         (($ $kreceive arity kargs)
-          (match arity
-            (($ $arity _ () #f () #f) &type-check)
-            (($ $arity () () _ () #f) (&allocate &pair))
-            (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
-         (($ $kfun) &type-check)
-         (($ $kclause) &type-check)
-         (($ $ktail) &no-effects)))
-     conts)))
+  (intmap-map
+   (lambda (label cont)
+     (match cont
+       (($ $kargs names syms ($ $continue k src exp))
+        (expression-effects exp))
+       (($ $kreceive arity kargs)
+        (match arity
+          (($ $arity _ () #f () #f) &type-check)
+          (($ $arity () () _ () #f) (&allocate &pair))
+          (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check))))
+       (($ $kfun) &type-check)
+       (($ $kclause) &type-check)
+       (($ $ktail) &no-effects)))
+   conts))
 
 ;; There is a way to abuse effects analysis in CSE to also do scalar
 ;; replacement, effectively adding `car' and `cdr' expressions to `cons'
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 4315c55..7106584 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -36,16 +36,13 @@
             lookup-slot
             lookup-maybe-slot
             lookup-representation
-            lookup-constant-value
-            lookup-maybe-constant-value
             lookup-nlocals
             lookup-call-proc-slot
             lookup-parallel-moves
             lookup-slot-map))
 
 (define-record-type $allocation
-  (make-allocation slots representations constant-values call-allocs
-                   shuffles frame-size)
+  (make-allocation slots representations call-allocs shuffles frame-size)
   allocation?
 
   ;; A map of VAR to slot allocation.  A slot allocation is an integer,
@@ -58,10 +55,6 @@
   ;;
   (representations allocation-representations)
 
-  ;; A map of VAR to constant value, for variables with constant values.
-  ;;
-  (constant-values allocation-constant-values)
-
   ;; A map of LABEL to /call allocs/, for expressions that continue to
   ;; $kreceive continuations: non-tail calls and $prompt expressions.
   ;;
@@ -110,20 +103,6 @@
 
 (define *absent* (list 'absent))
 
-(define (lookup-constant-value var allocation)
-  (let ((value (intmap-ref (allocation-constant-values allocation) var
-                           (lambda (_) *absent*))))
-    (when (eq? value *absent*)
-      (error "Variable does not have constant value" var))
-    value))
-
-(define (lookup-maybe-constant-value var allocation)
-  (let ((value (intmap-ref (allocation-constant-values allocation) var
-                           (lambda (_) *absent*))))
-    (if (eq? value *absent*)
-        (values #f #f)
-        (values #t value))))
-
 (define (lookup-call-alloc k allocation)
   (intmap-ref (allocation-call-allocs allocation) k))
 
@@ -800,7 +779,6 @@ are comparable with eqv?.  A tmp slot may be used."
   (let*-values (((defs uses) (compute-defs-and-uses cps))
                 ((representations) (compute-var-representations cps))
                 ((live-in live-out) (compute-live-variables cps defs uses))
-                ((constants) (compute-constant-values cps))
                 ((needs-slot) (compute-needs-slot cps defs uses))
                 ((lazy) (compute-lazy-vars cps live-in live-out defs
                                            needs-slot)))
@@ -995,5 +973,4 @@ are comparable with eqv?.  A tmp slot may be used."
         (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy))
                (shuffles (compute-shuffles cps slots calls live-in))
                (frame-size (compute-frame-size cps slots calls shuffles)))
-          (make-allocation slots representations constants calls
-                           shuffles frame-size))))))
+          (make-allocation slots representations calls shuffles 
frame-size))))))
diff --git a/module/language/cps/specialize-primcalls.scm 
b/module/language/cps/specialize-primcalls.scm
index a5ce739..25c7d65 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -31,6 +31,62 @@
   #:use-module (language cps intmap)
   #:export (specialize-primcalls))
 
+(define (compute-defining-expressions conts)
+  (define (meet-defining-expressions old new)
+    ;; If there are multiple definitions and they are different, punt
+    ;; and record #f.
+    (if (equal? old new)
+        old
+        #f))
+  (persistent-intmap
+   (intmap-fold (lambda (label cont defs)
+                  (match cont
+                    (($ $kargs _ _ ($ $continue k src exp))
+                     (match (intmap-ref conts k)
+                       (($ $kargs (_) (var))
+                        (intmap-add! defs var exp meet-defining-expressions))
+                       (_ defs)))
+                    (_ defs)))
+                conts
+                empty-intmap)))
+
+(define (compute-constant-values conts)
+  (let ((defs (compute-defining-expressions conts)))
+    (persistent-intmap
+     (intmap-fold
+      (lambda (var exp out)
+        (match exp
+          (($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
+           (intmap-add! out var val))
+          ;; Punch through type conversions to allow uadd to specialize
+          ;; to uadd/immediate.
+          (($ $primcall 'scm->f64 #f (val))
+           (let ((f64 (intmap-ref out val (lambda (_) #f))))
+             (if (and f64 (number? f64) (inexact? f64) (real? f64))
+                 (intmap-add! out var f64)
+                 out)))
+          (($ $primcall (or 'scm->u64 'scm->u64/truncate) #f (val))
+           (let ((u64 (intmap-ref out val (lambda (_) #f))))
+             (if (and u64 (number? u64) (exact-integer? u64)
+                      (<= 0 u64 #xffffFFFFffffFFFF))
+                 (intmap-add! out var u64)
+                 out)))
+          (($ $primcall 'scm->s64 #f (val))
+           (let ((s64 (intmap-ref out val (lambda (_) #f))))
+             (if (and s64 (number? s64) (exact-integer? s64)
+                      (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
+                 (intmap-add! out var s64)
+                 out)))
+          (_ out)))
+      defs
+      (intmap-fold (lambda (var exp out)
+                     (match exp
+                       (($ $const val)
+                        (intmap-add! out var val))
+                       (_ out)))
+                   defs
+                   empty-intmap)))))
+
 (define (specialize-primcalls conts)
   (let ((constants (compute-constant-values conts)))
     (define (uint? var)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 01768e6..3d7ac9c 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -46,7 +46,6 @@
             fixpoint
 
             ;; Flow analysis.
-            compute-constant-values
             compute-function-body
             compute-reachable-functions
             compute-successors
@@ -180,62 +179,6 @@ disjoint, an error will be signalled."
                (values x0* x1*)
                (lp x0* x1*))))))))
 
-(define (compute-defining-expressions conts)
-  (define (meet-defining-expressions old new)
-    ;; If there are multiple definitions and they are different, punt
-    ;; and record #f.
-    (if (equal? old new)
-        old
-        #f))
-  (persistent-intmap
-   (intmap-fold (lambda (label cont defs)
-                  (match cont
-                    (($ $kargs _ _ ($ $continue k src exp))
-                     (match (intmap-ref conts k)
-                       (($ $kargs (_) (var))
-                        (intmap-add! defs var exp meet-defining-expressions))
-                       (_ defs)))
-                    (_ defs)))
-                conts
-                empty-intmap)))
-
-(define (compute-constant-values conts)
-  (let ((defs (compute-defining-expressions conts)))
-    (persistent-intmap
-     (intmap-fold
-      (lambda (var exp out)
-        (match exp
-          (($ $primcall (or 'load-f64 'load-u64 'load-s64) val ())
-           (intmap-add! out var val))
-          ;; Punch through type conversions to allow uadd to specialize
-          ;; to uadd/immediate.
-          (($ $primcall 'scm->f64 #f (val))
-           (let ((f64 (intmap-ref out val (lambda (_) #f))))
-             (if (and f64 (number? f64) (inexact? f64) (real? f64))
-                 (intmap-add! out var f64)
-                 out)))
-          (($ $primcall (or 'scm->u64 'scm->u64/truncate) #f (val))
-           (let ((u64 (intmap-ref out val (lambda (_) #f))))
-             (if (and u64 (number? u64) (exact-integer? u64)
-                      (<= 0 u64 #xffffFFFFffffFFFF))
-                 (intmap-add! out var u64)
-                 out)))
-          (($ $primcall 'scm->s64 #f (val))
-           (let ((s64 (intmap-ref out val (lambda (_) #f))))
-             (if (and s64 (number? s64) (exact-integer? s64)
-                      (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF))
-                 (intmap-add! out var s64)
-                 out)))
-          (_ out)))
-      defs
-      (intmap-fold (lambda (var exp out)
-                     (match exp
-                       (($ $const val)
-                        (intmap-add! out var val))
-                       (_ out)))
-                   defs
-                   empty-intmap)))))
-
 (define (compute-function-body conts kfun)
   (persistent-intset
    (let visit-cont ((label kfun) (labels empty-intset))