[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/11: Lower eqv? and equal? to new instructions.
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 05/11: Lower eqv? and equal? to new instructions. |
|
Date: |
Sun, 29 Oct 2017 16:05:01 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 73d150263041628ccb02cc327f806fa39c3a380f
Author: Andy Wingo <address@hidden>
Date: Sun Oct 29 15:44:25 2017 +0100
Lower eqv? and equal? to new instructions.
* libguile/numbers.h:
* libguile/eq.c (scm_i_heap_numbers_equal_p): New helper, factored out
of scm_eqv_p.
(scm_eqv_p): Use new helper.
* libguile/vm-engine.c (heap-numbers-equal?): New op.
* module/language/cps/compile-bytecode.scm (compile-function): Add
support for heap-number? and heap-numbers-equal?. Remove case for
eqv?.
* module/language/cps/effects-analysis.scm: Add heap-numbers-equal?.
* module/language/cps/primitives.scm (*comparisons*): Add
heap-numbers-equal?.
* module/language/cps/type-fold.scm (heap-numbers-equal?): Update.
* module/language/cps/types.scm (heap-numbers-equal?): Update.
* module/language/tree-il/compile-cps.scm (canonicalize): Completely
inline eqv?, and partially inline equal?.
* module/system/vm/assembler.scm (system): Export emit-heap-numbers-equal?.
---
libguile/eq.c | 33 +++++++++++-------
libguile/numbers.h | 3 +-
libguile/vm-engine.c | 19 ++++++++++-
module/language/cps/compile-bytecode.scm | 4 ++-
module/language/cps/effects-analysis.scm | 1 +
module/language/cps/primitives.scm | 2 +-
module/language/cps/type-fold.scm | 2 +-
module/language/cps/types.scm | 2 +-
module/language/tree-il/compile-cps.scm | 57 +++++++++++++++++++++++++-------
module/system/vm/assembler.scm | 1 +
10 files changed, 94 insertions(+), 30 deletions(-)
diff --git a/libguile/eq.c b/libguile/eq.c
index 4680de7..daee4c0 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010,
2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995-1998,2000-2001,2003-2004,2006,2009-2011,2017 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 License
@@ -156,6 +156,25 @@ scm_i_fraction_equalp (SCM x, SCM y)
SCM_FRACTION_DENOMINATOR (y))));
}
+SCM
+scm_i_heap_numbers_equal_p (SCM x, SCM y)
+{
+ if (SCM_IMP (x)) abort();
+ switch (SCM_TYP16 (x))
+ {
+ case scm_tc16_big:
+ return scm_bigequal (x, y);
+ case scm_tc16_real:
+ return scm_real_equalp (x, y);
+ case scm_tc16_complex:
+ return scm_complex_equalp (x, y);
+ case scm_tc16_fraction:
+ return scm_i_fraction_equalp (x, y);
+ default:
+ abort ();
+ }
+}
+
static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
#include <stdio.h>
SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
@@ -210,17 +229,7 @@ SCM scm_eqv_p (SCM x, SCM y)
default:
break;
case scm_tc7_number:
- switch SCM_TYP16 (x)
- {
- case scm_tc16_big:
- return scm_bigequal (x, y);
- case scm_tc16_real:
- return scm_real_equalp (x, y);
- case scm_tc16_complex:
- return scm_complex_equalp (x, y);
- case scm_tc16_fraction:
- return scm_i_fraction_equalp (x, y);
- }
+ return scm_i_heap_numbers_equal_p (x, y);
}
return SCM_BOOL_F;
}
diff --git a/libguile/numbers.h b/libguile/numbers.h
index d2799b1..83bcc9e 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -4,7 +4,7 @@
#define SCM_NUMBERS_H
/* Copyright (C) 1995, 1996, 1998, 2000-2006, 2008-2011, 2013, 2014,
- * 2016 Free Software Foundation, Inc.
+ * 2016, 2017 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 License
@@ -260,6 +260,7 @@ SCM_API SCM scm_string_to_number (SCM str, SCM radix);
SCM_API SCM scm_bigequal (SCM x, SCM y);
SCM_API SCM scm_real_equalp (SCM x, SCM y);
SCM_API SCM scm_complex_equalp (SCM x, SCM y);
+SCM_INTERNAL SCM scm_i_heap_numbers_equal_p (SCM x, SCM y);
SCM_API SCM scm_number_p (SCM x);
SCM_API SCM scm_complex_p (SCM x);
SCM_API SCM scm_real_p (SCM x);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 1969ce9..8a9f9bc 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -4395,7 +4395,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (213, unused_213, NULL, NOP)
+ VM_DEFINE_OP (213, heap_numbers_equal, "heap-numbers-equal?", OP1
(X8_S12_S12))
+ {
+ scm_t_uint16 a, b;
+ SCM x, y;
+
+ UNPACK_12_12 (op, a, b);
+ x = SP_REF (a);
+ y = SP_REF (b);
+
+ SYNC_IP ();
+ if (scm_is_true (scm_i_heap_numbers_equal_p (x, y)))
+ vp->compare_result = SCM_F_COMPARE_EQUAL;
+ else
+ vp->compare_result = SCM_F_COMPARE_NONE;
+ CACHE_SP ();
+ NEXT (1);
+ }
+
VM_DEFINE_OP (214, unused_214, NULL, NOP)
VM_DEFINE_OP (215, unused_215, NULL, NOP)
VM_DEFINE_OP (216, unused_216, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 9794c09..5651047 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -441,11 +441,13 @@
(($ $primcall 'bytevector? (a)) (unary emit-bytevector? a))
(($ $primcall 'bitvector? (a)) (unary emit-bitvector? a))
(($ $primcall 'keyword? (a)) (unary emit-keyword? a))
+ (($ $primcall 'heap-number? (a)) (unary emit-heap-number? a))
;; Add more TC7 tests here. Keep in sync with
;; *branching-primcall-arities* in (language cps primitives) and
;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
- (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+ (($ $primcall 'heap-numbers-equal? (a b))
+ (binary-test emit-heap-numbers-equal? a b))
(($ $primcall '< (a b)) (binary* emit-<? emit-jl emit-jnl a b))
(($ $primcall '<= (a b)) (binary* emit-<? emit-jge emit-jnge b a))
(($ $primcall '= (a b)) (binary-test emit-=? a b))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index cdb482c..843111b 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -433,6 +433,7 @@ is or might be a read or a write to the same location as A."
;; Numbers.
(define-primitive-effects
+ ((heap-numbers-equal? . _))
((= . _) &type-check)
((< . _) &type-check)
((> . _) &type-check)
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index e62acd3..6207152 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -127,7 +127,7 @@ before it is lowered to CPS?"
(define *comparisons*
'(eq?
- eqv?
+ heap-numbers-equal?
<
<=
=
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index f216aca..9dd0d45 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -125,7 +125,7 @@
(values #t #t))
(else
(values #f #f))))
-(define-branch-folder-alias eqv? eq?)
+(define-branch-folder-alias heap-numbers-equal? eq?)
(define (compare-ranges type0 min0 max0 type1 min1 max1)
;; Since &real, &u64, and &f64 are disjoint, we can compare once
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 90611be..966ef38 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -632,7 +632,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?)
+(define-type-inferrer-aliases eq? heap-numbers-equal?)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index ca859a2..510dceb 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -509,18 +509,6 @@
(($ <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))))))))
((and (eq? name 'list)
(and-map (match-lambda
((or ($ <const>)
@@ -663,6 +651,8 @@
(lambda (cps integer)
(have-args cps (list integer)))))))
(else (have-args cps args))))
+ (when (branching-primitive? name)
+ (error "branching primcall in bad context" name))
(convert-args cps args
(lambda (cps args)
;; Tree-IL primcalls are sloppy, in that it could be
@@ -1001,6 +991,48 @@ integer."
(make-const src #f)
(make-const src #t))))
+ (($ <primcall> src (or 'eqv? 'equal?) (a b))
+ (let ()
+ (define-syntax-rule (with-lexical id . body)
+ (let ((k (lambda (id) . body)))
+ (match id
+ (($ <lexical-ref>) (k id))
+ (_
+ (let ((v (gensym "v ")))
+ (make-let src (list 'v) (list v) (list id)
+ (k (make-lexical-ref src 'v v))))))))
+ (define-syntax with-lexicals
+ (syntax-rules ()
+ ((with-lexicals () . body) (let () . body))
+ ((with-lexicals (id . ids) . body)
+ (with-lexical id (with-lexicals ids . body)))))
+ (define-syntax-rule (primcall name . args)
+ (make-primcall src 'name (list . args)))
+ (define-syntax primcall-chain
+ (syntax-rules ()
+ ((_ x) x)
+ ((_ x . y)
+ (make-conditional src (primcall . x) (primcall-chain . y)
+ (make-const src #f)))))
+ (define-syntax-rule (bool x)
+ (make-conditional src x (make-const src #t) (make-const src #f)))
+ (with-lexicals (a b)
+ (make-conditional
+ src
+ (primcall eq? a b)
+ (make-const src #t)
+ (match (primcall-name exp)
+ ('eqv?
+ ;; Completely inline.
+ (primcall-chain (heap-number? a)
+ (heap-number? b)
+ (bool (primcall heap-numbers-equal? a b))))
+ ('equal?
+ ;; Partially inline.
+ (primcall-chain (heap-object? a)
+ (heap-object? b)
+ (primcall equal? a b))))))))
+
(($ <primcall> src 'vector
(and args
((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
@@ -1110,4 +1142,5 @@ integer."
;;; Local Variables:
;;; eval: (put 'convert-arg 'scheme-indent-function 2)
;;; eval: (put 'convert-args 'scheme-indent-function 2)
+;;; eval: (put 'with-lexicals 'scheme-indent-function 1)
;;; End:
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 2fbf252..704e0fc 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -77,6 +77,7 @@
emit-immediate-tag=?
emit-heap-tag=?
emit-eq?
+ emit-heap-numbers-equal?
emit-j
emit-jl
emit-je
- [Guile-commits] branch master updated (9d1235a -> d1c69b5), Andy Wingo, 2017/10/29
- [Guile-commits] 01/11: Minor optimization compiling 'and', Andy Wingo, 2017/10/29
- [Guile-commits] 08/11: Add untag-fixnum instruction, Andy Wingo, 2017/10/29
- [Guile-commits] 10/11: Inline u64/scm comparisons, Andy Wingo, 2017/10/29
- [Guile-commits] 02/11: Rename "number" tag to "heap-number", Andy Wingo, 2017/10/29
- [Guile-commits] 03/11: Simplify lowering of branching primcalls to CPS, Andy Wingo, 2017/10/29
- [Guile-commits] 11/11: Remove compiler support for u64-scm comparisons, Andy Wingo, 2017/10/29
- [Guile-commits] 05/11: Lower eqv? and equal? to new instructions.,
Andy Wingo <=
- [Guile-commits] 04/11: Add missing compiler support for heap-object? primcall et al., Andy Wingo, 2017/10/29
- [Guile-commits] 07/11: Add compiler support for fixnum? primcall predicate, Andy Wingo, 2017/10/29
- [Guile-commits] 06/11: Add compiler support for s64 comparisons., Andy Wingo, 2017/10/29
- [Guile-commits] 09/11: Add hacks around lack of allocation sinking, Andy Wingo, 2017/10/29