Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / language / tree-il / primitives.scm

diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index f192c4f..8aecb85 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -29,7 +29,7 @@
             expand-primitives!
             effect-free-primitive? effect+exception-free-primitive?
             constructor-primitive? accessor-primitive?
-            singly-valued-primitive?))
+            singly-valued-primitive? equality-primitive?))
 
 (define *interesting-primitive-names* 
   '(apply @apply
@@ -46,6 +46,7 @@
     ash logand logior logxor
     not
     pair? null? list? symbol? vector? string? struct?
+    nil?
     acons cons cons*
 
     list vector
@@ -141,6 +142,7 @@
     + * - / 1- 1+ quotient remainder modulo
     not
     pair? null? list? symbol? vector? struct? string?
+    nil?
     string-length vector-length
     ;; These all should get expanded out by expand-primitives!.
     caar cadr cdar cddr
@@ -168,6 +170,7 @@
     ash logand logior logxor
     not
     pair? null? list? symbol? vector? acons cons cons*
+    nil?
     list vector
     car cdr
     set-car! set-cdr!
@@ -206,9 +209,13 @@
     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
 
+(define *equality-primitives*
+  '(eq? eqv? equal?))
+
 (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))
+(define *equality-primitive-table* (make-hash-table))
 
 (for-each (lambda (x)
             (hashq-set! *effect-free-primitive-table* x #t))
@@ -219,6 +226,9 @@
 (for-each (lambda (x) 
             (hashq-set! *singly-valued-primitive-table* x #t))
           *singly-valued-primitives*)
+(for-each (lambda (x)
+            (hashq-set! *equality-primitive-table* x #t))
+          *equality-primitives*)
 
 (define (constructor-primitive? prim)
   (memq prim *primitive-constructors*))
@@ -230,6 +240,8 @@
   (hashq-ref *effect+exceptions-free-primitive-table* prim))
 (define (singly-valued-primitive? prim)
   (hashq-ref *singly-valued-primitive-table* prim))
+(define (equality-primitive? prim)
+  (hashq-ref *equality-primitive-table* prim))
 
 (define (resolve-primitives! x mod)
   (define local-definitions
@@ -255,11 +267,15 @@
        ((<module-ref> src mod name public?)
         ;; for the moment, we're disabling primitive resolution for
         ;; public refs because resolve-interface can raise errors.
-        (let ((m (and (not public?) (resolve-module mod))))
-          (and m 
-               (and=> (hashq-ref *interesting-primitive-vars*
-                                 (module-variable m name))
-                      (lambda (name) (make-primitive-ref src name))))))
+        (and=> (and=> (resolve-module mod)
+                      (if public?
+                          module-public-interface
+                          identity))
+               (lambda (m)
+                 (and=> (hashq-ref *interesting-primitive-vars*
+                                   (module-variable m name))
+                        (lambda (name)
+                          (make-primitive-ref src name))))))
        ((<call> src proc args)
         (and (primitive-ref? proc)
              (make-primcall src (primitive-ref-name proc) args)))
@@ -535,22 +551,21 @@
             'call-with-prompt
             (case-lambda
               ((src tag thunk handler)
-               ;; Sigh. Until the inliner does its job, manually inline
-               ;; (let ((h (lambda ...))) (prompt k x h))
-               (cond
-                ((lambda? handler)
-                 (let ((args-sym (gensym)))
-                   (make-prompt
-                    src tag (make-call #f thunk '())
-                    ;; If handler itself is a lambda, the inliner can do some
-                    ;; trickery here.
-                    (make-lambda-case
-                     (tree-il-src handler) '() #f 'args #f '() (list args-sym)
-                     (make-primcall #f 'apply
-                                    (list handler
-                                          (make-lexical-ref #f 'args args-sym)))
-                     #f))))
-                (else #f)))
+               (let ((handler-sym (gensym))
+                     (args-sym (gensym)))
+                 (make-let
+                  src '(handler) (list handler-sym) (list handler)
+                  (make-prompt
+                   src tag (make-call #f thunk '())
+                   ;; If handler itself is a lambda, the inliner can do some
+                   ;; trickery here.
+                   (make-lambda-case
+                    (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+                    (make-primcall
+                     #f 'apply
+                     (list (make-lexical-ref #f 'handler handler-sym)
+                           (make-lexical-ref #f 'args args-sym)))
+                    #f)))))
               (else #f)))
 
 (hashq-set! *primitive-expand-table*