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 20e0421..8aecb85 100644 (file)
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -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)))
@@ -483,31 +499,12 @@
 (define-primitive-expander f64vector-set! (vec i x)
   (bytevector-ieee-double-native-set! vec (* i 8) x))
 
-(hashq-set! *primitive-expand-table*
-            'dynamic-wind
-            (case-lambda
-              ((src pre thunk post)
-               (let ((PRE (gensym " pre"))
-                     (THUNK (gensym " thunk"))
-                     (POST (gensym " post")))
-                 (make-let
-                  src
-                  '(pre thunk post)
-                  (list PRE THUNK POST)
-                  (list pre thunk post)
-                  (make-dynwind
-                   src
-                   (make-lexical-ref #f 'pre PRE)
-                   (make-call #f (make-lexical-ref #f 'thunk THUNK) '())
-                   (make-lexical-ref #f 'post POST)))))
-              (else #f)))
-
 (hashq-set! *primitive-expand-table*
             '@dynamic-wind
             (case-lambda
               ((src pre expr post)
-               (let ((PRE (gensym " pre"))
-                     (POST (gensym " post")))
+               (let ((PRE (gensym "pre-"))
+                     (POST (gensym "post-")))
                  (make-let
                   src
                   '(pre post)
@@ -516,7 +513,9 @@
                   (make-dynwind
                    src
                    (make-lexical-ref #f 'pre PRE)
+                   (make-call #f (make-lexical-ref #f 'pre PRE) '())
                    expr
+                   (make-call #f (make-lexical-ref #f 'post POST) '())
                    (make-lexical-ref #f 'post POST)))))))
 
 (hashq-set! *primitive-expand-table*
@@ -552,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*