[Guile-commits] 02/41: Don't compile equal? to br-if-equal

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 3e5d4131d2b8eecf72568bc94d626a7cdced7f5b
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 12 21:16:33 2015 +0100

    Don't compile equal? to br-if-equal
    
    * module/language/cps/compile-bytecode.scm (compile-function):
    * module/language/cps/primitives.scm (*branching-primcall-arities*):
    * module/language/cps/type-fold.scm (equal?):
    * module/language/cps/types.scm (equal?):
    * module/language/tree-il/compile-cps.scm (convert): `equal?' is no
      longer a branching primcall, because it isn't inline.  The
      implementation could lead to bad backtraces also, as it didn't save
      the IP, and actually could lead to segfaults as it didn't reload the
      SP after the return.  There is an eqv? fast-path, though.
    * module/system/vm/assembler.scm (br-if-equal): Remove interface.
    * module/system/vm/disassembler.scm (code-annotation):
      (compute-labels): No need to handle br-if-equal.
---
 module/language/cps/compile-bytecode.scm |    1 -
 module/language/cps/primitives.scm       |    1 -
 module/language/cps/type-fold.scm        |    1 -
 module/language/cps/types.scm            |    2 +-
 module/language/tree-il/compile-cps.scm  |   12 ++++++++++++
 module/system/vm/assembler.scm           |    1 -
 module/system/vm/disassembler.scm        |    4 ++--
 7 files changed, 15 insertions(+), 7 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 49b684c..1c7b99b 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -366,7 +366,6 @@
         ;; the set of macro-instructions in assembly.scm.
         (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
         (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
-        (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
         (($ $primcall '< (a b)) (binary emit-br-if-< a b))
         (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
         (($ $primcall '= (a b)) (binary emit-br-if-= a b))
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index 5f7f474..5074fb9 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -82,7 +82,6 @@
     (char? . (1 . 1))
     (eq? . (1 . 2))
     (eqv? . (1 . 2))
-    (equal? . (1 . 2))
     (= . (1 . 2))
     (< . (1 . 2))
     (> . (1 . 2))
diff --git a/module/language/cps/type-fold.scm 
b/module/language/cps/type-fold.scm
index e7a343b..c370306 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -91,7 +91,6 @@
    (else
     (values #f #f))))
 (define-branch-folder-alias eqv? eq?)
-(define-branch-folder-alias equal? eq?)
 
 (define (compare-ranges type0 min0 max0 type1 min1 max1)
   (and (zero? (logand (logior type0 type1) (lognot &real)))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index dac29f7..08e8ec8 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -483,7 +483,7 @@ minimum, and maximum."
           (max (min (&max a) (&max b))))
       (restrict! a type min max)
       (restrict! b type min max))))
-(define-type-inferrer-aliases eq? eqv? equal?)
+(define-type-inferrer-aliases eq? eqv?)
 
 (define-syntax-rule (define-simple-predicate-inferrer predicate type)
   (define-predicate-inferrer (predicate val true?)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 393b0a8..2ef751b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -506,6 +506,18 @@
 
     (($ <primcall> src name args)
      (cond
+      ((eq? name 'equal?)
+       (convert-args cps args
+         (lambda (cps args)
+           (with-cps cps
+             (let$ k* (adapt-arity k src 1))
+             (letk kt ($kargs () () ($continue k* src ($const #t))))
+             (letk kf* ($kargs () ()
+                         ;; Here we continue to the original $kreceive
+                         ;; or $ktail, as equal? doesn't have a VM op.
+                         ($continue k src ($primcall 'equal? args))))
+             (build-term ($continue kf* src
+                           ($branch kt ($primcall 'eqv? args))))))))
       ((branching-primitive? name)
        (convert-args cps args
          (lambda (cps args)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 296b86c..babe479 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -91,7 +91,6 @@
             emit-br-if-tc7
             emit-br-if-eq
             emit-br-if-eqv
-            emit-br-if-equal
             emit-br-if-=
             emit-br-if-<
             emit-br-if-<=
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index f718a4c..d90c885 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -193,7 +193,7 @@ address of that offset."
     (((or 'br
           'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
           'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
-          'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal
+          'br-if-char 'br-if-eq 'br-if-eqv
           'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
           'br-if-logtest) _ ... target)
      (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
@@ -295,7 +295,7 @@ address of that offset."
                  ((br
                    br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
                    br-if-true br-if-null br-if-nil br-if-pair br-if-struct
-                   br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal
+                   br-if-char br-if-tc7 br-if-eq br-if-eqv
                    br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
                   (match arg
                     ((_ ... target)