basis/math/floats/env/x86/x86.factor

   1 USING: accessors alien.c-types arrays assocs biassocs
   2 classes.struct combinators cpu.x86.features kernel literals
   3 math math.bitwise math.floats.env math.floats.env.private
   4 system vocabs.loader ;
   5 IN: math.floats.env.x86
   6
   7 STRUCT: sse-env
   8     { mxcsr uint } ;
   9
  10 STRUCT: x87-env
  11     { status ushort }
  12     { control ushort } ;
  13
  14 HOOK: get-sse-env cpu ( sse-env -- )
  15 HOOK: set-sse-env cpu ( sse-env -- )
  16
  17 HOOK: get-x87-env cpu ( x87-env -- )
  18 HOOK: set-x87-env cpu ( x87-env -- )
  19
  20 : <sse-env> ( -- sse-env )
  21     sse-env (struct) [ get-sse-env ] keep ;
  22
  23 M: sse-env (set-fp-env-register)
  24     set-sse-env ;
  25
  26 : <x87-env> ( -- x87-env )
  27     x87-env (struct) [ get-x87-env ] keep ;
  28
  29 M: x87-env (set-fp-env-register)
  30     set-x87-env ;
  31
  32 M: x86 (fp-env-registers)
  33     sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
  34
  35 CONSTANT: sse-exception-flag-bits HEX: 3f
  36 CONSTANT: sse-exception-flag>bit
  37     H{
  38         { +fp-invalid-operation+ HEX: 01 }
  39         { +fp-overflow+          HEX: 08 }
  40         { +fp-underflow+         HEX: 10 }
  41         { +fp-zero-divide+       HEX: 04 }
  42         { +fp-inexact+           HEX: 20 }
  43     }
  44
  45 CONSTANT: sse-fp-traps-bits HEX: 1f80
  46 CONSTANT: sse-fp-traps>bit
  47     H{
  48         { +fp-invalid-operation+ HEX: 0080 }
  49         { +fp-overflow+          HEX: 0400 }
  50         { +fp-underflow+         HEX: 0800 }
  51         { +fp-zero-divide+       HEX: 0200 }
  52         { +fp-inexact+           HEX: 1000 }
  53     }
  54
  55 CONSTANT: sse-rounding-mode-bits HEX: 6000
  56 CONSTANT: sse-rounding-mode>bit
  57     $[ H{
  58         { +round-nearest+ HEX: 0000 }
  59         { +round-down+    HEX: 2000 }
  60         { +round-up+      HEX: 4000 }
  61         { +round-zero+    HEX: 6000 }
  62     } >biassoc ]
  63
  64 CONSTANT: sse-denormal-mode-bits HEX: 8040
  65
  66 M: sse-env (get-exception-flags) ( register -- exceptions )
  67     mxcsr>> sse-exception-flag>bit mask> ; inline
  68 M: sse-env (set-exception-flags) ( register exceptions -- register' )
  69     [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
  70
  71 M: sse-env (get-fp-traps) ( register -- exceptions )
  72     mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
  73 M: sse-env (set-fp-traps) ( register exceptions -- register' )
  74     [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
  75
  76 M: sse-env (get-rounding-mode) ( register -- mode )
  77     mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
  78 M: sse-env (set-rounding-mode) ( register mode -- register' )
  79     [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
  80
  81 M: sse-env (get-denormal-mode) ( register -- mode )
  82     mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
  83 M: sse-env (set-denormal-mode) ( register mode -- register' )
  84     [
  85         {
  86             { +denormal-keep+  [ sse-denormal-mode-bits unmask ] }
  87             { +denormal-flush+ [ sse-denormal-mode-bits bitor  ] }
  88         } case
  89     ] curry change-mxcsr ; inline
  90
  91 CONSTANT: x87-exception-bits HEX: 3f
  92 CONSTANT: x87-exception>bit
  93     H{
  94         { +fp-invalid-operation+ HEX: 01 }
  95         { +fp-overflow+          HEX: 08 }
  96         { +fp-underflow+         HEX: 10 }
  97         { +fp-zero-divide+       HEX: 04 }
  98         { +fp-inexact+           HEX: 20 }
  99     }
 100
 101 CONSTANT: x87-rounding-mode-bits HEX: 0c00
 102 CONSTANT: x87-rounding-mode>bit
 103     $[ H{
 104         { +round-nearest+ HEX: 0000 }
 105         { +round-down+    HEX: 0400 }
 106         { +round-up+      HEX: 0800 }
 107         { +round-zero+    HEX: 0c00 }
 108     } >biassoc ]
 109
 110 M: x87-env (get-exception-flags) ( register -- exceptions )
 111     status>> x87-exception>bit mask> ; inline
 112 M: x87-env (set-exception-flags) ( register exceptions -- register' )
 113     drop ;
 114
 115 M: x87-env (get-fp-traps) ( register -- exceptions )
 116     control>> bitnot x87-exception>bit mask> ; inline
 117 M: x87-env (set-fp-traps) ( register exceptions -- register' )
 118     [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
 119
 120 M: x87-env (get-rounding-mode) ( register -- mode )
 121     control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
 122 M: x87-env (set-rounding-mode) ( register mode -- register' )
 123     [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
 124
 125 M: x87-env (get-denormal-mode) ( register -- mode )
 126     drop +denormal-keep+ ; inline
 127 M: x87-env (set-denormal-mode) ( register mode -- register' )
 128     drop ;
 129
 130 cpu {
 131     { x86.32 [ "math.floats.env.x86.32" ] }
 132     { x86.64 [ "math.floats.env.x86.64" ] }
 133 } case require