Commit 408aa78a authored by Raymond Toy's avatar Raymond Toy

Merge branch 'master' into rtoy-simp-dd-trig

parents 00bd409b 01a3f47b
This diff is collapsed.
......@@ -3232,12 +3232,17 @@
dstate
stream)))
(defun disassemble-segments (segments stream dstate)
(defun disassemble-segments (segments stream dstate &key
(base 16)
(case :downcase)
(radix *print-radix*))
"Disassemble the machine code instructions in each memory segment in
SEGMENTS in turn to STREAM."
(declare (type list segments)
(type stream stream)
(type disassem-state dstate))
(type disassem-state dstate)
(type (integer 2 36) base)
(type (member :upcase :downcase :capitalize) case))
(unless (null segments)
(let ((first (car segments))
(last (car (last segments))))
......@@ -3257,15 +3262,21 @@
;; Initialize these to a sane value, just in case.
(setf vm::*note-addis-inst* nil)
(setf vm::*pseudo-atomic-set* nil))
(dolist (seg segments)
(disassemble-segment seg stream dstate)))))
(let ((*print-base* base)
(*print-case* case)
(*print-radix* radix))
(dolist (seg segments)
(disassemble-segment seg stream dstate))))))
;;; ----------------------------------------------------------------
;;; top-level functions
(defun disassemble-function (function &key (stream *standard-output*)
(use-labels t)
(backend c:*native-backend*))
(use-labels t)
(backend c:*native-backend*)
(base 16)
(case :downcase)
(radix *print-radix*))
"Disassemble the machine code instructions for FUNCTION."
(declare (type compiled-function function)
(type stream stream)
......@@ -3275,7 +3286,8 @@
(segments (get-function-segments function)))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
(disassemble-segments segments stream dstate
:base base :case case :radix radix)))
(defun compile-function-lambda-expr (function)
(declare (type function function))
......@@ -3328,33 +3340,49 @@
(declare (type (or function symbol cons) object)
(type (or (member t) stream) stream)
(type (member t nil) use-labels)
(type c::backend backend)
(type (integer 2 36) base)
(type (member :upcase :downcase :capitalize) case))
(let ((*print-base* base)
(*print-case* case)
(*print-radix* radix)
(fun (compiled-function-or-lose object)))
(type c::backend backend))
(let ((fun (compiled-function-or-lose object)))
(if (typep fun 'kernel:byte-function)
(c:disassem-byte-fun fun)
;; we can't detect closures, so be careful
(disassemble-function (fun-self fun)
:stream stream
:use-labels use-labels
:backend backend)))
:backend backend
:base base
:case case
:radix radix)))
(values))
(defun disassemble-memory (address
length
&key
(stream *standard-output*)
code-component
(use-labels t)
(backend c:*backend*))
"Disassembles the given area of memory starting at ADDRESS and LENGTH long.
Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
you'd better disable it around the call to this function."
(declare (type (or address system:system-area-pointer) address)
(stream *standard-output*)
code-component
(use-labels t)
(backend c:*backend*)
(base 16)
(case :downcase)
(radix *print-radix*))
"Disassembles the given area of memory starting at ADDRESS and
LENGTH (octets) long. Note that if CODE-COMPONENT is NIL and this
memory could move during a GC, you'd better disable it around the
call to this function. ADDRESS can be either an integer or a
system-area-pointer.
:Stream stream
The dissassembly is written to this stream.
:Use-labels
Labels are generated instead of using instruction addresses.
:Base
:Case
:Radix
The disassembler uses the specified base, case, and radix when
printing the disassembled code. The default values are 16,
:downcase, and *print-radix*, respectively. "
(declare (type (or address
system:system-area-pointer) address)
(type length length)
(type stream stream)
(type (or null kernel:code-component) code-component)
......@@ -3379,12 +3407,16 @@
(list (make-memory-segment address length)))))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
(disassemble-segments segments stream dstate
:base base :case case :radix radix)))
(defun disassemble-code-component (code-component &key
(stream *standard-output*)
(use-labels t)
(backend c:*native-backend*))
(stream *standard-output*)
(use-labels t)
(backend c:*native-backend*)
(base 16)
(case :downcase)
(radix *print-radix*))
"Disassemble the machine code instructions associated with
CODE-COMPONENT (this may include multiple entry points)."
(declare (type (or null kernel:code-component compiled-function)
......@@ -3400,7 +3432,8 @@
(segments (get-code-segments code-component)))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
(disassemble-segments segments stream dstate
:base base :case case :radix radix)))
;;; ----------------------------------------------------------------
;;; Code for making useful segments from arbitrary lists of code-blocks
......
......@@ -731,8 +731,6 @@
(deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
`(,prim x))))
#+(or (and linux x86) sparc)
(progn
(defknown (kernel::%sincos)
(double-float) (values double-float double-float)
(movable foldable flushable))
......@@ -752,7 +750,7 @@
(deftransform cis ((z) (double-double-float) *)
;; Cis.
'(complex (cos z) (sin z)))
)
;;; The argument range is limited on the x86 FP trig. functions. A
;;; post-test can detect a failure (and load a suitable result), but
......
......@@ -126,10 +126,6 @@ msgstr ""
msgid "inline scalb function"
msgstr ""
#: src/compiler/x86/float.lisp
msgid "inline log1p function"
msgstr ""
#: src/compiler/x86/float.lisp
msgid "inline log1p with limited x range function"
msgstr ""
......@@ -146,6 +142,10 @@ msgstr ""
msgid "inline atan2 function"
msgstr ""
#: src/compiler/x86/float.lisp
msgid "inline log1p function"
msgstr ""
#: src/compiler/x86/float.lisp
msgid "inline complex single-float creation"
msgstr ""
......
......@@ -17157,10 +17157,22 @@ msgstr ""
#: src/compiler/disassem.lisp
msgid ""
"Disassembles the given area of memory starting at ADDRESS and LENGTH long.\n"
" Note that if CODE-COMPONENT is NIL and this memory could move during a GC,"
"Disassembles the given area of memory starting at ADDRESS and\n"
" LENGTH (octets) long. Note that if CODE-COMPONENT is NIL and this\n"
" memory could move during a GC, you'd better disable it around the\n"
" call to this function. ADDRESS can be either an integer or a\n"
" system-area-pointer.\n"
"\n"
" you'd better disable it around the call to this function."
" :Stream stream\n"
" The dissassembly is written to this stream.\n"
" :Use-labels\n"
" Labels are generated instead of using instruction addresses.\n"
" :Base\n"
" :Case\n"
" :Radix\n"
" The disassembler uses the specified base, case, and radix when\n"
" printing the disassembled code. The default values are 16,\n"
" :downcase, and *print-radix*, respectively. "
msgstr ""
#: src/compiler/disassem.lisp
......
......@@ -56,6 +56,6 @@ ASSEM_SRC = sparc-assem.S
ARCH_SRC = sparc-arch.c
DEPEND=$(CC)
OS_SRC = solaris-os.c os-common.c undefineds.c elf.c k_rem_pio2.c
OS_SRC = solaris-os.c os-common.c undefineds.c elf.c e_rem_pio2.c k_rem_pio2.c
OS_LIBS= -lsocket -lnsl -ldl
EXEC_FINAL_OBJ = exec-final.o
......@@ -65,7 +65,13 @@ NM = nm -gp
DEPEND_FLAGS = -MM
# This no longer has aliasing problems, so no need to use
# -ffloat-store and -fno-strict-aliasing anymore.
# -fno-strict-aliasing anymore. However, if we're building with x87,
# we MUST use -ffloat-store to get proper double-float rounding.
e_rem_pio2.o : e_rem_pio2.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) $<
$(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $<
k_rem_pio2.o : k_rem_pio2.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $<
# -*- Mode: makefile -*-
include Config.x86_common
# Need -ffloat-store for e_rem_pio2 and k_rem_pio2 to get properly
# rounded double-floats while using x87 extended precision.
CC_REM_PIO2 = -ffloat-store
UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
OS_SRC += FreeBSD-os.c elf.c
OS_LINK_FLAGS = -dynamic -export-dynamic
......
......@@ -3,6 +3,10 @@ include Config.x86_common
CPPFLAGS += -m32 -rdynamic -D__NO_CTYPE -D_GNU_SOURCE
# Need -ffloat-store for e_rem_pio2 and k_rem_pio2 to get properly
# rounded double-floats while using x87 extended precision.
CC_REM_PIO2 = -ffloat-store
UNDEFSYMPATTERN = -Xlinker -u -Xlinker &
ASSEM_SRC += linux-stubs.S
OS_SRC += Linux-os.c elf.c
......
......@@ -542,3 +542,19 @@ os_guard_control_stack(int zone, int guard)
}
#endif /* not RED_ZONE_HIT */
/* Simple interface to __ieee754_rem_pio2 */
int ieee754_rem_pio2(double x, double *y0, double *y1)
{
extern int __ieee754_rem_pio2(double x, double *y);
double y[2];
int n;
n = __ieee754_rem_pio2(x, y);
*y0 = y[0];
*y1 = y[1];
return n;
}
......@@ -723,17 +723,3 @@ arch_linkage_entry(unsigned long retaddr)
/ LinkageEntrySize;
}
#endif
int ieee754_rem_pio2(double x, double *y0, double *y1)
{
extern int __ieee754_rem_pio2(double x, double *y);
double y[2];
int n;
n = __ieee754_rem_pio2(x, y);
*y0 = y[0];
*y1 = y[1];
return n;
}
......@@ -521,19 +521,3 @@ arch_linkage_entry(unsigned long retaddr)
return ((retaddr - 5) - FOREIGN_LINKAGE_SPACE_START) / LinkageEntrySize;
}
#endif /* LINKAGE_TABLE */
int ieee754_rem_pio2(double x, double *y0, double *y1)
{
extern int __ieee754_rem_pio2(double x, double *y);
double y[2];
int n;
n = __ieee754_rem_pio2(x, y);
*y0 = y[0];
*y1 = y[1];
return n;
}
;;; Tests for the basic trig functions, now implemented in Lisp.
(defpackage :trig-tests
(:use :cl :lisp-unit))
(in-package "TRIG-TESTS")
(define-test sin.signed-zeroes
"Test sin for 0d0 and -0d0"
(:tag :sin :signed-zeroes)
(assert-eql 0d0 (sin 0d0))
(assert-eql -0d0 (sin -0d0)))
(define-test sin.very-small
"Tests sin for the case of |x| < 2^-27, but not 0."
(:tag :sin)
(assert-eql (scale-float 1d0 -28)
(sin (scale-float 1d0 -28))))
(define-test sin.no-reduction
"Test sin for small args without reduction"
(:tag :sin)
(assert-eql 0.479425538604203d0
(sin .5d0))
(assert-eql -0.479425538604203d0
(sin -0.5d0)))
(define-test sin.pi/2
"Test for arg near pi/2"
(:tag :sin)
(assert-eql 1d0 (sin (/ pi 2))))
(define-test sin.arg-reduction
"Test for sin with arg reduction"
(:tag :sin)
;; Test for argument reduction with n mod 4 = 0
(assert-eql -7.07106781186547675943154203316156531867416581156d-1
(sin (* 7/4 pi)))
;; Test for argument reduction with n mod 4 = 1
(assert-eql 7.07106781186547329560731709118834541043171055432d-1
(sin (* 9/4 pi)))
;; Test for argument reduction with n mod 4 = 2
(assert-eql 7.07106781186548390575743300374993861263439430213d-1
(sin (* 11/4 pi)))
;; Test for argument reduction with n mod 4 = 3
(assert-eql -7.07106781186547871002109559079472349116005337743d-1
(sin (* 13/4 pi)))
;; Test for argument reduction, big value
(assert-eql 0.377820109360752d0
(sin (scale-float 1d0 120))))
(define-test sin.exceptions
"Test sin for exceptional values"
(:tag :sin :exceptions)
(kernel::with-float-traps-masked ()
(assert-error 'floating-point-invalid-operation
(sin ext:double-float-positive-infinity))
(assert-error 'floating-point-invalid-operation
(sin ext:double-float-negative-infinity))))
(define-test cos.signed-zeroes
"Test cos for 0d0 and -0d0"
(:tag :cos :signed-zeroes)
(assert-eql 1d0 (cos 0d0))
(assert-eql 1d0 (cos -0d0)))
(define-test cos.very-small
"Test cos for |x| < 2^-27"
(:tag :cos)
(assert-eql 1d0 (cos (scale-float 1d0 -28))))
(define-test cos.code-paths
"Tests various code paths in cos evaluation"
(:tag :cos)
;; Test for branch |x| < .3
(assert-eql 0.9689124217106447d0
(cos 0.25d0))
;; Test for branch |x| > .3 and \x| < .78125
(assert-eql 8.7758256189037271611628158260382965199164519711d-1
(cos 0.5d0))
;; Test for branch |x| > .3 and |x| > .78125
(assert-eql 0.7073882691671998d0
(cos 0.785d0)))
(define-test cos.pi/2
"Test cos(pi/2)"
(:tag :cos)
(assert-eql 6.123233995736766d-17
(cos (/ pi 2))))
(define-test cos.arg-reduction
"Test for cos with arg reduction"
(:tag :cos)
;; Test for argument reduction with n mod 4 = 0
(assert-eql 7.07106781186547372858534520893509069186435867941d-1
(cos (* 7/4 pi)))
;; Test for argument reduction with n mod 4 = 1
(assert-eql 7.0710678118654771924095701509080985020443197242d-1
(cos (* 9/4 pi)))
;; Test for argument reduction with n mod 4 = 2
(assert-eql -7.07106781186546658225945423833643190916000739026d-1
(cos (* 11/4 pi)))
;; Test for argument reduction with n mod 4 = 3
(assert-eql -7.07106781186547177799579165130055836531929091466d-1
(cos (* 13/4 pi)))
;; Test for argument reduction
(assert-eql -0.9258790228548379d0
(cos (scale-float 1d0 120))))
(define-test cos.exceptions
"Test cos for exceptional values"
(:tag :sin :exceptions)
(kernel::with-float-traps-masked ()
(assert-error 'floating-point-invalid-operation
(cos ext:double-float-positive-infinity))
(assert-error 'floating-point-invalid-operation
(cos ext:double-float-negative-infinity))))
(define-test tan.signed-zeroes
"Test tan for 0d0 and -0d0"
(:tag :tan :signed-zeroes)
(assert-eql 0d0 (tan 0d0))
(assert-eql -0d0 (tan -0d0)))
(define-test tan.very-small
"Test for tan, |x| < 2^-28"
(:tag :tan)
(assert-eql (scale-float 1d0 -29)
(tan (scale-float 1d0 -29)))
(assert-eql (scale-float -1d0 -29)
(tan (scale-float -1d0 -29))))
(define-test tan.pi/2
"Test for tan(pi/2)"
(:tag :tan)
(assert-eql 1.63312393531953697559677370415289165308640681049d16
(tan (/ pi 2))))
(define-test tan.code-paths
"Tests for various code paths in tan"
(:tag :tan)
;; |x| < .6744
(assert-eql 5.4630248984379051325517946578028538329755172018d-1
(tan 0.5d0))
;; |x = 11/16 = 0.6875 > .6744
(assert-eql 8.21141801589894121911423965374711700875371645309d-1
(tan (float 11/16 1d0)))
;; This was found by maxima's testsuite. A bug in kernel-tan when
;; returning cot(x).
(assert-eql 2.0000000000000028604455051971538975562294147582d0
(tan 1.107148717794091d0)))
(define-test tan.arg-reduction
"Test for tan with arg reduction"
(:tag :tan)
;; Test for argument reduction with n even
(assert-eql -1.00000000000000042862637970157370388940976433505d0
(tan (* 7/4 pi)))
;; Test for argument reduction with n odd
(assert-eql 9.99999999999999448908940383691222098948324989275d-1
(tan (* 9/4 pi)))
(assert-eql -4.08066388841804238545143494525595117765084022768d-1
(tan (scale-float 1d0 120))))
(define-test tan.exceptions
"Test tan for exceptional values"
(:tag :sin :exceptions)
(kernel::with-float-traps-masked ()
(assert-error 'floating-point-invalid-operation
(tan ext:double-float-positive-infinity))
(assert-error 'floating-point-invalid-operation
(tan ext:double-float-negative-infinity))))
(define-test sincos.signed-zeroes
"Test sincos at 0d0, -0d0"
(:tag :sincos :signed-zeroes)
(assert-equal '(0d0 1d0)
(multiple-value-list (kernel::%sincos 0d0)))
(assert-equal '(-0d0 1d0)
(multiple-value-list (kernel::%sincos -0d0))))
;; Test sincos at a bunch of random points and compare the result from
;; sin and cos. If they differ, save the result in a list to be
;; returned.
(defun sincos-test (limit n)
(let (results)
(dotimes (k n)
(let* ((x (random limit))
(s-exp (sin x))
(c-exp (cos x)))
(multiple-value-bind (s c)
(kernel::%sincos x)
(unless (and (eql s s-exp)
(eql c c-exp))
(push (list x
(list s s-exp)
(list c c-exp))
results)))))
results))
(define-test sincos.consistent
"Test sincos is consistent with sin and cos"
(:tag :sincos)
;; Small values
(assert-eql nil
(sincos-test (/ pi 4) 1000))
;; Medium
(assert-eql nil
(sincos-test 16d0 1000))
;; Large
(assert-eql nil
(sincos-test (scale-float 1d0 120) 1000))
;; Very large
(assert-eql nil
(sincos-test (scale-float 1d0 1023) 1000)))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment