basis/math/floats/env/env.factor

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