1 ! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
2 ! See http://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 ;
10 QUALIFIED: alien.accessors
11 QUALIFIED: alien.c-types
12 QUALIFIED: alien.data.private
14 QUALIFIED: byte-arrays
15 QUALIFIED: classes.tuple.private
17 QUALIFIED: kernel.private
18 QUALIFIED: math.bitwise.private
19 QUALIFIED: math.floats.private
20 QUALIFIED: math.integers.private
22 QUALIFIED: math.private
23 QUALIFIED: slots.private
24 QUALIFIED: strings.private
25 IN: compiler.cfg.intrinsics
27 ERROR: inline-intrinsics-not-supported word quot ;
29 : enable-intrinsics ( alist -- )
31 over inline? [ throw-inline-intrinsics-not-supported ] when
32 "intrinsic" set-word-prop
36 { kernel.private:tag [ drop emit-tag ] }
37 { kernel.private:context-object [ emit-context-object ] }
38 { kernel.private:special-object [ emit-special-object ] }
39 { kernel.private:set-special-object [ emit-set-special-object ] }
40 { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
41 { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
42 { math.private:fixnum+ [ drop emit-fixnum+ ] }
43 { math.private:fixnum- [ drop emit-fixnum- ] }
44 { math.private:fixnum* [ drop emit-fixnum* ] }
45 { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
46 { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
47 { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
48 { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
49 { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
50 { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
51 { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
52 { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
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 { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
57 { kernel:eq? [ emit-eq ] }
58 { slots.private:slot [ emit-slot ] }
59 { slots.private:set-slot [ emit-set-slot ] }
60 { strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
61 { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
62 { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
63 { arrays:<array> [ emit-<array> ] }
64 { byte-arrays:<byte-array> [ emit-<byte-array> ] }
65 { byte-arrays:(byte-array) [ emit-(byte-array) ] }
66 { kernel:<wrapper> [ emit-simple-allot ] }
67 { alien.data.private:(local-allot) [ emit-local-allot ] }
68 { alien.data.private:(cleanup-allot) [ drop emit-cleanup-allot ] }
69 { alien:<displaced-alien> [ emit-<displaced-alien> ] }
70 { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
71 { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
72 { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
73 { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
74 { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
75 { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
76 { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
77 { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
78 { alien.accessors:alien-cell [ emit-alien-cell ] }
79 { alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
82 : enable-alien-4-intrinsics ( -- )
84 { alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
85 { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
86 { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
87 { alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
90 : enable-float-intrinsics ( -- )
92 { math.private:float+ [ drop [ ^^add-float ] binary-op ] }
93 { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
94 { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
95 { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
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> [ drop cc> emit-float-ordered-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-u> [ drop cc> emit-float-unordered-comparison ] }
104 { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
105 { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
106 { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
107 { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
108 { alien.accessors:alien-float [ float-rep f emit-load-memory ] }
109 { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
110 { alien.accessors:alien-double [ double-rep f emit-load-memory ] }
111 { alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
112 } enable-intrinsics ;
114 : enable-fsqrt ( -- )
116 { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
117 } enable-intrinsics ;
119 : enable-float-min/max ( -- )
121 { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
122 { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
123 } enable-intrinsics ;
125 : enable-min/max ( -- )
127 { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
128 { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
129 } enable-intrinsics ;
133 { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
134 } enable-intrinsics ;
136 : enable-bit-count ( -- )
138 { math.bitwise.private:fixnum-bit-count [ drop [ ^^bit-count ] unary-op ] }
139 } enable-intrinsics ;
141 : enable-bit-test ( -- )
143 { math.integers.private:fixnum-bit? [ drop [ ^^bit-test ] binary-op ] }
144 } enable-intrinsics ;
146 : emit-intrinsic ( node word -- )
147 "intrinsic" word-prop call( node -- ) ;