basis/math/floats/env/ppc/ppc.factor

   1 USING: accessors alien alien.c-types alien.syntax arrays assocs
   2 biassocs classes.struct combinators kernel literals math
   3 math.bitwise math.floats.env math.floats.env.private system
   4 cpu.ppc.assembler ;
   5 IN: math.floats.env.ppc
   6
   7 STRUCT: ppc-fpu-env
   8     { padding uint }
   9     { fpscr uint } ;
  10
  11 STRUCT: ppc-vmx-env
  12     { vscr uint } ;
  13
  14 : get_ppc_fpu_env ( env -- )
  15     void { void* } cdecl [
  16         0 MFFS
  17         0 3 0 STFD
  18     ] alien-assembly ;
  19
  20 : set_ppc_fpu_env ( env -- )
  21     void { void* } cdecl [
  22         0 3 0 LFD
  23         0xff 0 0 0 MTFSF
  24     ] alien-assembly ;
  25
  26 : get_ppc_vmx_env ( env -- )
  27     void { void* } cdecl [
  28         0 MFVSCR
  29         4 1 16 SUBI
  30         5 0xf LI
  31         4 4 5 ANDC
  32         0 0 4 STVXL
  33         5 0xc LI
  34         6 5 4 LWZX
  35         6 3 0 STW
  36     ] alien-assembly ;
  37
  38 : set_ppc_vmx_env ( env -- )
  39     void { void* } cdecl [
  40         3 1 16 SUBI
  41         5 0xf LI
  42         4 4 5 ANDC
  43         5 0xc LI
  44         6 3 0 LWZ
  45         6 5 4 STWX
  46         0 0 4 LVXL
  47         0 MTVSCR
  48     ] alien-assembly ;
  49
  50 : <ppc-fpu-env> ( -- ppc-fpu-env )
  51     ppc-fpu-env (struct)
  52     [ get_ppc_fpu_env ] keep ;
  53
  54 : <ppc-vmx-env> ( -- ppc-fpu-env )
  55     ppc-vmx-env (struct)
  56     [ get_ppc_vmx_env ] keep ;
  57
  58 M: ppc-fpu-env (set-fp-env-register)
  59     set_ppc_fpu_env ;
  60
  61 M: ppc-vmx-env (set-fp-env-register)
  62     set_ppc_vmx_env ;
  63
  64 M: ppc (fp-env-registers)
  65     <ppc-fpu-env> 1array ;
  66
  67 CONSTANT: ppc-exception-flag-bits 0xfff8,0700
  68 CONSTANT: ppc-exception-flag>bit
  69     H{
  70         { +fp-invalid-operation+ 0x2000,0000 }
  71         { +fp-overflow+          0x1000,0000 }
  72         { +fp-underflow+         0x0800,0000 }
  73         { +fp-zero-divide+       0x0400,0000 }
  74         { +fp-inexact+           0x0200,0000 }
  75     }
  76
  77 CONSTANT: ppc-fp-traps-bits 0xf8
  78 CONSTANT: ppc-fp-traps>bit
  79     H{
  80         { +fp-invalid-operation+ 0x80 }
  81         { +fp-overflow+          0x40 }
  82         { +fp-underflow+         0x20 }
  83         { +fp-zero-divide+       0x10 }
  84         { +fp-inexact+           0x08 }
  85     }
  86
  87 CONSTANT: ppc-rounding-mode-bits 0x3
  88 CONSTANT: ppc-rounding-mode>bit
  89     $[ H{
  90         { +round-nearest+ 0x0 }
  91         { +round-zero+    0x1 }
  92         { +round-up+      0x2 }
  93         { +round-down+    0x3 }
  94     } >biassoc ]
  95
  96 CONSTANT: ppc-denormal-mode-bits 0x4
  97
  98 M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
  99     fpscr>> ppc-exception-flag>bit mask> ; inline
 100 M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
 101     [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
 102
 103 M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
 104     fpscr>> ppc-fp-traps>bit mask> ; inline
 105 M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
 106     [ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
 107
 108 M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
 109     fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
 110 M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
 111     [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpscr ; inline
 112
 113 M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
 114     fpscr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
 115 M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
 116     [
 117         {
 118             { +denormal-keep+  [ ppc-denormal-mode-bits unmask ] }
 119             { +denormal-flush+ [ ppc-denormal-mode-bits bitor  ] }
 120         } case
 121     ] curry change-fpscr ; inline
 122
 123 CONSTANT: vmx-denormal-mode-bits 0x10000
 124
 125 M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
 126     drop { } ; inline
 127 M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
 128     drop ;
 129
 130 M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
 131     drop { } ; inline
 132 M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
 133     drop ;
 134
 135 M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
 136     drop +round-nearest+ ;
 137 M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
 138     drop ;
 139
 140 M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
 141     vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
 142 M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
 143     [
 144         {
 145             { +denormal-keep+  [ vmx-denormal-mode-bits unmask ] }
 146             { +denormal-flush+ [ vmx-denormal-mode-bits bitor  ] }
 147         } case
 148     ] curry change-vscr ; inline
 149