basis/compiler/cfg/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: assocs compiler.cfg.comparisons compiler.cfg.hats
   4 compiler.cfg.intrinsics.alien compiler.cfg.intrinsics.allot
   5 compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float
   6 compiler.cfg.intrinsics.misc compiler.cfg.intrinsics.slots
   7 compiler.cfg.intrinsics.strings compiler.cfg.stacks
   8 cpu.architecture kernel words ;
   9 QUALIFIED: alien
  10 QUALIFIED: alien.accessors
  11 QUALIFIED: alien.c-types
  12 QUALIFIED: alien.data.private
  13 QUALIFIED: arrays
  14 QUALIFIED: byte-arrays
  15 QUALIFIED: classes.tuple.private
  16 QUALIFIED: kernel.private
  17 QUALIFIED: math.bitwise.private
  18 QUALIFIED: math.floats.private
  19 QUALIFIED: math.integers.private
  20 QUALIFIED: math.libm
  21 QUALIFIED: math.private
  22 QUALIFIED: slots.private
  23 QUALIFIED: strings.private
  24 IN: compiler.cfg.intrinsics
  25
  26 ERROR: inline-intrinsics-not-supported word quot ;
  27
  28 : enable-intrinsics ( alist -- )
  29     [
  30         over inline? [ inline-intrinsics-not-supported ] when
  31         "intrinsic" set-word-prop
  32     ] assoc-each ;
  33
  34 {
  35     { kernel.private:tag [ drop emit-tag ] }
  36     { kernel.private:context-object [ emit-context-object ] }
  37     { kernel.private:special-object [ emit-special-object ] }
  38     { kernel.private:set-special-object [ emit-set-special-object ] }
  39     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
  40     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
  41     { math.private:fixnum+ [ drop emit-fixnum+ ] }
  42     { math.private:fixnum- [ drop emit-fixnum- ] }
  43     { math.private:fixnum* [ drop emit-fixnum* ] }
  44     { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
  45     { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
  46     { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
  47     { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
  48     { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
  49     { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
  50     { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
  51     { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
  52     { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
  53     { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
  54     { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
  55     { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
  56     { kernel:eq? [ emit-eq ] }
  57     { slots.private:slot [ emit-slot ] }
  58     { slots.private:set-slot [ emit-set-slot ] }
  59     { strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
  60     { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
  61     { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
  62     { arrays:<array> [ emit-<array> ] }
  63     { byte-arrays:<byte-array> [ emit-<byte-array> ] }
  64     { byte-arrays:(byte-array) [ emit-(byte-array) ] }
  65     { kernel:<wrapper> [ emit-simple-allot ] }
  66     { alien.data.private:local-allot [ emit-local-allot ] }
  67     { alien.data.private:cleanup-allot [ emit-cleanup-allot ] }
  68     { alien:<displaced-alien> [ emit-<displaced-alien> ] }
  69     { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
  70     { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
  71     { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
  72     { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
  73     { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
  74     { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
  75     { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
  76     { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
  77     { alien.accessors:alien-cell [ emit-alien-cell ] }
  78     { alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
  79 } enable-intrinsics
  80
  81 : enable-alien-4-intrinsics ( -- )
  82     {
  83         { alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
  84         { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
  85         { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
  86         { alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
  87     } enable-intrinsics ;
  88
  89 : enable-float-intrinsics ( -- )
  90     {
  91         { math.private:float+ [ drop [ ^^add-float ] binary-op ] }
  92         { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
  93         { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
  94         { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
  95         { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
  96         { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
  97         { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
  98         { math.private:float> [ drop cc> emit-float-ordered-comparison ] }
  99         { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
 100         { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
 101         { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
 102         { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
 103         { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
 104         { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
 105         { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
 106         { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
 107         { alien.accessors:alien-float [ float-rep f emit-load-memory ] }
 108         { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
 109         { alien.accessors:alien-double [ double-rep f emit-load-memory ] }
 110         { alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
 111     } enable-intrinsics ;
 112
 113 : enable-fsqrt ( -- )
 114     {
 115         { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
 116     } enable-intrinsics ;
 117
 118 : enable-float-min/max ( -- )
 119     {
 120         { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
 121         { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
 122     } enable-intrinsics ;
 123
 124 : enable-min/max ( -- )
 125     {
 126         { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
 127         { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
 128     } enable-intrinsics ;
 129
 130 : enable-log2 ( -- )
 131     {
 132         { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
 133     } enable-intrinsics ;
 134
 135 : enable-bit-count ( -- )
 136     {
 137         { math.bitwise.private:fixnum-bit-count [ drop [ ^^bit-count ] unary-op ] }
 138     } enable-intrinsics ;
 139
 140 : enable-bit-test ( -- )
 141     {
 142         { math.integers.private:fixnum-bit? [ drop [ ^^bit-test ] binary-op ] }
 143     } enable-intrinsics ;