basis/math/floats/env/env.factor

   1 ! (c)Joe Groff bsd license
   2 USING: alien.syntax arrays assocs biassocs combinators continuations
   3 generalizations kernel literals locals math math.bitwise
   4 sequences sets system vocabs.loader ;
   5 IN: math.floats.env
   6
   7 SINGLETONS:
   8     +fp-invalid-operation+
   9     +fp-overflow+
  10     +fp-underflow+
  11     +fp-zero-divide+
  12     +fp-inexact+ ;
  13
  14 UNION: fp-exception
  15     +fp-invalid-operation+
  16     +fp-overflow+
  17     +fp-underflow+
  18     +fp-zero-divide+
  19     +fp-inexact+ ;
  20
  21 CONSTANT: all-fp-exceptions
  22     {
  23         +fp-invalid-operation+
  24         +fp-overflow+
  25         +fp-underflow+
  26         +fp-zero-divide+
  27         +fp-inexact+
  28     }
  29
  30 SINGLETONS:
  31     +round-nearest+
  32     +round-down+
  33     +round-up+
  34     +round-zero+ ;
  35
  36 UNION: fp-rounding-mode
  37     +round-nearest+
  38     +round-down+
  39     +round-up+
  40     +round-zero+ ;
  41
  42 SINGLETONS:
  43     +denormal-keep+
  44     +denormal-flush+ ;
  45
  46 UNION: fp-denormal-mode
  47     +denormal-keep+
  48     +denormal-flush+ ;
  49
  50 <PRIVATE
  51
  52 HOOK: (fp-env-registers) cpu ( -- registers )
  53
  54 : fp-env-register ( -- register ) (fp-env-registers) first ;
  55
  56 :: mask> ( bits assoc -- symbols )
  57     assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
  58 : >mask ( symbols assoc -- bits )
  59     over empty?
  60     [ 2drop 0 ]
  61     [ [ at ] curry [ bitor ] map-reduce ] if ;
  62
  63 : remask ( x new-bits mask-bits -- x' )
  64     [ unmask ] [ mask ] bi-curry bi* bitor ; inline
  65
  66 GENERIC: (set-fp-env-register) ( fp-env -- )
  67
  68 GENERIC: (get-exception-flags) ( fp-env -- exceptions )
  69 GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
  70
  71 GENERIC: (get-fp-traps) ( fp-env -- exceptions )
  72 GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
  73
  74 GENERIC: (get-rounding-mode) ( fp-env -- mode )
  75 GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
  76
  77 GENERIC: (get-denormal-mode) ( fp-env -- mode )
  78 GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
  79
  80 : change-fp-env-registers ( quot -- )
  81     (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
  82
  83 : set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
  84 : set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
  85 : set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
  86
  87 : get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
  88     fp-env-register {
  89         [ (get-exception-flags) ]
  90         [ (get-fp-traps) ]
  91         [ (get-rounding-mode) ]
  92         [ (get-denormal-mode) ]
  93     } cleave ;
  94
  95 : set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
  96     [
  97         {
  98             [ [ (set-exception-flags) ] when* ]
  99             [ [ (set-fp-traps) ] when* ]
 100             [ [ (set-rounding-mode) ] when* ]
 101             [ [ (set-denormal-mode) ] when* ]
 102         } spread
 103     ] 4 ncurry change-fp-env-registers ;
 104
 105 PRIVATE>
 106
 107 : fp-exception-flags ( -- exceptions )
 108     (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
 109 : set-fp-exception-flags ( exceptions -- )
 110     [ (set-exception-flags) ] curry change-fp-env-registers ; inline
 111 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
 112
 113 : collect-fp-exceptions ( quot -- exceptions )
 114     [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
 115
 116 : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
 117
 118 :: with-denormal-mode ( mode quot -- )
 119     denormal-mode :> orig
 120     mode set-denormal-mode
 121     quot [ orig set-denormal-mode ] [ ] cleanup ; inline
 122
 123 : rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
 124
 125 :: with-rounding-mode ( mode quot -- )
 126     rounding-mode :> orig
 127     mode set-rounding-mode
 128     quot [ orig set-rounding-mode ] [ ] cleanup ; inline
 129
 130 : fp-traps ( -- exceptions )
 131     (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
 132
 133 :: with-fp-traps ( exceptions quot -- )
 134     fp-traps :> orig
 135     exceptions set-fp-traps
 136     quot [ orig set-fp-traps ] [ ] cleanup ; inline
 137
 138 : without-fp-traps ( quot -- )
 139     { } swap with-fp-traps ; inline
 140
 141 << {
 142     { [ cpu x86? ] [ "math.floats.env.x86" require ] }
 143     { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
 144     [ "CPU architecture unsupported by math.floats.env" throw ]
 145 } cond >>
 146