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 SINGLETONS:
  22     +round-nearest+
  23     +round-down+
  24     +round-up+
  25     +round-zero+ ;
  26
  27 UNION: fp-rounding-mode
  28     +round-nearest+
  29     +round-down+
  30     +round-up+
  31     +round-zero+ ;
  32
  33 SINGLETONS:
  34     +denormal-keep+
  35     +denormal-flush+ ;
  36
  37 UNION: fp-denormal-mode
  38     +denormal-keep+
  39     +denormal-flush+ ;
  40
  41 <PRIVATE
  42
  43 HOOK: (fp-env-registers) cpu ( -- registers )
  44
  45 : fp-env-register ( -- register ) (fp-env-registers) first ;
  46
  47 :: mask> ( bits assoc -- symbols )
  48     assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
  49 : >mask ( symbols assoc -- bits )
  50     over empty?
  51     [ 2drop 0 ]
  52     [ [ at ] curry [ bitor ] map-reduce ] if ;
  53
  54 : remask ( x new-bits mask-bits -- x' )
  55     [ unmask ] [ mask ] bi-curry bi* bitor ; inline
  56
  57 GENERIC: (set-fp-env-register) ( fp-env -- )
  58
  59 GENERIC: (get-exception-flags) ( fp-env -- exceptions )
  60 GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
  61
  62 GENERIC: (get-fp-traps) ( fp-env -- exceptions )
  63 GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
  64
  65 GENERIC: (get-rounding-mode) ( fp-env -- mode )
  66 GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
  67
  68 GENERIC: (get-denormal-mode) ( fp-env -- mode )
  69 GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
  70
  71 : change-fp-env-registers ( quot -- )
  72     (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
  73
  74 : set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
  75 : set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
  76 : set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
  77
  78 : get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
  79     fp-env-register {
  80         [ (get-exception-flags) ]
  81         [ (get-fp-traps) ]
  82         [ (get-rounding-mode) ]
  83         [ (get-denormal-mode) ]
  84     } cleave ;
  85
  86 : set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
  87     [
  88         {
  89             [ [ (set-exception-flags) ] when* ]
  90             [ [ (set-fp-traps) ] when* ]
  91             [ [ (set-rounding-mode) ] when* ]
  92             [ [ (set-denormal-mode) ] when* ]
  93         } spread
  94     ] 4 ncurry change-fp-env-registers ;
  95
  96 PRIVATE>
  97
  98 : fp-exception-flags ( -- exceptions )
  99     (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
 100 : set-fp-exception-flags ( exceptions -- )
 101     [ (set-exception-flags) ] curry change-fp-env-registers ; inline
 102 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
 103
 104 : collect-fp-exceptions ( quot -- exceptions )
 105     clear-fp-exception-flags call fp-exception-flags ; inline
 106
 107 : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
 108
 109 :: with-denormal-mode ( mode quot -- )
 110     denormal-mode :> orig
 111     mode set-denormal-mode
 112     quot [ orig set-denormal-mode ] [ ] cleanup ; inline
 113
 114 : rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
 115
 116 :: with-rounding-mode ( mode quot -- )
 117     rounding-mode :> orig
 118     mode set-rounding-mode
 119     quot [ orig set-rounding-mode ] [ ] cleanup ; inline
 120
 121 : fp-traps ( -- exceptions )
 122     (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
 123
 124 :: with-fp-traps ( exceptions quot -- )
 125     fp-traps :> orig
 126     exceptions set-fp-traps
 127     quot [ orig set-fp-traps ] [ ] cleanup ; inline
 128
 129 : without-fp-traps ( quot -- )
 130     { } swap with-fp-traps ; inline
 131
 132 << {
 133     { [ cpu x86? ] [ "math.floats.env.x86" require ] }
 134     { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
 135     [ "CPU architecture unsupported by math.floats.env" throw ]
 136 } cond >>
 137