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

   1 USING: accessors alien alien.c-types alien.syntax arrays assocs
   2 biassocs classes.struct combinators cpu.x86.64
   3 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86.features
   4 kernel literals math math.bitwise math.floats.env
   5 math.floats.env.private system ;
   6 IN: math.floats.env.x86
   7
   8 STRUCT: sse-env
   9     { mxcsr uint } ;
  10
  11 STRUCT: x87-env
  12     { status ushort }
  13     { control ushort } ;
  14
  15 HOOK: get-sse-env cpu ( sse-env -- )
  16 HOOK: set-sse-env cpu ( sse-env -- )
  17
  18 HOOK: get-x87-env cpu ( x87-env -- )
  19 HOOK: set-x87-env cpu ( x87-env -- )
  20
  21 ! 32-bit
  22 M: x86.32 get-sse-env
  23     void { void* } "cdecl" [
  24         EAX ESP [] MOV
  25         EAX [] STMXCSR
  26     ] alien-assembly ;
  27
  28 M: x86.32 set-sse-env
  29     void { void* } "cdecl" [
  30         EAX ESP [] MOV
  31         EAX [] LDMXCSR
  32     ] alien-assembly ;
  33
  34 M: x86.32 get-x87-env
  35     void { void* } "cdecl" [
  36         EAX ESP [] MOV
  37         EAX [] FNSTSW
  38         EAX 2 [+] FNSTCW
  39     ] alien-assembly ;
  40
  41 M: x86.32 set-x87-env
  42     void { void* } "cdecl" [
  43         EAX ESP [] MOV
  44         FNCLEX
  45         EAX 2 [+] FLDCW
  46     ] alien-assembly ;
  47
  48 ! 64-bit
  49 M: x86.64 get-sse-env
  50     void { void* } "cdecl" [
  51         param-reg-0 [] STMXCSR
  52     ] alien-assembly ;
  53
  54 M: x86.64 set-sse-env
  55     void { void* } "cdecl" [
  56         param-reg-0 [] LDMXCSR
  57     ] alien-assembly ;
  58
  59 M: x86.64 get-x87-env
  60     void { void* } "cdecl" [
  61         param-reg-0 [] FNSTSW
  62         param-reg-0 2 [+] FNSTCW
  63     ] alien-assembly ;
  64
  65 M: x86.64 set-x87-env
  66     void { void* } "cdecl" [
  67         FNCLEX
  68         param-reg-0 2 [+] FLDCW
  69     ] alien-assembly ;
  70
  71 : <sse-env> ( -- sse-env )
  72     sse-env (struct) [ get-sse-env ] keep ;
  73
  74 M: sse-env (set-fp-env-register)
  75     set-sse-env ;
  76
  77 : <x87-env> ( -- x87-env )
  78     x87-env (struct) [ get-x87-env ] keep ;
  79
  80 M: x87-env (set-fp-env-register)
  81     set-x87-env ;
  82
  83 M: x86 (fp-env-registers)
  84     sse2? [ <sse-env> <x87-env> 2array ] [ <x87-env> 1array ] if ;
  85
  86 CONSTANT: sse-exception-flag-bits HEX: 3f
  87 CONSTANT: sse-exception-flag>bit
  88     H{
  89         { +fp-invalid-operation+ HEX: 01 }
  90         { +fp-overflow+          HEX: 08 }
  91         { +fp-underflow+         HEX: 10 }
  92         { +fp-zero-divide+       HEX: 04 }
  93         { +fp-inexact+           HEX: 20 }
  94     }
  95
  96 CONSTANT: sse-fp-traps-bits HEX: 1f80
  97 CONSTANT: sse-fp-traps>bit
  98     H{
  99         { +fp-invalid-operation+ HEX: 0080 }
 100         { +fp-overflow+          HEX: 0400 }
 101         { +fp-underflow+         HEX: 0800 }
 102         { +fp-zero-divide+       HEX: 0200 }
 103         { +fp-inexact+           HEX: 1000 }
 104     }
 105
 106 CONSTANT: sse-rounding-mode-bits HEX: 6000
 107 CONSTANT: sse-rounding-mode>bit
 108     $[ H{
 109         { +round-nearest+ HEX: 0000 }
 110         { +round-down+    HEX: 2000 }
 111         { +round-up+      HEX: 4000 }
 112         { +round-zero+    HEX: 6000 }
 113     } >biassoc ]
 114
 115 CONSTANT: sse-denormal-mode-bits HEX: 8040
 116
 117 M: sse-env (get-exception-flags) ( register -- exceptions )
 118     mxcsr>> sse-exception-flag>bit mask> ; inline
 119 M: sse-env (set-exception-flags) ( register exceptions -- register' )
 120     [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
 121
 122 M: sse-env (get-fp-traps) ( register -- exceptions )
 123     mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
 124 M: sse-env (set-fp-traps) ( register exceptions -- register' )
 125     [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
 126
 127 M: sse-env (get-rounding-mode) ( register -- mode )
 128     mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
 129 M: sse-env (set-rounding-mode) ( register mode -- register' )
 130     [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
 131
 132 M: sse-env (get-denormal-mode) ( register -- mode )
 133     mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
 134 M: sse-env (set-denormal-mode) ( register mode -- register' )
 135     [
 136         {
 137             { +denormal-keep+  [ sse-denormal-mode-bits unmask ] }
 138             { +denormal-flush+ [ sse-denormal-mode-bits bitor  ] }
 139         } case
 140     ] curry change-mxcsr ; inline
 141
 142 CONSTANT: x87-exception-bits HEX: 3f
 143 CONSTANT: x87-exception>bit
 144     H{
 145         { +fp-invalid-operation+ HEX: 01 }
 146         { +fp-overflow+          HEX: 08 }
 147         { +fp-underflow+         HEX: 10 }
 148         { +fp-zero-divide+       HEX: 04 }
 149         { +fp-inexact+           HEX: 20 }
 150     }
 151
 152 CONSTANT: x87-rounding-mode-bits HEX: 0c00
 153 CONSTANT: x87-rounding-mode>bit
 154     $[ H{
 155         { +round-nearest+ HEX: 0000 }
 156         { +round-down+    HEX: 0400 }
 157         { +round-up+      HEX: 0800 }
 158         { +round-zero+    HEX: 0c00 }
 159     } >biassoc ]
 160
 161 M: x87-env (get-exception-flags) ( register -- exceptions )
 162     status>> x87-exception>bit mask> ; inline
 163 M: x87-env (set-exception-flags) ( register exceptions -- register' )
 164     drop ;
 165
 166 M: x87-env (get-fp-traps) ( register -- exceptions )
 167     control>> bitnot x87-exception>bit mask> ; inline
 168 M: x87-env (set-fp-traps) ( register exceptions -- register' )
 169     [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
 170
 171 M: x87-env (get-rounding-mode) ( register -- mode )
 172     control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
 173 M: x87-env (set-rounding-mode) ( register mode -- register' )
 174     [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
 175
 176 M: x87-env (get-denormal-mode) ( register -- mode )
 177     drop +denormal-keep+ ; inline
 178 M: x87-env (set-denormal-mode) ( register mode -- register' )
 179     drop ;
 180