From e84cdfb6d4e77344cae031c3a79828062818a27b Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sat, 5 Apr 2014 21:06:35 +0200
Subject: [PATCH] Add effects for specialized primitives

* module/language/cps/effects-analysis.scm (make-vector)
  (make-vector/immediate, vector-ref/immediate, vector-set!/immediate)
  (struct-ref/immediate, struct-set!/immediate): Add effects.
---
 module/language/cps/effects-analysis.scm | 30 ++++++++++++++++++++++--
 1 file changed, 28 insertions(+), 2 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 1725d2852..a8e7cb2a8 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -294,8 +294,12 @@
 ;; Vectors.
 (define-primitive-effects
   ((vector . _) (cause &allocation))
+  ((make-vector n init) (logior (cause &type-check) (cause &allocation)))
+  ((make-vector/immediate n init) (cause &allocation))
   ((vector-ref v n) (logior (cause &type-check) &vector))
+  ((vector-ref/immediate v n) (logior (cause &type-check) &vector))
   ((vector-set! v n x) (logior (cause &type-check) (cause &vector)))
+  ((vector-set!/immediate v n x) (logior (cause &type-check) (cause &vector)))
   ((vector-length v) (cause &type-check)))
 
 ;; Variables.
@@ -323,6 +327,17 @@
              (4 &struct-4)
              (5 &struct-5)
              (_ &struct-6+))))
+  ((struct-ref/immediate s n)
+   (logior (cause &type-check)
+           (match (lookup-constant-index n dfg)
+             (#f &struct)
+             (0 &struct-0)
+             (1 &struct-1)
+             (2 &struct-2)
+             (3 &struct-3)
+             (4 &struct-4)
+             (5 &struct-5)
+             (_ &struct-6+))))
   ((struct-set! s n x)
    (logior (cause &type-check)
            (match (lookup-constant-index n dfg)
@@ -334,6 +349,17 @@
              (4 (cause &struct-4))
              (5 (cause &struct-5))
              (_ (cause &struct-6+)))))
+  ((struct-set!/immediate s n x)
+   (logior (cause &type-check)
+           (match (lookup-constant-index n dfg)
+             (#f (cause &struct))
+             (0 (cause &struct-0))
+             (1 (cause &struct-1))
+             (2 (cause &struct-2))
+             (3 (cause &struct-3))
+             (4 (cause &struct-4))
+             (5 (cause &struct-5))
+             (_ (cause &struct-6+)))))
   ((struct-vtable s) (cause &type-check)))
 
 ;; Strings.
@@ -461,8 +487,8 @@
               (($ $arity _ () _ () #f) (logior (cause &allocation)
                                                (cause &type-check)))))
            (($ $kif) &no-effects)
-           (($ $kentry) &type-check)
-           (($ $kclause) &type-check)
+           (($ $kentry) (cause &type-check))
+           (($ $kclause) (cause &type-check))
            (($ $ktail) &no-effects)))
         (lp (1+ n))))
     effects))
-- 
2.20.1