mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-28 14:00:31 +02:00
Code Activity

Unbox floor/ceiling and trigonometric functions where possible

Browse source 
* libguile/intrinsics.c (scm_atan1): New intrinsic, wrapping scm_atan.
  (scm_bootstrap_intrinsics): Add new intrinsics.
* libguile/intrinsics.h (scm_t_f64_from_f64_f64_intrinsic): New
  intrinsic type.
  (SCM_FOR_ALL_VM_INTRINSICS): Add intrinsics for floor, ceiling, sin,
  cos, tan, asin, acos, atan, and their unboxed counterparts.
* libguile/jit.c (sp_f64_operand): New helper.
  (compile_call_f64_from_f64, compile_call_f64_from_f64_f64): Call out
  to intrinsics.
* libguile/vm-engine.c (call-f64<-f64-f64): New opcode.
* module/language/cps/effects-analysis.scm: Add new intrinsics.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
  Add new intrinsics.
* module/language/cps/slot-allocation.scm (compute-var-representations):
  Add 'f64 slot types for the new unboxed intrinsics.
* module/language/cps/specialize-numbers.scm (specialize-operations):
  Support unboxing the new intrinsics.
* module/language/cps/types.scm: Define type inferrers for the new
  intrinsics.
* module/language/tree-il/cps-primitives.scm: Define CPS translations
  for the new intrinsics.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*):
  (*effect-free-primitives*, atan): Define primitive resolvers.
* module/system/vm/assembler.scm: Export assemblers for the new
  intrinsics.
  (define-f64<-f64-f64-intrinsic): New helper.
This commit is contained in:
Andy Wingo 2019-08-24 11:37:17 +02:00
parent 9e3a5c9a10
commit b1564df298
12 changed files with 278 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

13
module/language/cps/specialize-numbers.scm
View file

@ -445,16 +445,21 @@ BITS indicating the significant bits needed for a variable. BITS may be
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(match (cons* op result param args)
(((or 'add 'sub 'mul 'div)
(((or 'add 'sub 'mul 'div 'atan2)
(? f64-result?) #f a b)
(let ((op (match op
('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv))))
('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv)
('atan2 'fatan2))))
(specialize-binop cps k src op a b
(unbox-f64 a) (unbox-f64 b) (box-f64 result))))
(((or 'sqrt 'abs)
(((or 'sqrt 'abs 'floor 'ceiling 'sin 'cos 'tan 'asin 'acos 'atan)
(? f64-result?) #f a)
(let ((op (match op ('sqrt 'fsqrt) ('abs 'fabs))))
(let ((op (match op
('sqrt 'fsqrt) ('abs 'fabs)
('floor 'ffloor) ('ceiling 'fceiling)
('sin 'fsin) ('cos 'fcos) ('tan 'ftan)
('asin 'fasin) ('acos 'facos) ('atan 'fatan))))
(specialize-unop cps k src op #f a
(unbox-f64 a) (box-f64 result))))