diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index ced371161..a00ab39f6 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -21,6 +21,8 @@ # include #endif +#include + #include "alist.h" #include "atomics-internal.h" #include "boolean.h" @@ -516,6 +518,10 @@ scm_bootstrap_intrinsics (void) scm_vm_intrinsics.current_module = current_module; scm_vm_intrinsics.push_prompt = push_prompt; scm_vm_intrinsics.allocate_words_with_freelist = allocate_words_with_freelist; + scm_vm_intrinsics.abs = scm_abs; + scm_vm_intrinsics.sqrt = scm_sqrt; + scm_vm_intrinsics.fabs = fabs; + scm_vm_intrinsics.fsqrt = sqrt; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_intrinsics", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index de4f0e2d2..15add953f 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -92,6 +92,7 @@ typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*); typedef void (*scm_t_ptr_scm_intrinsic) (SCM*, SCM); typedef SCM (*scm_t_scm_from_ptr_scm_intrinsic) (SCM*, SCM); typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM); +typedef double (*scm_t_f64_from_f64_intrinsic) (double); typedef uint32_t* scm_t_vcode_intrinsic; #define SCM_FOR_ALL_VM_INTRINSICS(M) \ @@ -162,6 +163,10 @@ typedef uint32_t* scm_t_vcode_intrinsic; M(thread_scm, unpack_values_object, "unpack-values-object", UNPACK_VALUES_OBJECT) \ M(vcode, handle_interrupt_code, "%handle-interrupt-code", HANDLE_INTERRUPT_CODE) \ M(scm_from_thread_sz, allocate_words_with_freelist, "allocate-words/freelist", ALLOCATE_WORDS_WITH_FREELIST) \ + M(scm_from_scm, abs, "abs", ABS) \ + M(scm_from_scm, sqrt, "sqrt", SQRT) \ + M(f64_from_f64, fabs, "fabs", FABS) \ + M(f64_from_f64, fsqrt, "fsqrt", FSQRT) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/jit.c b/libguile/jit.c index 082eb3ef3..a8b2270a2 100644 --- a/libguile/jit.c +++ b/libguile/jit.c @@ -516,6 +516,8 @@ DEFINE_CLOBBER_RECORDING_EMITTER_R_I(muli, gpr) DEFINE_CLOBBER_RECORDING_EMITTER_R_R(mulr, gpr) DEFINE_CLOBBER_RECORDING_EMITTER_R_R(mulr_d, fpr) DEFINE_CLOBBER_RECORDING_EMITTER_R_R(divr_d, fpr) +DEFINE_CLOBBER_RECORDING_EMITTER_R(absr_d, fpr) +DEFINE_CLOBBER_RECORDING_EMITTER_R(sqrtr_d, fpr) DEFINE_CLOBBER_RECORDING_EMITTER_R_I(andi, gpr) DEFINE_CLOBBER_RECORDING_EMITTER_R_R(andr, gpr) DEFINE_CLOBBER_RECORDING_EMITTER_R_R(orr, gpr) @@ -2362,6 +2364,30 @@ compile_call_f64_from_scm (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t emit_sp_set_f64 (j, dst, JIT_F0); } +static void +compile_call_f64_from_f64 (scm_jit_state *j, uint16_t dst, uint16_t src, uint32_t idx) +{ + switch ((enum scm_vm_intrinsic) idx) + { + case SCM_VM_INTRINSIC_FABS: + { + emit_sp_ref_f64 (j, JIT_F0, src); + emit_absr_d (j, JIT_F0, JIT_F0); + emit_sp_set_f64 (j, dst, JIT_F0); + break; + } + case SCM_VM_INTRINSIC_FSQRT: + { + emit_sp_ref_f64 (j, JIT_F0, src); + emit_sqrtr_d (j, JIT_F0, JIT_F0); + emit_sp_set_f64 (j, dst, JIT_F0); + break; + } + default: + DIE("unhandled f64<-f64"); + } +} + static void compile_call_u64_from_scm (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t idx) { diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 469a31cea..ab34d42b9 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3242,7 +3242,25 @@ VM_NAME (scm_thread *thread) NEXT (1); } - VM_DEFINE_OP (155, unused_155, NULL, NOP) + /* call-f64<-f64 dst:12 src:12 IDX:32 + * + * Call the double-returning instrinsic with index IDX, passing SCM + * local SRC as argument. Place the double result in DST. + */ + VM_DEFINE_OP (155, call_f64_from_f64, "call-f64<-f64", DOP2 (X8_S12_S12, C32)) + { + uint16_t dst, src; + scm_t_f64_from_f64_intrinsic intrinsic; + + UNPACK_12_12 (op, dst, src); + intrinsic = intrinsics[ip[1]]; + + /* We assume these instructions can't throw an exception. */ + SP_SET_F64 (dst, intrinsic (SP_REF_F64 (src))); + + NEXT (2); + } + VM_DEFINE_OP (156, unused_156, NULL, NOP) VM_DEFINE_OP (157, unused_157, NULL, NOP) VM_DEFINE_OP (158, unused_158, NULL, NOP) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 250aec78a..f35a56a04 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -1,6 +1,6 @@ ;;; Effects analysis on CPS -;; Copyright (C) 2011-2015, 2017, 2018 Free Software Foundation, Inc. +;; Copyright (C) 2011-2015,2017-2019 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 @@ -549,7 +549,9 @@ the LABELS that are clobbered by the effects of LABEL." ((logtest a b) &type-check) ((logbit? a b) &type-check) ((sqrt _) &type-check) - ((abs _) &type-check)) + ((abs _) &type-check) + ((fsqrt _)) + ((fabs _))) ;; Characters. (define-primitive-effects diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 6ec90299e..2f8cb5245 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -314,6 +314,10 @@ quo rem mod + sqrt + abs + fsqrt + fabs logand logior logxor diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 247d64869..91ce0dfe3 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -756,7 +756,7 @@ are comparable with eqv?. A tmp slot may be used." (intmap-ref representations arg))) (($ $primcall (or 'scm->f64 'load-f64 'f32-ref 'f64-ref - 'fadd 'fsub 'fmul 'fdiv)) + 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs)) (intmap-add representations var 'f64)) (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 's64->u64 diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index dc8e26f29..a0fafb215 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -452,6 +452,12 @@ BITS indicating the significant bits needed for a variable. BITS may be (specialize-binop cps k src op a b (unbox-f64 a) (unbox-f64 b) (box-f64 result)))) + (((or 'sqrt 'abs) + (? f64-result?) #f a) + (let ((op (match op ('sqrt 'fsqrt) ('abs 'fabs)))) + (specialize-unop cps k src op #f a + (unbox-f64 a) (box-f64 result)))) + (((or 'add 'sub 'mul 'logand 'logior 'logxor 'logsub) (? u64-result?) #f (? u64-operand? a) (? u64-operand? b)) (let ((op (match op diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index bcf22d391..f6db09fb4 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1680,6 +1680,16 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)." (if (zero? r) s (+ s 1))))))) (else (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) +(define-type-checker (fsqrt x) #t) +(define-type-inferrer (fsqrt x result) + (define! result + &f64 + (exact-integer-sqrt (max (&min x) 0)) + (if (inf? (&max x)) + +inf.0 + (call-with-values (lambda () (exact-integer-sqrt (&max x))) + (lambda (s r) + (if (zero? r) s (+ s 1))))))) (define-simple-type-checker (abs &real)) (define-type-inferrer (abs x result) @@ -1704,6 +1714,12 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)." (define! result (logior (logand type (lognot &number)) (logand type &real)) min max)))))) +(define-type-checker (fabs x) #t) +(define-type-inferrer (fabs x result) + (let ((min (if (< (&min x) 0) 0 (&min x))) + (max (max (abs (&min x)) (abs (&max x))))) + (define! result &f64 min max))) + diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm index b9f2fe95b..17afa0d1e 100644 --- a/module/language/tree-il/cps-primitives.scm +++ b/module/language/tree-il/cps-primitives.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013- 2015, 2017-2018 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015, 2017-2019 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 @@ -85,6 +85,8 @@ (define-cps-primitive (quotient quo) 2 1) (define-cps-primitive (remainder rem) 2 1) (define-cps-primitive (modulo mod) 2 1) +(define-cps-primitive sqrt 1 1) +(define-cps-primitive abs 1 1) (define-cps-primitive lsh 2 1) (define-cps-primitive rsh 2 1) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c9e9f5f7b..d8a84dda3 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -197,6 +197,10 @@ emit-quo emit-rem emit-mod + emit-abs + emit-sqrt + emit-fabs + emit-fsqrt emit-logand emit-logior emit-logxor @@ -1321,6 +1325,9 @@ returned instead." (define-syntax-rule (define-f64<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-f64<-scm asm dst src (intrinsic-name->index 'name)))) +(define-syntax-rule (define-f64<-f64-intrinsic name) + (define-macro-assembler (name asm dst src) + (emit-call-f64<-f64 asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-u64<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-u64<-scm asm dst src (intrinsic-name->index 'name)))) @@ -1364,6 +1371,10 @@ returned instead." (define-scm<-scm-scm-intrinsic quo) (define-scm<-scm-scm-intrinsic rem) (define-scm<-scm-scm-intrinsic mod) +(define-scm<-scm-intrinsic abs) +(define-scm<-scm-intrinsic sqrt) +(define-f64<-f64-intrinsic fabs) +(define-f64<-f64-intrinsic fsqrt) (define-scm<-scm-scm-intrinsic logand) (define-scm<-scm-scm-intrinsic logior) (define-scm<-scm-scm-intrinsic logxor)