add accessor-primitive?, peval uses it

* module/language/tree-il/primitives.scm (*primitive-accessors*): New
  set of primitives: those that access mutable memory, but are otherwise
  pure.  Include bytevector references here.
  (accessor-primitive?): New public predicate.

* module/language/tree-il/peval.scm (peval): Refactor to distinguish
  constructor-primitive? from accessor-primitive?.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 9488b24..2ef77ae 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -521,6 +521,7 @@ top-level bindings from ENV and return the resulting expression."
         (($ <application> _ ($ <primitive-ref> _ name) args)
          (and (effect-free-primitive? name)
               (not (constructor-primitive? name))
+              (not (accessor-primitive? name))
               (types-check? name args)
               (every loop args)))
         (($ <application> _ ($ <lambda> _ _ body) args)
@@ -927,31 +928,32 @@ top-level bindings from ENV and return the resulting expression."
                    (($ <application> src ($ <primitive-ref> _ 'list) elts)
                     (make-application src (make-primitive-ref #f 'list)
                                       (cons head elts)))
-                   (_ (make-application src proc
-                                        (list head tail)))))
-
-                ;; FIXME: these for-tail recursions could take
-                ;; place outside an effort counter.
-                (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
-                 (for-tail (make-sequence src (list tail head))))
-                (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
-                 (for-tail (make-sequence src (list head tail))))
-                (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
-                 (for-tail (make-sequence src (append tail (list head)))))
-                (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
-                 (for-tail (make-sequence
-                            src
-                            (list head
-                                  (make-application
-                                   src (make-primitive-ref #f 'list) tail)))))
-                  
-                (('car ($ <const> src (head . tail)))
-                 (for-tail (make-const src head)))
-                (('cdr ($ <const> src (head . tail)))
-                 (for-tail (make-const src tail)))
-
+                   (_ (make-application src proc (list head tail)))))
                 ((_ . args)
                  (make-application src proc args))))))
+           (($ <primitive-ref> _ (? accessor-primitive? name))
+            (match (cons name (map for-value orig-args))
+              ;; FIXME: these for-tail recursions could take place outside
+              ;; an effort counter.
+              (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
+               (for-tail (make-sequence src (list tail head))))
+              (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
+               (for-tail (make-sequence src (list head tail))))
+              (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
+               (for-tail (make-sequence src (append tail (list head)))))
+              (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
+               (for-tail (make-sequence
+                          src
+                          (list head
+                                (make-application
+                                 src (make-primitive-ref #f 'list) tail)))))
+                  
+              (('car ($ <const> src (head . tail)))
+               (for-tail (make-const src head)))
+              (('cdr ($ <const> src (head . tail)))
+               (for-tail (make-const src tail)))
+              ((_ . args)
+               (make-application src proc args))))
            (($ <primitive-ref> _ (? effect-free-primitive? name))
             (let ((args (map for-value orig-args)))
               (if (every const? args)   ; only simple constants

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index c850cba..65b93b5 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -28,7 +28,8 @@
   #:export (resolve-primitives! add-interesting-primitive!
             expand-primitives!
             effect-free-primitive? effect+exception-free-primitive?
-            constructor-primitive? singly-valued-primitive?))
+            constructor-primitive? accessor-primitive?
+            singly-valued-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -110,7 +111,24 @@
 (define *primitive-constructors*
   ;; Primitives that return a fresh object.
   '(acons cons cons* list vector make-struct make-struct/no-tail
-          car cdr vector-ref struct-ref make-prompt-tag))
+    make-prompt-tag))
+
+(define *primitive-accessors*
+  ;; Primitives that are pure, but whose result depends on the mutable
+  ;; memory pointed to by their operands.
+  '(vector-ref
+    car cdr
+    memq memv
+    struct-vtable struct-ref
+    bytevector-u8-ref bytevector-s8-ref
+    bytevector-u16-ref bytevector-u16-native-ref
+    bytevector-s16-ref bytevector-s16-native-ref
+    bytevector-u32-ref bytevector-u32-native-ref
+    bytevector-s32-ref bytevector-s32-native-ref
+    bytevector-u64-ref bytevector-u64-native-ref
+    bytevector-s64-ref bytevector-s64-native-ref
+    bytevector-ieee-single-ref bytevector-ieee-single-native-ref
+    bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
 
 (define *effect-free-primitives*
   `(values
@@ -118,22 +136,14 @@
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo
     not
-    pair? null? list? symbol? vector?
+    pair? null? list? symbol? vector? struct?
+    ;; These all should get expanded out by expand-primitives!.
     caar cadr cdar cddr
     caaar caadr cadar caddr cdaar cdadr cddar cdddr
     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
-    struct? struct-vtable
-    bytevector-u8-ref bytevector-s8-ref
-    bytevector-u16-ref bytevector-u16-native-ref
-    bytevector-s16-ref bytevector-s16-native-ref
-    bytevector-u32-ref bytevector-u32-native-ref
-    bytevector-s32-ref bytevector-s32-native-ref
-    bytevector-u64-ref bytevector-u64-native-ref
-    bytevector-s64-ref bytevector-s64-native-ref
-    bytevector-ieee-single-ref bytevector-ieee-single-native-ref
-    bytevector-ieee-double-ref bytevector-ieee-double-native-ref
-    ,@*primitive-constructors*))
+    ,@*primitive-constructors*
+    ,@*primitive-accessors*))
 
 ;; Like *effect-free-primitives* above, but further restricted in that they
 ;; cannot raise exceptions.
@@ -141,9 +151,8 @@
   '(values
     eq? eqv? equal?
     not
-    pair? null? list? symbol? vector? acons cons cons*
-    list vector
-    struct?))
+    pair? null? list? symbol? vector? struct?
+    acons cons cons* list vector))
 
 ;; Primitives that only return one value.
 (define *singly-valued-primitives* 
@@ -207,6 +216,8 @@
 
 (define (constructor-primitive? prim)
   (memq prim *primitive-constructors*))
+(define (accessor-primitive? prim)
+  (memq prim *primitive-accessors*))
 (define (effect-free-primitive? prim)
   (hashq-ref *effect-free-primitive-table* prim))
 (define (effect+exception-free-primitive? prim)