basis/math/vectors/conversion/conversion.factor

   1 ! (c)Joe Groff bsd license
   2 USING: accessors alien arrays assocs classes combinators
   3 combinators.short-circuit fry kernel locals math math.vectors
   4 math.vectors.simd math.vectors.simd.intrinsics sequences ;
   5 FROM: alien.c-types =>
   6     char uchar short ushort int uint longlong ulonglong
   7     float double heap-size ;
   8 IN: math.vectors.conversion
   9
  10 ERROR: bad-vconvert from-type to-type ;
  11 ERROR: bad-vconvert-input value expected-type ;
  12
  13 <PRIVATE
  14
  15 : float-type? ( c-type -- ? )
  16     { float double } member-eq? ;
  17 : unsigned-type? ( c-type -- ? )
  18     { uchar ushort uint ulonglong } member-eq? ;
  19
  20 : check-vconvert-type ( value expected-type -- value )
  21     2dup instance? [ drop ] [ throw-bad-vconvert-input ] if ; inline
  22
  23 :: [vconvert] ( from-element to-element from-size to-size from-type to-type -- quot )
  24     {
  25         {
  26             [ from-element to-element eq? ]
  27             [ [ ] ]
  28         }
  29         {
  30             [ from-element to-element [ float-type? not ] both? ]
  31             [ [ underlying>> to-type boa ] ]
  32         }
  33         {
  34             [ from-element float-type? ]
  35             [ from-type new simd-rep '[ underlying>> _ (simd-v>integer) to-type boa ] ]
  36         }
  37         {
  38             [ to-element   float-type? ]
  39             [ from-type new simd-rep '[ underlying>> _ (simd-v>float)   to-type boa ] ]
  40         }
  41     } cond
  42     [ from-type check-vconvert-type ] prepose ;
  43
  44 :: check-vpack ( from-element to-element from-type to-type steps -- )
  45     {
  46         [ steps 1 = not ]
  47         [ from-element to-element [ float-type? ] bi@ xor ]
  48         [ from-element unsigned-type? to-element unsigned-type? not and ]
  49     } 0|| [ from-type to-type throw-bad-vconvert ] when ;
  50
  51 :: ([vpack-unsigned]) ( from-type to-type -- quot )
  52     from-type new simd-rep
  53     '[
  54         [ from-type check-vconvert-type underlying>> ] bi@
  55         _ (simd-vpack-unsigned) to-type boa
  56     ] ;
  57
  58 :: ([vpack-signed]) ( from-type to-type -- quot )
  59     from-type new simd-rep
  60     '[
  61         [ from-type check-vconvert-type underlying>> ] bi@
  62         _ (simd-vpack-signed)   to-type boa
  63     ] ;
  64
  65 :: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
  66     from-size to-size /i log2 :> steps
  67
  68     from-element to-element from-type to-type steps check-vpack
  69
  70     from-type to-type to-element unsigned-type?
  71     [ ([vpack-unsigned]) ] [ ([vpack-signed]) ] if ;
  72
  73 :: check-vunpack ( from-element to-element from-type to-type steps -- )
  74     {
  75         [ steps 1 = not ]
  76         [ from-element to-element [ float-type? ] bi@ xor ]
  77         [ from-element unsigned-type? not to-element unsigned-type? and ]
  78     } 0|| [ from-type to-type throw-bad-vconvert ] when ;
  79
  80 :: ([vunpack]) ( from-type to-type -- quot )
  81     from-type new simd-rep
  82     '[
  83         from-type check-vconvert-type underlying>> _
  84         [ (simd-vunpack-head) to-type boa ]
  85         [ (simd-vunpack-tail) to-type boa ] 2bi
  86     ] ;
  87
  88 :: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
  89     to-size from-size /i log2 :> steps
  90     from-element to-element from-type to-type steps check-vunpack
  91     from-type to-type ([vunpack]) ;
  92
  93 PRIVATE>
  94
  95 MACRO:: vconvert ( from-type to-type -- quot )
  96     from-type new [ simd-element-type ] [ byte-length ] bi :> ( from-element from-length )
  97     to-type   new [ simd-element-type ] [ byte-length ] bi :> ( to-element   to-length   )
  98     from-element heap-size :> from-size
  99     to-element   heap-size :> to-size
 100
 101     from-length to-length = [ from-type to-type throw-bad-vconvert ] unless
 102
 103     from-element to-element from-size to-size from-type to-type {
 104         { [ from-size to-size < ] [ [vunpack] ] }
 105         { [ from-size to-size = ] [ [vconvert] ] }
 106         { [ from-size to-size > ] [ [vpack] ] }
 107     } cond ;