mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
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?.
This commit is contained in:
Andy Wingo
parent
c2fa345093
commit
73d1502630
10 changed files with 94 additions and 30 deletions
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ before it is lowered to CPS?"
|
|||
|
||||
(define *comparisons*
|
||||
'(eq?
|
||||
eqv?
|
||||
heap-numbers-equal?
|
||||
<
|
||||
<=
|
||||
=
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -77,6 +77,7 @@
|
|||
emit-immediate-tag=?
|
||||
emit-heap-tag=?
|
||||
emit-eq?
|
||||
emit-heap-numbers-equal?
|
||||
emit-j
|
||||
emit-jl
|
||||
emit-je
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue