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

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