0 | module Core.SchemeEval.Builtins
  1 |
  2 | import Core.SchemeEval.ToScheme
  3 | import Core.TT
  4 |
  5 | import Data.Vect
  6 | import Libraries.Utils.Scheme
  7 |
  8 | -- Integers are wrapped, so unwrap then wrap again
  9 | add : Maybe IntKind -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 10 | add (Just (Signed (P n))) x y = Apply (Var "ct-s+") [x, y, toScheme (n-1)]
 11 | add (Just (Unsigned n)) x y = Apply (Var "ct-u+") [x, y, toScheme n]
 12 | add _ x y = Apply (Var "ct+") [x, y]
 13 |
 14 | sub : Maybe IntKind -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 15 | sub (Just (Signed (P n))) x y = Apply (Var "ct-s-") [x, y, toScheme (n-1)]
 16 | sub (Just (Unsigned n)) x y = Apply (Var "ct-u-") [x, y, toScheme n]
 17 | sub _ x y = Apply (Var "ct-") [x, y]
 18 |
 19 | mul : Maybe IntKind -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 20 | mul (Just (Signed (P n))) x y = Apply (Var "ct-s*") [x, y, toScheme (n-1)]
 21 | mul (Just (Unsigned n)) x y = Apply (Var "ct-u*") [x, y, toScheme n]
 22 | mul _ x y = Apply (Var "ct*") [x, y]
 23 |
 24 | div : Maybe IntKind -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 25 | div (Just (Signed Unlimited)) x y = Apply (Var "ct/") [x, y]
 26 | div (Just (Signed (P n))) x y = Apply (Var "ct-s/") [x, y, toScheme (n-1)]
 27 | div (Just (Unsigned n)) x y = Apply (Var "ct-u/") [x, y, toScheme n]
 28 | div _ x y = Apply (Var "ct/") [x, y]
 29 |
 30 | mod : SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 31 | mod x y = Apply (Var "ct-mod") [x, y]
 32 |
 33 | shl : Maybe IntKind -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 34 | shl (Just (Signed (P n))) x y = Apply (Var "ct-bits-shl-signed") [x, y, toScheme (n-1)]
 35 | shl (Just (Unsigned n)) x y = Apply (Var "ct-bits-shl") [x, y, toScheme n]
 36 | shl _ x y = Apply (Var "ct-shl") [x, y]
 37 |
 38 | shr : Maybe IntKind -> SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 39 | shr _ x y = Apply (Var "ct-shr") [x, y]
 40 |
 41 | -- Doubles don't need wrapping, since there's only one double type
 42 | addDbl : SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 43 | addDbl x y = Apply (Var "+") [x, y]
 44 |
 45 | subDbl : SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 46 | subDbl x y = Apply (Var "-") [x, y]
 47 |
 48 | mulDbl : SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 49 | mulDbl x y = Apply (Var "*") [x, y]
 50 |
 51 | divDbl : SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 52 | divDbl x y = Apply (Var "/") [x, y]
 53 |
 54 | -- Check necessary arguments are in canonical form before applying the
 55 | -- operator, otherwise return the blocked form
 56 | -- Current assumption is that all primitives that we can evaluate at
 57 | -- compile time work on constants, if they do anything in Scheme at all.
 58 | canonical : SchemeObj Write ->
 59 |             Vect n (SchemeObj Write) -> SchemeObj Write -> SchemeObj Write
 60 | canonical blk [] body = body
 61 | canonical blk (n :: ns) body
 62 |    = If (Apply (Var "ct-isConstant") [n]) (canonical blk ns body) blk
 63 |
 64 | -- Return blocked application if a partial operator is given an input
 65 | -- on which it's undefined
 66 | testPartial : SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 67 | testPartial blk res
 68 |     = Let "p-0" res $
 69 |           (If (Apply (Var "ct-isConstant") [Var "p-0"])
 70 |               (Var "p-0")
 71 |               blk)
 72 |
 73 | unaryOp : SchemeObj Write -> String ->
 74 |           SchemeObj Write -> SchemeObj Write
 75 | unaryOp blk op x = canonical blk [x] $ Apply (Var op) [x]
 76 |
 77 | binOp : SchemeObj Write -> String ->
 78 |         SchemeObj Write -> SchemeObj Write -> SchemeObj Write
 79 | binOp blk op x y = canonical blk [x, y] $ Apply (Var op) [x, y]
 80 |
 81 | ternaryOp : SchemeObj Write -> String ->
 82 |             SchemeObj Write -> SchemeObj Write -> SchemeObj Write ->
 83 |             SchemeObj Write
 84 | ternaryOp blk op x y z = canonical blk [x, y, z] $ Apply (Var op) [x, y, z]
 85 |
 86 | int : SchemeObj Write -> SchemeObj Write
 87 | int obj = Vector (-100) [obj]
 88 |
 89 | int8 : SchemeObj Write -> SchemeObj Write
 90 | int8 obj = Vector (-101) [obj]
 91 |
 92 | int16 : SchemeObj Write -> SchemeObj Write
 93 | int16 obj = Vector (-102) [obj]
 94 |
 95 | int32 : SchemeObj Write -> SchemeObj Write
 96 | int32 obj = Vector (-103) [obj]
 97 |
 98 | int64 : SchemeObj Write -> SchemeObj Write
 99 | int64 obj = Vector (-104) [obj]
