guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-100-g40bd6


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.2-100-g40bd6a7
Date: Wed, 21 Sep 2011 07:00:53 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=40bd6a7e57a779d249f901f710d7368bf26550bb

The branch, stable-2.0 has been updated
       via  40bd6a7e57a779d249f901f710d7368bf26550bb (commit)
       via  9581febbb004b24843630adcefb72810624d0300 (commit)
       via  2605b6ba2749a90c55a7f49bb91d6f20f256a20e (commit)
       via  ddbee5c00f438c4dc1dbe2b944b559a3c2de0e6b (commit)
       via  5d5e4f399a38e530a5f0081d6fdec80d3eb4736a (commit)
       via  4f33b47591e823500d800ee4f9d98c8ae98ceab8 (commit)
       via  65a32655253cdfcf4e2caf03a73ac66b05da5f71 (commit)
       via  03026d0fb888c4d19b87a995c641cb3e93afd973 (commit)
       via  d111abd0f6d06308b172cc1fa964eb11ccf5d94a (commit)
       via  0c448ef47b752683855753ece53bef52733aee0b (commit)
       via  78295f242adc2e308eba69839a8812da6cc1e02e (commit)
      from  ccb771575a9fc03eab034bef4c77917486bbf8c7 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 40bd6a7e57a779d249f901f710d7368bf26550bb
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:50:45 2011 +0200

    peval comment & reindentation
    
    * module/language/tree-il/optimize.scm (peval): Add a comment regarding
      failure modes, and reindent one clause.

commit 9581febbb004b24843630adcefb72810624d0300
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:49:36 2011 +0200

    fix comment regarding alpha-renaming
    
    * module/language/tree-il/optimize.scm (peval): Fix comment regarding
      alpha-renaming: it's not simply the allocator that needs unique names;
      rather, all transformations depend on it.

commit 2605b6ba2749a90c55a7f49bb91d6f20f256a20e
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:46:44 2011 +0200

    better pure-expression?
    
    * module/language/tree-il/optimize.scm (peval): Allow dynref, fix, and
      let-values to be pure expressions.

commit ddbee5c00f438c4dc1dbe2b944b559a3c2de0e6b
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:46:03 2011 +0200

    more alpha-rename robustness
    
    * module/language/tree-il/optimize.scm (alpha-rename): Handle all kinds
      of tree-il, with the current exceptions of lexical set!, prompt, and
      abort.

commit 5d5e4f399a38e530a5f0081d6fdec80d3eb4736a
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:44:19 2011 +0200

    more robust alpha-renaming
    
    * module/language/tree-il/optimize.scm (fresh-gensyms): New helper.
      (alpha-rename): Name the new gensyms using the old names as templates,
      not the old gensyms.  This prevents accidental collisions between
      gensyms, if #{x 1}# becomes #{x 12}# instead of #{x 2}#.

commit 4f33b47591e823500d800ee4f9d98c8ae98ceab8
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:58:09 2011 +0200

    peval: inlining of let-values
    
    * module/language/tree-il/optimize.scm (peval): Add support for
      let-values.  Try to inline the consumer into the body of the producer,
      if there is only one return point, and we can figure out how many
      values are being returned, and that number is compatible with the
      consumer.

commit 65a32655253cdfcf4e2caf03a73ac66b05da5f71
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:56:09 2011 +0200

    peval support for more forms
    
    * module/language/tree-il/optimize.scm (peval): Add support for fix,
      dynwind, dynlet, dynref, module-set, and toplevel-set.  (Mutating a
      variable directly is similar to calling a function that does so behind
      our backs, so this presents no additional problem.)

commit 03026d0fb888c4d19b87a995c641cb3e93afd973
Author: Andy Wingo <address@hidden>
Date:   Wed Sep 21 08:53:06 2011 +0200

    add singly-valued-primitive?
    
    * module/language/tree-il/primitives.scm (singly-valued-primitive?): New
      predicate, for primitives that return exactly one value.

