basis/compiler/cfg/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: words sequences kernel combinators cpu.architecture assocs
   4 compiler.cfg.hats
   5 compiler.cfg.instructions
   6 compiler.cfg.intrinsics.alien
   7 compiler.cfg.intrinsics.allot
   8 compiler.cfg.intrinsics.fixnum
   9 compiler.cfg.intrinsics.float
  10 compiler.cfg.intrinsics.slots
  11 compiler.cfg.intrinsics.misc
  12 compiler.cfg.comparisons ;
  13 QUALIFIED: alien
  14 QUALIFIED: alien.accessors
  15 QUALIFIED: kernel
  16 QUALIFIED: arrays
  17 QUALIFIED: byte-arrays
  18 QUALIFIED: kernel.private
  19 QUALIFIED: slots.private
  20 QUALIFIED: strings.private
  21 QUALIFIED: classes.tuple.private
  22 QUALIFIED: math.private
  23 QUALIFIED: math.integers.private
  24 QUALIFIED: math.floats.private
  25 QUALIFIED: math.libm
  26 IN: compiler.cfg.intrinsics
  27
  28 : enable-intrinsics ( alist -- )
  29     [ "intrinsic" set-word-prop ] assoc-each ;
  30
  31 {
  32     { kernel.private:tag [ drop emit-tag ] }
  33     { kernel.private:getenv [ emit-getenv ] }
  34     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
  35     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
  36     { math.private:fixnum+ [ drop emit-fixnum+ ] }
  37     { math.private:fixnum- [ drop emit-fixnum- ] }
  38     { math.private:fixnum* [ drop emit-fixnum* ] }
  39     { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
  40     { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
  41     { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
  42     { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
  43     { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
  44     { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
  45     { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
  46     { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
  47     { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
  48     { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
  49     { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
  50     { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
  51     { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
  52     { slots.private:slot [ emit-slot ] }
  53     { slots.private:set-slot [ emit-set-slot ] }
  54     { strings.private:string-nth [ drop emit-string-nth ] }
  55     { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
  56     { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
  57     { arrays:<array> [ emit-<array> ] }
  58     { byte-arrays:<byte-array> [ emit-<byte-array> ] }
  59     { byte-arrays:(byte-array) [ emit-(byte-array) ] }
  60     { kernel:<wrapper> [ emit-simple-allot ] }
  61     { alien:<displaced-alien> [ emit-<displaced-alien> ] }
  62     { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
  63     { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
  64     { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
  65     { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
  66     { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
  67     { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
  68     { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
  69     { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
  70     { alien.accessors:alien-cell [ emit-alien-cell-getter ] }
  71     { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
  72 } enable-intrinsics
  73
  74 : enable-alien-4-intrinsics ( -- )
  75     {
  76         { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
  77         { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
  78         { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
  79         { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
  80     } enable-intrinsics ;
  81
  82 : enable-float-intrinsics ( -- )
  83     {
  84         { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
  85         { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
  86         { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
  87         { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
  88         { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
  89         { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
  90         { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
  91         { math.private:float> [ drop cc> emit-float-ordered-comparison ] }
  92         { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
  93         { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
  94         { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
  95         { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
  96         { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
  97         { math.private:float>fixnum [ drop emit-float>fixnum ] }
  98         { math.private:fixnum>float [ drop emit-fixnum>float ] }
  99         { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
 100         { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
 101         { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
 102         { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
 103         { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
 104     } enable-intrinsics ;
 105
 106 : enable-fsqrt ( -- )
 107     {
 108         { math.libm:fsqrt [ drop emit-fsqrt ] }
 109     } enable-intrinsics ;
 110
 111 : enable-float-min/max ( -- )
 112     {
 113         { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
 114         { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
 115     } enable-intrinsics ;
 116
 117 : enable-float-functions ( -- )
 118     {
 119         { math.libm:facos [ drop "acos" emit-unary-float-function ] }
 120         { math.libm:fasin [ drop "asin" emit-unary-float-function ] }
 121         { math.libm:fatan [ drop "atan" emit-unary-float-function ] }
 122         { math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] }
 123         { math.libm:fcos [ drop "cos" emit-unary-float-function ] }
 124         { math.libm:fsin [ drop "sin" emit-unary-float-function ] }
 125         { math.libm:ftan [ drop "tan" emit-unary-float-function ] }
 126         { math.libm:fcosh [ drop "cosh" emit-unary-float-function ] }
 127         { math.libm:fsinh [ drop "sinh" emit-unary-float-function ] }
 128         { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
 129         { math.libm:fexp [ drop "exp" emit-unary-float-function ] }
 130         { math.libm:flog [ drop "log" emit-unary-float-function ] }
 131         { math.libm:flog10 [ drop "log10" emit-unary-float-function ] }
 132         { math.libm:fpow [ drop "pow" emit-binary-float-function ] }
 133         { math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
 134         { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
 135         { math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
 136         { math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] }
 137         { math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] }
 138         { math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] }
 139         { math.private:float-mod [ drop "fmod" emit-binary-float-function ] }
 140     } enable-intrinsics ;
 141
 142 : enable-min/max ( -- )
 143     {
 144         { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
 145         { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
 146     } enable-intrinsics ;
 147
 148 : enable-fixnum-log2 ( -- )
 149     {
 150         { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
 151     } enable-intrinsics ;
 152
 153 : emit-intrinsic ( node word -- )
 154     "intrinsic" word-prop call( node -- ) ;