basis/compiler/cfg/intrinsics/intrinsics.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: qualified words sequences kernel combinators
   4 cpu.architecture
   5 compiler.cfg.hats
   6 compiler.cfg.instructions
   7 compiler.cfg.intrinsics.alien
   8 compiler.cfg.intrinsics.allot
   9 compiler.cfg.intrinsics.fixnum
  10 compiler.cfg.intrinsics.float
  11 compiler.cfg.intrinsics.slots
  12 compiler.cfg.intrinsics.misc
  13 compiler.cfg.iterator ;
  14 QUALIFIED: kernel
  15 QUALIFIED: arrays
  16 QUALIFIED: byte-arrays
  17 QUALIFIED: kernel.private
  18 QUALIFIED: slots.private
  19 QUALIFIED: strings.private
  20 QUALIFIED: classes.tuple.private
  21 QUALIFIED: math.private
  22 QUALIFIED: math.integers.private
  23 QUALIFIED: alien.accessors
  24 IN: compiler.cfg.intrinsics
  25
  26 {
  27     kernel.private:tag
  28     kernel.private:getenv
  29     math.private:both-fixnums?
  30     math.private:fixnum+
  31     math.private:fixnum-
  32     math.private:fixnum*
  33     math.private:fixnum+fast
  34     math.private:fixnum-fast
  35     math.private:fixnum-bitand
  36     math.private:fixnum-bitor
  37     math.private:fixnum-bitxor
  38     math.private:fixnum-shift-fast
  39     math.private:fixnum-bitnot
  40     math.private:fixnum*fast
  41     math.private:fixnum<
  42     math.private:fixnum<=
  43     math.private:fixnum>=
  44     math.private:fixnum>
  45     math.private:bignum>fixnum
  46     math.private:fixnum>bignum
  47     kernel:eq?
  48     slots.private:slot
  49     slots.private:set-slot
  50     strings.private:string-nth
  51     strings.private:set-string-nth-fast
  52     classes.tuple.private:<tuple-boa>
  53     arrays:<array>
  54     byte-arrays:<byte-array>
  55     byte-arrays:(byte-array)
  56     math.private:<complex>
  57     math.private:<ratio>
  58     kernel:<wrapper>
  59     alien.accessors:alien-unsigned-1
  60     alien.accessors:set-alien-unsigned-1
  61     alien.accessors:alien-signed-1
  62     alien.accessors:set-alien-signed-1
  63     alien.accessors:alien-unsigned-2
  64     alien.accessors:set-alien-unsigned-2
  65     alien.accessors:alien-signed-2
  66     alien.accessors:set-alien-signed-2
  67     alien.accessors:alien-cell
  68     alien.accessors:set-alien-cell
  69 } [ t "intrinsic" set-word-prop ] each
  70
  71 : enable-alien-4-intrinsics ( -- )
  72     {
  73         alien.accessors:alien-unsigned-4
  74         alien.accessors:set-alien-unsigned-4
  75         alien.accessors:alien-signed-4
  76         alien.accessors:set-alien-signed-4
  77     } [ t "intrinsic" set-word-prop ] each ;
  78
  79 : enable-float-intrinsics ( -- )
  80     {
  81         math.private:float+
  82         math.private:float-
  83         math.private:float*
  84         math.private:float/f
  85         math.private:fixnum>float
  86         math.private:float>fixnum
  87         math.private:float<
  88         math.private:float<=
  89         math.private:float>
  90         math.private:float>=
  91         math.private:float=
  92         alien.accessors:alien-float
  93         alien.accessors:set-alien-float
  94         alien.accessors:alien-double
  95         alien.accessors:set-alien-double
  96     } [ t "intrinsic" set-word-prop ] each ;
  97
  98 : enable-fixnum-log2 ( -- )
  99     \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
 100
 101 : emit-intrinsic ( node word -- node/f )
 102     {
 103         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
 104         { \ kernel.private:getenv [ emit-getenv iterate-next ] }
 105         { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
 106         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
 107         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
 108         { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
 109         { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
 110         { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
 111         { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
 112         { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
 113         { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
 114         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
 115         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
 116         { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
 117         { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
 118         { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
 119         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
 120         { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
 121         { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
 122         { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
 123         { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
 124         { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
 125         { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
 126         { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
 127         { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
 128         { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
 129         { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
 130         { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
 131         { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
 132         { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
 133         { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
 134         { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
 135         { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
 136         { \ slots.private:slot [ emit-slot iterate-next ] }
 137         { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
 138         { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
 139         { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
 140         { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
 141         { \ arrays:<array> [ emit-<array> iterate-next ] }
 142         { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
 143         { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
 144         { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
 145         { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
 146         { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
 147         { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
 148         { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
 149         { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
 150         { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
 151         { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
 152         { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
 153         { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
 154         { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
 155         { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
 156         { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
 157         { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
 158         { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
 159         { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
 160         { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
 161         { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
 162         { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
 163         { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
 164         { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
 165     } case ;