commit d111abd0f6d06308b172cc1fa964eb11ccf5d94a
Author: Andy Wingo <address@hidden>
Date:   Mon Sep 19 20:59:53 2011 -0400

    more optimize.scm factoring
    
    * module/language/tree-il/optimize.scm (vlist-any): New helper.
      (peval): Use it here.

commit 0c448ef47b752683855753ece53bef52733aee0b
Author: Andy Wingo <address@hidden>
Date:   Mon Sep 19 20:49:50 2011 -0400

    optimize.scm refactor
    
    * module/language/tree-il/optimize.scm (let/ec, tree-il-any): New
      helpers.
      (code-contains-calls?): Use them here.

commit 78295f242adc2e308eba69839a8812da6cc1e02e
Author: Daniel Llorens <address@hidden>
Date:   Mon Sep 5 11:09:08 2011 +0200

    Fix compilation of untyped arrays of rank not 1
    
    * module/language/glil/compile-assembly.scm: vector-fold2 expects vector.

-----------------------------------------------------------------------

Summary of changes:
 module/language/glil/compile-assembly.scm |    2 +-
 module/language/tree-il/optimize.scm      |  256 ++++++++++++++++++++++++----
 module/language/tree-il/primitives.scm    |   54 ++++++-
 3 files changed, 273 insertions(+), 39 deletions(-)

