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

   1 USING: accessors alien.syntax 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 ;
   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 ! defined in the vm, cpu-x86*.S
  15 FUNCTION: void get_sse_env ( sse-env* env ) ;
  16 FUNCTION: void set_sse_env ( sse-env* env ) ;
  17
  18 FUNCTION: void get_x87_env ( x87-env* env ) ;
  19 FUNCTION: void set_x87_env ( x87-env* env ) ;
  20
  21 : <sse-env> ( -- sse-env )
  22     sse-env (struct) [ get_sse_env ] keep ;
  23
  24 M: sse-env (set-fp-env-register)
  25     set_sse_env ;
  26
  27 : <x87-env> ( -- x87-env )
  28     x87-env (struct) [ get_x87_env ] keep ;
  29
  30 M: x87-env (set-fp-env-register)
  31     set_x87_env ;
  32
  33 M: x86 (fp-env-registers)
  34     sse-version 20 >=
  35     [ <sse-env> <x87-env> 2array ]
  36     [ <x87-env> 1array ] if ;
  37
  38 CONSTANT: sse-exception-flag-bits HEX: 3f
  39 CONSTANT: sse-exception-flag>bit
  40     H{
  41         { +fp-invalid-operation+ HEX: 01 }
  42         { +fp-overflow+          HEX: 08 }
  43         { +fp-underflow+         HEX: 10 }
  44         { +fp-zero-divide+       HEX: 04 }
  45         { +fp-inexact+           HEX: 20 }
  46     }
  47
  48 CONSTANT: sse-fp-traps-bits HEX: 1f80
  49 CONSTANT: sse-fp-traps>bit
  50     H{
  51         { +fp-invalid-operation+ HEX: 0080 }
  52         { +fp-overflow+          HEX: 0400 }
  53         { +fp-underflow+         HEX: 0800 }
  54         { +fp-zero-divide+       HEX: 0200 }
  55         { +fp-inexact+           HEX: 1000 }
  56     }
  57
  58 CONSTANT: sse-rounding-mode-bits HEX: 6000
  59 CONSTANT: sse-rounding-mode>bit
  60     $[ H{
  61         { +round-nearest+ HEX: 0000 }
  62         { +round-down+    HEX: 2000 }
  63         { +round-up+      HEX: 4000 }
  64         { +round-zero+    HEX: 6000 }
  65     } >biassoc ]
  66
  67 CONSTANT: sse-denormal-mode-bits HEX: 8040
  68
  69 M: sse-env (get-exception-flags) ( register -- exceptions )
  70     mxcsr>> sse-exception-flag>bit mask> ; inline
  71 M: sse-env (set-exception-flags) ( register exceptions -- register' )
  72     [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
  73
  74 M: sse-env (get-fp-traps) ( register -- exceptions )
  75     mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
  76 M: sse-env (set-fp-traps) ( register exceptions -- register' )
  77     [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
  78
  79 M: sse-env (get-rounding-mode) ( register -- mode )
  80     mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
  81 M: sse-env (set-rounding-mode) ( register mode -- register' )
  82     [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
  83
  84 M: sse-env (get-denormal-mode) ( register -- mode )
  85     mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
  86 M: sse-env (set-denormal-mode) ( register mode -- register' )
  87     [
  88         {
  89             { +denormal-keep+  [ sse-denormal-mode-bits unmask ] }
  90             { +denormal-flush+ [ sse-denormal-mode-bits bitor  ] }
  91         } case
  92     ] curry change-mxcsr ; inline
  93
  94 CONSTANT: x87-exception-bits HEX: 3f
  95 CONSTANT: x87-exception>bit
  96     H{
  97         { +fp-invalid-operation+ HEX: 01 }
  98         { +fp-overflow+          HEX: 08 }
  99         { +fp-underflow+         HEX: 10 }
 100         { +fp-zero-divide+       HEX: 04 }
 101         { +fp-inexact+           HEX: 20 }
 102     }
 103
 104 CONSTANT: x87-rounding-mode-bits HEX: 0c00
 105 CONSTANT: x87-rounding-mode>bit
 106     $[ H{
 107         { +round-nearest+ HEX: 0000 }
 108         { +round-down+    HEX: 0400 }
 109         { +round-up+      HEX: 0800 }
 110         { +round-zero+    HEX: 0c00 }
 111     } >biassoc ]
 112
 113 M: x87-env (get-exception-flags) ( register -- exceptions )
 114     status>> x87-exception>bit mask> ; inline
 115 M: x87-env (set-exception-flags) ( register exceptions -- register' )
 116     drop ;
 117
 118 M: x87-env (get-fp-traps) ( register -- exceptions )
 119     control>> bitnot x87-exception>bit mask> ; inline
 120 M: x87-env (set-fp-traps) ( register exceptions -- register' )
 121     [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
 122
 123 M: x87-env (get-rounding-mode) ( register -- mode )
 124     control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
 125 M: x87-env (set-rounding-mode) ( register mode -- register' )
 126     [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
 127
 128 M: x87-env (get-denormal-mode) ( register -- mode )
 129     drop +denormal-keep+ ; inline
 130 M: x87-env (set-denormal-mode) ( register mode -- register' )
 131     drop ;
 132