100 |
101 | integer : SchemeObj Write -> SchemeObj Write
102 | integer obj = Vector (-105) [obj]
103 |
104 | bits8 : SchemeObj Write -> SchemeObj Write
105 | bits8 obj = Vector (-106) [obj]
106 |
107 | bits16 : SchemeObj Write -> SchemeObj Write
108 | bits16 obj = Vector (-107) [obj]
109 |
110 | bits32 : SchemeObj Write -> SchemeObj Write
111 | bits32 obj = Vector (-108) [obj]
112 |
113 | bits64 : SchemeObj Write -> SchemeObj Write
114 | bits64 obj = Vector (-109) [obj]
115 |
116 | wrap : IntKind -> SchemeObj Write -> SchemeObj Write
117 | wrap (Signed Unlimited) = integer
118 | wrap (Signed (P 8)) = int8
119 | wrap (Signed (P 16)) = int16
120 | wrap (Signed (P 32)) = int32
121 | wrap (Signed (P 64)) = int64
122 | wrap (Unsigned 8) = bits8
123 | wrap (Unsigned 16) = bits16
124 | wrap (Unsigned 32) = bits32
125 | wrap (Unsigned 64) = bits64
126 | wrap _ = integer
127 |
128 | -- Result has to be wrapped in Int, which is Vector (-100)
129 | boolOp : SchemeObj Write -> String ->
130 |          SchemeObj Write -> SchemeObj Write -> SchemeObj Write
131 | boolOp blk op x y
132 |     = canonical blk [x, y] $
133 |          int $
134 |              Apply (Var "or")
135 |                 [Apply (Var "and") [Apply (Var op) [x, y],
136 |                                     IntegerVal 1],
137 |                  IntegerVal 0]
138 |
139 | applyIntCast : IntKind -> IntKind -> SchemeObj Write -> SchemeObj Write
140 | applyIntCast _ (Signed Unlimited) x = x
141 | applyIntCast (Signed m) k@(Signed (P n)) x
142 |     = if P n >= m
143 |          then x
144 |          else wrap k $ Apply (Var "ct-cast-signed") [x, toScheme (n - 1)]
145 | applyIntCast (Unsigned m) k@(Signed (P n)) x
146 |     = if n > m
147 |          then x
148 |          else wrap k $ Apply (Var "ct-cast-signed") [x, toScheme (n - 1)]
149 | applyIntCast (Signed _) k@(Unsigned n) x
150 |     = wrap k $ Apply (Var "ct-cast-unsigned") [x, toScheme n]
151 | applyIntCast (Unsigned m) (Unsigned n) x
152 |     = if n >= m
153 |          then x
154 |          else Apply (Var "ct-cast-unsigned") [x, toScheme n]
155 |
156 | applyCast : SchemeObj Write ->
157 |             PrimType -> PrimType ->
158 |             SchemeObj Write -> SchemeObj Write
159 | applyCast blk CharType to x
160 |     = canonical blk [x] $
161 |         case intKind to of
162 |            Nothing =>
163 |               case to of
164 |                    StringType => Apply (Var "string") [x]
165 |                    _ => blk
166 |            Just (Signed Unlimited) => integer $ Apply (Var "char->integer") [x]
167 |            Just k@(Signed (P n)) => wrap k $ Apply (Var "ct-cast-char-boundedInt") [x, toScheme (n - 1)]
168 |            Just k@(Unsigned n) => wrap k $ Apply (Var "ct-cast-char-boundedUInt") [x, toScheme n]
169 | applyCast blk from CharType x
170 |     = canonical blk [x] $
171 |         case intKind from of
172 |            Nothing => blk
173 |            Just k => Apply (Var "ct-cast-int-char") [x]
174 | applyCast blk StringType to x
175 |     = canonical blk [x] $
176 |         case intKind to of
177 |            Nothing => case to of
178 |                            DoubleType => Apply (Var "ct-cast-string-double") [x]
179 |                            _ => blk
180 |            Just (Signed Unlimited) => integer $ Apply (Var "ct-cast-string-int") [x]
181 |            Just k@(Signed (P n)) => wrap k $ Apply (Var "ct-cast-string-boundedInt") [x, toScheme (n - 1)]
182 |            Just k@(Unsigned n) => wrap k $ Apply (Var "ct-cast-string-boundedUInt") [x, toScheme n]
183 | applyCast blk from StringType x
184 |     = canonical blk [x] $
185 |         case intKind from of
186 |            Nothing => case from of
187 |                            DoubleType => Apply (Var "number->string") [x]
188 |                            _ => blk
189 |            Just k => Apply (Var "ct-cast-number-string") [x]
190 | applyCast blk DoubleType to x
191 |     = canonical blk [x] $
192 |         case intKind to of
193 |            Nothing => case to of
194 |                            StringType => Apply (Var "number->string") [x]
195 |                            _ => blk
196 |            Just (Signed Unlimited) => integer $ Apply (Var "ct-exact-truncate") [x]
197 |            Just k@(Signed (P n)) => wrap k $ Apply (Var "ct-exact-truncate-boundedInt") [x, toScheme (n - 1)]
198 |            Just k@(Unsigned n) => wrap k $ Apply (Var "ct-exact-truncate-boundedUInt") [x, toScheme n]
199 | applyCast blk from DoubleType x
200 |     = canonical blk [x] $
201 |         case intKind from of
202 |            Nothing => case from of
203 |                            StringType => Apply (Var "ct-cast-string-double") [x]
204 |                            _ => blk
205 |            Just k => Apply (Var "ct-int-double") [x]
206 | applyCast blk from to x
207 |     = canonical blk [x] $
208 |         case (intKind from, intKind to) of
209 |            (Just f, Just t) => applyIntCast f t x
210 |            _ => blk
211 |
212 | applyOp : SchemeObj Write -> -- if we don't have arguments in canonical form
213 |           PrimFn n -> Vect n (SchemeObj Write) ->
214 |           SchemeObj Write
215 | applyOp blk (Add DoubleType) [x, y] = binOp blk "+" x y
216 | applyOp blk (Sub DoubleType) [x, y] = binOp blk "-" x y
217 | applyOp blk (Mul DoubleType) [x, y] = binOp blk "*" x y
218 | applyOp blk (Div DoubleType) [x, y] = binOp blk "/" x y
219 | applyOp blk (Neg DoubleType) [x] = unaryOp blk "-" x
220 | applyOp blk (Add ty) [x, y] = canonical blk [x, y] $ add (intKind ty) x y
221 | applyOp blk (Sub ty) [x, y] = canonical blk [x, y] $ sub (intKind ty) x y
222 | applyOp blk (Mul ty) [x, y] = canonical blk [x, y] $ mul (intKind ty) x y
223 | applyOp blk (Div ty) [x, y] = canonical blk [x, y] $ div (intKind ty) x y
224 | applyOp blk (Mod ty) [x, y] = canonical blk [x, y] $ mod x y
225 | applyOp blk (Neg ty) [x] = canonical blk [x] $ Apply (Var "ct-neg") [x]
226 | applyOp blk (ShiftL ty) [x, y] = canonical blk [x, y] $ shl (intKind ty) x y
227 | applyOp blk (ShiftR ty) [x, y] = canonical blk [x, y] $ shr (intKind ty) x y
228 | applyOp blk (BAnd ty) [x, y] = binOp blk "ct-and" x y
229 | applyOp blk (BOr ty) [x, y] = binOp blk "ct-or" x y
230 | applyOp blk (BXOr ty) [x, y] = binOp blk "ct-xor" x y
231 | applyOp blk (LT CharType) [x, y] = boolOp blk "char<?" x y
232 | applyOp blk (LTE CharType) [x, y] = boolOp blk "char<=?" x y
233 | applyOp blk (EQ CharType) [x, y] = boolOp blk "char=?" x y
234 | applyOp blk (GTE CharType) [x, y] = boolOp blk "char>=?" x y
235 | applyOp blk (GT CharType) [x, y] = boolOp blk "char>?" x y
236 | applyOp blk (LT StringType) [x, y] = boolOp blk "string<?" x y
237 | applyOp blk (LTE StringType) [x, y] = boolOp blk "string<=?" x y
238 | applyOp blk (EQ StringType) [x, y] = boolOp blk "string=?" x y
239 | applyOp blk (GTE StringType) [x, y] = boolOp blk "string>=?" x y
240 | applyOp blk (GT StringType) [x, y] = boolOp blk "string>?" x y
241 | applyOp blk (LT DoubleType) [x, y] = boolOp blk "<" x y
242 | applyOp blk (LTE DoubleType) [x, y] = boolOp blk "<=" x y
243 | applyOp blk (EQ DoubleType) [x, y] = boolOp blk "=" x y
244 | applyOp blk (GTE DoubleType) [x, y] = boolOp blk ">=" x y
245 | applyOp blk (GT DoubleType) [x, y] = boolOp blk ">" x y
246 | applyOp blk (LT ty) [x, y] = boolOp blk "ct<" x y
247 | applyOp blk (LTE ty) [x, y] = boolOp blk "ct<=" x y
248 | applyOp blk (EQ ty) [x, y] = boolOp blk "ct=" x y
249 | applyOp blk (GTE ty) [x, y] = boolOp blk "ct>=" x y
250 | applyOp blk (GT ty) [x, y] = boolOp blk "ct>" x y
251 | applyOp blk StrLength [x]
252 |     = canonical blk [x] $ Vector (-100) [Apply (Var "string-length") [x]]
253 | applyOp blk StrHead [x]
254 |     = canonical blk [x] $ Apply (Var "string-ref")
255 |                                 [x, IntegerVal 0]
256 | applyOp blk StrTail [x]
257 |     = canonical blk [x] $ Apply (Var "substring")
258 |                                 [x, IntegerVal 1,
259 |                                  Apply (Var "string-length") [x]]
260 | applyOp blk StrIndex [x, y]
261 |     = canonical blk [x, y] $ testPartial blk $
262 |          Apply (Var "ct-string-ref") [x, y]
263 | applyOp blk StrCons [x, y]
264 |     = canonical blk [x, y] $ Apply (Var "ct-string-cons") [x, y]
265 | applyOp blk StrAppend [x, y]
266 |     = canonical blk [x, y] $ Apply (Var "string-append") [x, y]
267 | applyOp blk StrReverse [x]
268 |     = canonical blk [x] $ Apply (Var "ct-string-reverse") [x]
269 | applyOp blk StrSubstr [x, y, z]
270 |     = canonical blk [x, y, z] $ Apply (Var "ct-string-substr") [x]
271 |
272 | applyOp blk DoubleExp [x] = unaryOp blk "flexp" x
273 | applyOp blk DoubleLog [x] = unaryOp blk "fllog" x
274 | applyOp blk DoublePow [x, y] = binOp blk "expt" x y
275 | applyOp blk DoubleSin [x] = unaryOp blk "flsin" x
276 | applyOp blk DoubleCos [x] = unaryOp blk "flcos" x
277 | applyOp blk DoubleTan [x] = unaryOp blk "fltan" x
278 | applyOp blk DoubleASin [x] = unaryOp blk "flasin" x
279 | applyOp blk DoubleACos [x] = unaryOp blk "flacos" x
280 | applyOp blk DoubleATan [x] = unaryOp blk "flatan" x
281 | applyOp blk DoubleSqrt [x] = unaryOp blk "flsqrt" x
282 | applyOp blk DoubleFloor [x] = unaryOp blk "flfloor" x
283 | applyOp blk DoubleCeiling [x] = unaryOp blk "flceiling" x
284 |
285 | applyOp blk (Cast from to) [x] = applyCast blk from to x
286 | applyOp blk BelieveMe [_, _, x] = x
287 | applyOp blk Crash [_, msg] = blk
288 |
289 | mkArgList : Int -> (n : Nat) -> Vect n String
290 | mkArgList i Z = []
291 | mkArgList i (S k) = ("x-" ++ show i) :: mkArgList (i + 1) k
292 |
293 | export
294 | compileBuiltin : {farity : Nat} ->
295 |                 Name -> PrimFn farity -> SchemeObj Write
296 | compileBuiltin nm fn
297 |     = let args = mkArgList 0 farity in
298 |           bindArgs args [] args
299 |   where
300 |     makeBlockedApp : Vect n String -> SchemeObj Write
301 |     makeBlockedApp args = Vector (-2) [toScheme nm, vars args]
302 |       where
303 |         vars : forall n . Vect n String -> SchemeObj Write
304 |         vars [] = Null
305 |         vars (x :: xs) = Cons (Var x) (vars xs)
306 |
307 |     bindArgs : Vect n String -> Vect n' String ->
308 |                Vect farity String -> SchemeObj Write
309 |     bindArgs [] done args = applyOp (makeBlockedApp args) fn (map Var args)
310 |     bindArgs (x :: xs) done args
311 |         = Vector (-9) [makeBlockedApp (reverse done),
312 |                        Lambda [x] (bindArgs xs (x :: done) args)]
313 |