diff --git a/module/language/glil/compile-assembly.scm 
b/module/language/glil/compile-assembly.scm
index a081822..c76e412 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -856,7 +856,7 @@
             (vector-fold2 (lambda (x codes addr)
                             (receive (subcode addr) (ref-or-dump x i addr)
                               (values (cons subcode codes) addr)))
-                          x '() addr)
+                          contents '() addr)
           (receive (shape addr) (ref-or-dump (array-shape x) i addr)
             (values (fold append
                           (let ((len (vector-length contents)))
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 19ef54d..2503e14 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -46,6 +46,10 @@
 ;;; Partial evaluation.
 ;;;
 
+(define (fresh-gensyms syms)
+  (map (lambda (x) (gensym (string-append (symbol->string x) " ")))
+       syms))
+
 (define (alpha-rename exp)
   "Alpha-rename EXP.  For any lambda in EXP, generate new symbols and
 replace all lexical references to the former symbols with lexical
@@ -57,7 +61,11 @@ references to the new symbols."
       (($ <lambda-case> src req opt rest kw inits gensyms body alt)
        ;; Create new symbols to replace GENSYMS and propagate them down
        ;; in BODY and ALT.
-       (let* ((new     (map (compose gensym symbol->string) gensyms))
+       (let* ((new     (fresh-gensyms
+                        (append req
+                                (or opt '())
+                                (if rest (list rest) '())
+                                (if kw (map cadr (cdr kw)) '()))))
               (mapping (fold vhash-consq mapping gensyms new)))
          (make-lambda-case src req opt rest kw inits new
                            (loop body mapping)
@@ -72,18 +80,27 @@ references to the new symbols."
        (make-lambda src meta (loop body mapping)))
       (($ <let> src names gensyms vals body)
        ;; As for `lambda-case' rename GENSYMS to avoid any collision.
-       (let* ((new     (map (compose gensym symbol->string) gensyms))
+       (let* ((new     (fresh-gensyms names))
               (mapping (fold vhash-consq mapping gensyms new))
               (vals    (map (cut loop <> mapping) vals))
               (body    (loop body mapping)))
          (make-let src names new vals body)))
       (($ <letrec> src in-order? names gensyms vals body)
        ;; Likewise.
-       (let* ((new     (map (compose gensym symbol->string) gensyms))
+       (let* ((new     (fresh-gensyms names))
               (mapping (fold vhash-consq mapping gensyms new))
               (vals    (map (cut loop <> mapping) vals))
               (body    (loop body mapping)))
          (make-letrec src in-order? names new vals body)))
+      (($ <fix> src names gensyms vals body)
+       ;; Likewise.
+       (let* ((new     (fresh-gensyms names))
+              (mapping (fold vhash-consq mapping gensyms new))
+              (vals    (map (cut loop <> mapping) vals))
+              (body    (loop body mapping)))
+         (make-fix src names new vals body)))
+      (($ <let-values> src exp body)
+       (make-let-values src (loop exp mapping) (loop body mapping)))
       (($ <const>)
        exp)
       (($ <void>)
@@ -94,6 +111,24 @@ references to the new symbols."
        exp)
       (($ <primitive-ref>)
        exp)
+      (($ <toplevel-set> src name exp)
+       (make-toplevel-set src name (loop exp mapping)))
+      (($ <toplevel-define> src name exp)
+       (make-toplevel-define src name (loop exp mapping)))
+      (($ <module-set> src mod name public? exp)
+       (make-module-set src mod name public? (loop exp mapping)))
+      (($ <dynlet> src fluids vals body)
+       (make-dynlet src
+                    (map (cut loop <> mapping) fluids)
+                    (map (cut loop <> mapping) vals)
+                    (loop body mapping)))
+      (($ <dynwind> src winder body unwinder)
+       (make-dynwind src
+                     (loop winder mapping)
+                     (loop body mapping)
+                     (loop unwinder mapping)))
+      (($ <dynref> src fluid)
+       (make-dynref src (loop fluid mapping)))
       (($ <conditional> src condition subsequent alternate)
        (make-conditional src
                          (loop condition mapping)
@@ -105,33 +140,46 @@ references to the new symbols."
       (($ <sequence> src exps)
        (make-sequence src (map (cut loop <> mapping) exps))))))
 
+(define-syntax-rule (let/ec k e e* ...)
+  (let ((tag (make-prompt-tag)))
+    (call-with-prompt
+     tag
+     (lambda ()
+       (let ((k (lambda args (apply abort-to-prompt tag args))))
+         e e* ...))
+     (lambda (_ res) res))))
+
+(define (tree-il-any proc exp)
+  (let/ec k
+    (tree-il-fold (lambda (exp res) #f)
+                  (lambda (exp res)
+                    (let ((res (proc exp)))
+                      (if res (k res) #f)))
+                  (lambda (exp res) #f)
+                  #f exp)))
+
 (define (code-contains-calls? body proc lookup)
   "Return true if BODY contains calls to PROC.  Use LOOKUP to look up
 lexical references."
-  (define exit
-    ;; The exit label.
-    (gensym))
+  (tree-il-any
+   (lambda (exp)
+     (match exp
+       (($ <application> _
+           (and ref ($ <lexical-ref> _ _ gensym)) _)
+        (or (equal? ref proc)
+            (equal? (lookup gensym) proc)))
+       (($ <application>
+           (and proc* ($ <lambda>)))
+        (equal? proc* proc))
+       (_ #f)))
+   body))
 
-  (catch exit
-    (lambda ()
-      (tree-il-fold (lambda (exp result) result)
-                    (lambda (exp result)
-                      (match exp
-                        (($ <application> _
-                            (and ref ($ <lexical-ref> _ _ gensym)) _)
-                         (and (or (equal? ref proc)
-                                  (equal? (lookup gensym) proc))
-                              (throw exit #t)))
-                        (($ <application>
-                            (and proc* ($ <lambda>)))
-                         (and (equal? proc* proc)
-                              (throw exit #t)))
-                        (_ #f)))
-                    (lambda (exp result) result)
-                    #f
-                    body))
-    (lambda (_ result)
-      result)))
+(define (vlist-any proc vlist)
+  (let ((len (vlist-length vlist)))
+    (let lp ((i 0))
+      (and (< i len)
+           (or (proc (vlist-ref vlist i))
+               (lp (1+ i)))))))
 
 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
   "Partially evaluate EXP in compilation environment CENV, with
@@ -179,6 +227,74 @@ it does not handle <fix> and <let-values>, it should be 
called before
       (lambda _
         (values #f '()))))
 
+  (define (inline-values exp src names gensyms body)
+    (let loop ((exp exp))
+      (match exp
+        ;; Some expression types are always singly-valued.
+        ((or ($ <const>)
+             ($ <void>)
+             ($ <lambda>)
+             ($ <lexical-ref>)
+             ($ <toplevel-ref>)
+             ($ <module-ref>)
+             ($ <primitive-ref>)
+             ($ <dynref>)
+             ($ <toplevel-set>)         ; FIXME: these set! expressions
+             ($ <toplevel-define>)      ; could return zero values in
+             ($ <module-set>))          ; the future
+         (and (= (length names) 1)
+              (make-let src names gensyms (list exp) body)))
+        (($ <application> src
+                ($ <primitive-ref> _ (? singly-valued-primitive? name)))
+         (and (= (length names) 1)
+              (make-let src names gensyms (list exp) body)))
+
+        ;; Statically-known number of values.
+        (($ <application> src ($ <primitive-ref> _ 'values) vals)
+         (and (= (length names) (length vals))
+              (make-let src names gensyms vals body)))
+
+        ;; Not going to copy code into both branches.
+        (($ <conditional>) #f)
+
+        ;; Bail on other applications.
+        (($ <application>) #f)
+
+        ;; Propagate to tail positions.
+        (($ <let> src names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-let src names gensyms vals body))))
+        (($ <letrec> src in-order? names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-letrec src in-order? names gensyms vals body))))
+        (($ <fix> src names gensyms vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-fix src names gensyms vals body))))
+        (($ <let-values> src exp
+            ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
+         (let ((body (loop body)))
+           (and body
+                (make-let-values src exp
+                                 (make-lambda-case src2 req opt rest kw
+                                                   inits gensyms body #f)))))
+        (($ <dynwind> src winder body unwinder)
+         (let ((body (loop body)))
+           (and body
+                (make-dynwind src winder body unwinder))))
+        (($ <dynlet> src fluids vals body)
+         (let ((body (loop body)))
+           (and body
+                (make-dynlet src fluids vals body))))
+        (($ <sequence> src exps)
+         (match exps
+           ((head ... tail)
+            (let ((tail (loop tail)))
+              (and tail
+                   (make-sequence src (append head (list tail)))))))))))
+
   (define (make-values src values)
     (match values
       ((single) single)                           ; 1 value
@@ -204,6 +320,7 @@ it does not handle <fix> and <let-values>, it should be 
called before
         (($ <lexical-ref>) #t)
         (($ <toplevel-ref>) #t)
         (($ <primitive-ref>) #t)
+        (($ <dynref> _ fluid) (loop fluid))
         (($ <conditional> _ condition subsequent alternate)
          (and (loop condition) (loop subsequent) (loop alternate)))
         (($ <application> _ ($ <primitive-ref> _ name) args)
@@ -218,6 +335,10 @@ it does not handle <fix> and <let-values>, it should be 
called before
          (and (every loop vals) (loop body)))
         (($ <letrec> _ _ _ _ vals body)
          (and (every loop vals) (loop body)))
+        (($ <fix> _ _ _ vals body)
+         (and (every loop vals) (loop body)))
+        (($ <let-values> _ exp body)
+         (and (loop exp) (loop body)))
         (_ #f))))
 
   (define (mutable? exp)
@@ -276,17 +397,16 @@ it does not handle <fix> and <let-values>, it should be 
called before
           ($ <lambda-case> _ req opt rest kw inits gensyms body))
        ;; Look for NEW in the current environment, starting from the
        ;; outermost frame.
-       (or (any (lambda (x)
-                  (and (equal? (cdr x) new)
-                       (make-lexical-ref src name (car x))))
-                (vlist-fold cons '() env))        ; todo: optimize
+       (or (vlist-any (lambda (x)
+                        (and (equal? (cdr x) new)
+                             (make-lexical-ref src name (car x))))
+                      env)
            new))
       (($ <lambda> src ()
           (and lc ($ <lambda-case>)))
-       ;; This is an anonymous lambda that we're going to inline.  The
-       ;; variable allocation process assumes globally unique gensyms, so
-       ;; alpha-rename the lambda to avoid any collision with other
-       ;; copies of it.
+       ;; This is an anonymous lambda that we're going to inline.
+       ;; Inlining creates new variable bindings, so we need to provide
+       ;; the new code with fresh names.
        (make-lambda src '() (alpha-rename lc)))
       (_ new)))
 
@@ -307,6 +427,7 @@ it does not handle <fix> and <let-values>, it should be 
called before
            ;; Propagate only pure expressions.
            (let ((val (lookup gensym)))
              (or (and (pure-expression? val) val) exp)))
+          ;; Lexical set! causes a bailout.
           (($ <let> src names gensyms vals body)
            (let* ((vals* (map (cut loop <> env calls) vals))
                   (vals  (map maybe-unconst vals vals*))
@@ -329,12 +450,49 @@ it does not handle <fix> and <let-values>, it should be 
called before
            (let* ((vals* (map (cut loop <> env calls) vals))
                   (vals  (map maybe-unconst vals vals*))
                   (body* (loop body
-                              (fold vhash-consq env gensyms vals)
-                              calls))
+                               (fold vhash-consq env gensyms vals)
+                               calls))
                   (body  (maybe-unconst body body*)))
              (if (const? body*)
                  body
                  (make-letrec src in-order? names gensyms vals body))))
+          (($ <fix> src names gensyms vals body)
+           (let* ((vals (map (cut loop <> env calls) vals))
+                  (body* (loop body
+                           (fold vhash-consq env gensyms vals)
+                           calls))
+                  (body  (maybe-unconst body body*)))
+             (if (const? body*)
+                 body
+                 (make-fix src names gensyms vals body))))
+          (($ <let-values> src producer
+              ($ <lambda-case> src2 req #f #f #f () gensyms body #f))
+           ;; Peval both producer and consumer, then try to inline.  If
+           ;; that succeeds, peval again.
+           (let* ((producer (maybe-unconst producer (loop producer env calls)))
+                  (body (maybe-unconst body (loop body env calls))))
+             (cond
+              ((inline-values producer src2 req gensyms body)
+               => (lambda (exp) (loop exp env calls)))
+              (else
+               (make-let-values
+                src producer
+                (make-lambda-case src2 req #f #f #f '() gensyms body #f))))))
+          (($ <let-values>)
+           exp)
+          (($ <dynwind> src winder body unwinder)
+           (make-dynwind src (loop winder env calls)
+                         (loop body env calls)
+                         (loop unwinder env calls)))
+          (($ <dynlet> src fluids vals body)
+           (make-dynlet src
+                        (map maybe-unconst fluids
+                             (map (cut loop <> env calls) fluids))
+                        (map maybe-unconst vals
+                             (map (cut loop <> env calls) vals))
+                        (maybe-unconst body (loop body env calls))))
+          (($ <dynref> src fluid)
+           (make-dynref src (maybe-unconst fluid (loop fluid env calls))))
           (($ <toplevel-ref> src (? effect-free-primitive? name))
            (if (local-toplevel? name)
                exp
@@ -344,9 +502,15 @@ it does not handle <fix> and <let-values>, it should be 
called before
            exp)
           (($ <module-ref>)
            exp)
+          (($ <module-set> src mod name public? exp)
+           (make-module-set src mod name public?
+                            (maybe-unconst exp (loop exp env '()))))
           (($ <toplevel-define> src name exp)
            (make-toplevel-define src name
                                  (maybe-unconst exp (loop exp env '()))))
+          (($ <toplevel-set> src name exp)
+           (make-toplevel-set src name
+                              (maybe-unconst exp (loop exp env '()))))
           (($ <primitive-ref>)
            exp)
           (($ <conditional> src condition subsequent alternate)
@@ -359,6 +523,18 @@ it does not handle <fix> and <let-values>, it should be 
called before
                  (make-conditional src condition
                                    (loop subsequent env calls)
                                    (loop alternate env calls)))))
+          (($ <application> src
+                ($ <primitive-ref> _ '@call-with-values)
+                (producer
+                 ($ <lambda> _ _
+                    (and consumer
+                         ;; No optional or kwargs.
+                         ($ <lambda-case>
+                            _ req #f rest #f () gensyms body #f)))))
+           (loop (make-let-values src (make-application src producer '())
+                                  consumer)
+                 env calls))
+
           (($ <application> src orig-proc orig-args)
            ;; todo: augment the global env with specialized functions
            (let* ((proc  (loop orig-proc env calls))
@@ -416,7 +592,13 @@ it does not handle <fix> and <let-values>, it should be 
called before
                    (($ <lambda>)
                     app)
                    (($ <toplevel-ref>)
-                    app))
+                    app)
+                   
+                   ;; In practice, this is the clause that stops peval:
+                   ;; module-ref applications (produced by macros,
+                   ;; typically) don't match, and so this throws,
+                   ;; aborting peval for an entire expression.
+                   )
 
                  app)))
           (($ <lambda> src meta body)
diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 2627279..76fb669 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -28,7 +28,7 @@
   #:export (resolve-primitives! add-interesting-primitive!
             expand-primitives!
             effect-free-primitive? effect+exception-free-primitive?
-            constructor-primitive?))
+            constructor-primitive? singly-valued-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -146,8 +146,55 @@
     list vector
     struct?))
 
+;; Primitives that only return one value.
+(define *singly-valued-primitives* 
+  '(eq? eqv? equal?
+    memq memv
+    = < > <= >= zero?
+    + * - / 1- 1+ quotient remainder modulo
+    ash logand logior logxor
+    not
+    pair? null? list? symbol? vector? acons cons cons*
+    list vector
+    car cdr
+    set-car! set-cdr!
+    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
+    vector-ref vector-set!
+    variable-ref variable-set!
+    variable-bound?
+    fluid-ref fluid-set!
+    make-prompt-tag
+    struct? struct-vtable make-struct struct-ref struct-set!
+    bytevector-u8-ref bytevector-u8-set!
+    bytevector-s8-ref bytevector-s8-set!
+    u8vector-ref u8vector-set! s8vector-ref s8vector-set!
+    bytevector-u16-ref bytevector-u16-set!
+    bytevector-u16-native-ref bytevector-u16-native-set!
+    bytevector-s16-ref bytevector-s16-set!
+    bytevector-s16-native-ref bytevector-s16-native-set!
+    u16vector-ref u16vector-set! s16vector-ref s16vector-set!
+    bytevector-u32-ref bytevector-u32-set!
+    bytevector-u32-native-ref bytevector-u32-native-set!
+    bytevector-s32-ref bytevector-s32-set!
+    bytevector-s32-native-ref bytevector-s32-native-set!
+    u32vector-ref u32vector-set! s32vector-ref s32vector-set!
+    bytevector-u64-ref bytevector-u64-set!
+    bytevector-u64-native-ref bytevector-u64-native-set!
+    bytevector-s64-ref bytevector-s64-set!
+    bytevector-s64-native-ref bytevector-s64-native-set!
+    u64vector-ref u64vector-set! s64vector-ref s64vector-set!
+    bytevector-ieee-single-ref bytevector-ieee-single-set!
+    bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
+    bytevector-ieee-double-ref bytevector-ieee-double-set!
+    bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+    f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+
 (define *effect-free-primitive-table* (make-hash-table))
 (define *effect+exceptions-free-primitive-table* (make-hash-table))
+(define *singly-valued-primitive-table* (make-hash-table))
 
 (for-each (lambda (x)
             (hashq-set! *effect-free-primitive-table* x #t))
@@ -155,6 +202,9 @@
 (for-each (lambda (x) 
             (hashq-set! *effect+exceptions-free-primitive-table* x #t))
           *effect+exception-free-primitives*)
+(for-each (lambda (x) 
+            (hashq-set! *singly-valued-primitive-table* x #t))
+          *singly-valued-primitives*)
 
 (define (constructor-primitive? prim)
   (memq prim *primitive-constructors*))
@@ -162,6 +212,8 @@
   (hashq-ref *effect-free-primitive-table* prim))
 (define (effect+exception-free-primitive? prim)
   (hashq-ref *effect+exceptions-free-primitive-table* prim))
+(define (singly-valued-primitive? prim)
+  (hashq-ref *singly-valued-primitive-table* prim))
 
 (define (resolve-primitives! x mod)
   (post-order!


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]