git.iko.soy/Idris-dev
on dd09721 help sign in
Idris-dev/src/Idris/Primitives.hs
698 lines 33 kB history raw
1{-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-}
3module Idris.Primitives(primitives, Prim(..)) where
5import Idris.AbsSyntax
7import IRTS.Lang
9import Idris.Core.TT
10import Idris.Core.Evaluate
11import Data.Bits
12import Data.Word
13import Data.Int
14import Data.Char
15import Data.Function (on)
16import Data.Vector.Unboxed (Vector)
17import qualified Data.Vector.Unboxed as V
19data Prim = Prim { p_name :: Name,
20 p_type :: Type,
21 p_arity :: Int,
22 p_def :: [Const] -> Maybe Const,
23 p_lexp :: (Int, PrimFn),
24 p_total :: Totality
25 }
27ty :: [Const] -> Const -> Type
28ty [] x = Constant x
29ty (t:ts) x = Bind (sMN 0 "T") (Pi (Constant t)) (ty ts x)
31total, partial :: Totality
32total = Total []
33partial = Partial NotCovering
35primitives :: [Prim]
36primitives =
37 -- operators
38 [iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt,
39 iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt,
40 iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt,
41 iCoerce (ITFixed IT8) ITBig "zext" zext LZExt,
42 iCoerce (ITFixed IT8) ITNative "zext" zext LZExt,
43 iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt,
44 iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt,
45 iCoerce (ITFixed IT16) ITBig "zext" zext LZExt,
46 iCoerce (ITFixed IT16) ITNative "zext" zext LZExt,
47 iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt,
48 iCoerce (ITFixed IT32) ITBig "zext" zext LZExt,
49 iCoerce (ITFixed IT32) ITNative "zext" zext LZExt,
50 iCoerce (ITFixed IT64) ITBig "zext" zext LZExt,
51 iCoerce ITNative ITBig "zext" zext LZExt,
52 iCoerce ITNative (ITFixed IT64) "zext" zext LZExt,
53 iCoerce ITNative (ITFixed IT32) "zext" zext LZExt,
54 iCoerce ITNative (ITFixed IT16) "zext" zext LZExt,
55 iCoerce ITChar ITBig "zext" zext LZExt,
57 iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt,
58 iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt,
59 iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt,
60 iCoerce (ITFixed IT8) ITBig "sext" sext LSExt,
61 iCoerce (ITFixed IT8) ITNative "sext" sext LSExt,
62 iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt,
63 iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt,
64 iCoerce (ITFixed IT16) ITBig "sext" sext LSExt,
65 iCoerce (ITFixed IT16) ITNative "sext" sext LSExt,
66 iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt,
67 iCoerce (ITFixed IT32) ITBig "sext" sext LSExt,
68 iCoerce (ITFixed IT32) ITNative "sext" sext LSExt,
69 iCoerce (ITFixed IT64) ITBig "sext" sext LSExt,
70 iCoerce ITNative ITBig "sext" sext LSExt,
71 iCoerce ITNative ITBig "sext" sext LSExt,
72 iCoerce ITNative (ITFixed IT64) "sext" sext LSExt,
73 iCoerce ITNative (ITFixed IT32) "sext" sext LSExt,
74 iCoerce ITNative (ITFixed IT16) "sext" sext LSExt,
75 iCoerce ITChar ITBig "sext" sext LSExt,
77 iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc,
78 iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc,
79 iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc,
80 iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc,
81 iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc,
82 iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc,
83 iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc,
84 iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc,
85 iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc,
86 iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc,
87 iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc,
88 iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc,
89 iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc,
90 iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc,
91 iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc,
92 iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc,
93 iCoerce ITBig ITNative "trunc" trunc LTrunc,
94 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,
95 iCoerce ITBig ITChar "trunc" trunc LTrunc,
97 Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))
98 (2, LPlus ATFloat) total,
99 Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))
100 (2, LMinus ATFloat) total,
101 Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))
102 (2, LTimes ATFloat) total,
103 Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))
104 (2, LSDiv ATFloat) total,
105 Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))
106 (2, LEq ATFloat) total,
107 Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))
108 (2, LSLt ATFloat) total,
109 Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))
110 (2, LSLe ATFloat) total,
111 Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))
112 (2, LSGt ATFloat) total,
113 Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))
114 (2, LSGe ATFloat) total,
115 Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))
116 (2, LStrConcat) total,
117 Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))
118 (2, LStrEq) total,
119 Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
120 (2, LStrLt) total,
121 Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
122 (1, LStrLen) total,
123 -- Conversions
124 Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)
125 (1, LChInt ITNative) total,
126 Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)
127 (1, LIntCh ITNative) total,
128 Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)
129 (1, LStrFloat) total,
130 Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)
131 (1, LFloatStr) total,
133 Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)
134 (1, LFExp) total,
135 Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
136 (1, LFLog) total,
137 Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
138 (1, LFSin) total,
139 Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
140 (1, LFCos) total,
141 Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
142 (1, LFTan) total,
143 Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
144 (1, LFASin) total,
145 Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
146 (1, LFACos) total,
147 Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
148 (1, LFATan) total,
149 Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
150 (1, LFSqrt) total,
151 Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
152 (1, LFFloor) total,
153 Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
154 (1, LFCeil) total,
156 Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
157 (1, LStrHead) partial,
158 Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
159 (1, LStrTail) partial,
160 Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
161 (2, LStrCons) total,
162 Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
163 (2, LStrIndex) partial,
164 Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
165 (1, LStrRev) total,
166 Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)
167 (1, LReadStr) partial,
168 Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)
169 (0, LVMPtr) total,
170 -- Streams
171 Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)
172 (0, LStdIn) partial,
173 Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)
174 (0, LNullPtr) total,
175 -- Managed pointer registration
176 Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)
177 (2, LRegisterPtr) total,
178 -- Buffers
179 Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_cantreduce)
180 (1, LAllocate) total,
181 Prim (sUN "prim__appendBuffer") (ty [BufferType, AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), AType (ATInt (ITFixed IT64)), BufferType] BufferType) 6 (p_cantreduce)
182 (6, LAppendBuffer) partial
183 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
184 ++ concatMap vecOps vecTypes
185 ++ concatMap fixedOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64] -- ITNative, ITChar, ATFloat ] ++ vecTypes
186 ++ vecBitcasts vecTypes
188vecTypes :: [IntTy]
189vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]
191intOps :: IntTy -> [Prim]
192intOps ity = intCmps ity ++ intArith ity ++ intConv ity
194intSCmps :: IntTy -> [Prim]
195intSCmps ity =
196 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
197 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
198 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
199 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
200 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
201 ]
203intCmps :: IntTy -> [Prim]
204intCmps ITNative = intSCmps ITNative
205intCmps ity =
206 intSCmps ity ++
207 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
208 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
209 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
210 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
211 ]
213intArith :: IntTy -> [Prim]
214intArith ity =
215 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
216 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
217 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
218 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
219 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
220 , iBinOp ity "urem" (bitBin ity rem) LURem partial
221 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
222 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
223 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
224 , iBinOp ity "ashr" (bashr ity) LASHR total
225 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
226 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
227 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
228 , iUnOp ity "compl" (bUn ity complement) LCompl total
229 ]
231intConv :: IntTy -> [Prim]
232intConv ity =
233 [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
234 (1, LIntStr ity) total
235 , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
236 (1, LStrInt ity) total
237 , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
238 (1, LIntFloat ity) total
239 , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
240 (1, LFloatInt ity) total
241 ]
243vecCmps :: IntTy -> [Prim]
244vecCmps ity =
245 [ iCmp ity "slt" True (bCmp ity (<)) (LSLt . ATInt) total
246 , iCmp ity "slte" True (bCmp ity (<=)) (LSLe . ATInt) total
247 , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total
248 , iCmp ity "sgte" True (bCmp ity (>=)) (LSGe . ATInt) total
249 , iCmp ity "sgt" True (bCmp ity (>)) (LSGt . ATInt) total
250 , iCmp ity "lt" True (bCmp ity (<)) LLt total
251 , iCmp ity "lte" True (bCmp ity (<=)) LLe total
252 , iCmp ity "gte" True (bCmp ity (>=)) LGe total
253 , iCmp ity "gt" True (bCmp ity (>)) LGt total
254 ]
256vecOps :: IntTy -> [Prim]
257vecOps ity@(ITVec elem count) =
258 [ Prim (sUN $ "prim__mk" ++ intTyName ity)
259 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))
260 count (mkVecCon elem count) (count, LMkVec elem count) total
261 , Prim (sUN $ "prim__index" ++ intTyName ity)
262 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))
263 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces
264 , Prim (sUN $ "prim__update" ++ intTyName ity)
265 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]
266 (AType . ATInt $ ity))
267 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces
268 ] ++ intArith ity ++ vecCmps ity
270bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim
271bitcastPrim from to impl prim =
272 Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)
273 (1, prim) total
275vecBitcasts :: [IntTy] -> [Prim]
276vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to)
277 | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to]
279fixedOps :: IntTy -> [Prim]
280fixedOps ity@(ITFixed _) =
281 map appendFun endiannesses ++
282 map peekFun endiannesses
283 where
284 endiannesses = [ Native, LE, BE ]
285 tyName = intTyName ity
286 b64 = AType (ATInt (ITFixed IT64))
287 thisTy = AType $ ATInt ity
288 appendFun en = Prim (sUN $ "prim__append" ++ tyName ++ show en)
289 (ty [BufferType, b64, b64, thisTy] BufferType)
290 4 (p_cantreduce) (4, LAppend ity en) partial
291 peekFun en = Prim (sUN $ "prim__peek" ++ tyName ++ show en)
292 (ty [BufferType, b64] thisTy)
293 2 (p_cantreduce) (2, LPeek ity en) partial
295mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b
296mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))
298mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b
299mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2)))
301concatWord8 :: (Word8, Word8) -> Word16
302concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8)
304concatWord16 :: (Word16, Word16) -> Word32
305concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16)
307concatWord32 :: (Word32, Word32) -> Word64
308concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32)
310truncWord16 :: Bool -> Word16 -> Word8
311truncWord16 True x = fromIntegral (x `shiftR` 8)
312truncWord16 False x = fromIntegral x
314truncWord32 :: Bool -> Word32 -> Word16
315truncWord32 True x = fromIntegral (x `shiftR` 16)
316truncWord32 False x = fromIntegral x
318truncWord64 :: Bool -> Word64 -> Word32
319truncWord64 True x = fromIntegral (x `shiftR` 32)
320truncWord64 False x = fromIntegral x
322bitcastVec :: ArithTy -> [Const] -> Maybe Const
323bitcastVec (ATInt (ITVec IT8 n)) [x@(B8V v)]
324 | V.length v == n = Just x
325bitcastVec (ATInt (ITVec IT16 n)) [B8V v]
326 | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v
327bitcastVec (ATInt (ITVec IT32 n)) [B8V v]
328 | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v
329bitcastVec (ATInt (ITVec IT64 n)) [B8V v]
330 | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v
332bitcastVec (ATInt (ITVec IT8 n)) [B16V v]
333 | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v
334bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)]
335 | V.length v == n = Just x
336bitcastVec (ATInt (ITVec IT32 n)) [B16V v]
337 | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v
338bitcastVec (ATInt (ITVec IT64 n)) [B16V v]
339 | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v
341bitcastVec (ATInt (ITVec IT8 n)) [B32V v]
342 | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v
343bitcastVec (ATInt (ITVec IT16 n)) [B32V v]
344 | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v
345bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)]
346 | V.length v == n = Just x
347bitcastVec (ATInt (ITVec IT64 n)) [B32V v]
348 | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v
350bitcastVec (ATInt (ITVec IT8 n)) [B64V v]
351 | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v
352bitcastVec (ATInt (ITVec IT16 n)) [B64V v]
353 | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v
354bitcastVec (ATInt (ITVec IT32 n)) [B64V v]
355 | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v
356bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)]
357 | V.length v == n = Just x
359bitcastVec _ _ = Nothing
361mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const
362mkVecCon ity count args
363 | length ints == count = Just (mkVec ity count ints)
364 | otherwise = Nothing
365 where
366 ints = getInt args
367 mkVec :: NativeTy -> Int -> [Integer] -> Const
368 mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))
369 mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))
370 mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))
371 mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))
373mkVecIndex count [vec, B32 i] = Just (idxVec vec)
374 where
375 idxVec :: Const -> Const
376 idxVec (B8V v) = B8 $ V.unsafeIndex v (fromIntegral i)
377 idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i)
378 idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i)
379 idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i)
380mkVecIndex _ _ = Nothing
382mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem
383 where
384 updateVec :: Const -> Const -> Maybe Const
385 updateVec (B8V v) (B8 e) = Just . B8V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
386 updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
387 updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
388 updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
389 updateVec _ _ = Nothing
390mkVecUpdate _ _ _ = Nothing
392aTyName :: ArithTy -> String
393aTyName (ATInt t) = intTyName t
394aTyName ATFloat = "Float"
396iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
397iCmp ity op self impl irop totality
398 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
399 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
400 2 impl (2, irop ity) totality
402iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
403iBinOp ity op impl irop totality
404 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
405 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
406 2 impl (2, irop ity) totality
407iUnOp ity op impl irop totality
408 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
409 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
410 1 impl (1, irop ity) totality
412iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
413iCoerce from to op impl irop =
414 Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
415 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
417fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
418fBin op [Fl x, Fl y] = Just $ Fl (op x y)
419fBin _ _ = Nothing
421bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
422bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
423 Just $ I i
424bfBin _ _ = Nothing
426bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const
427bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in
428 Just $ I i
429bcBin _ _ = Nothing
431bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
432bsBin op [Str x, Str y]
433 = let i = (if op x y then 1 else 0) in
434 Just $ I i
435bsBin _ _ = Nothing
437sBin :: (String -> String -> String) -> [Const] -> Maybe Const
438sBin op [Str x, Str y] = Just $ Str (op x y)
439sBin _ _ = Nothing
441bsrem :: IntTy -> [Const] -> Maybe Const
442bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
443bsrem (ITFixed IT8) [B8 x, B8 y]
444 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
445bsrem (ITFixed IT16) [B16 x, B16 y]
446 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
447bsrem (ITFixed IT32) [B32 x, B32 y]
448 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
449bsrem (ITFixed IT64) [B64 x, B64 y]
450 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
451bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
452bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
453bsrem (ITVec IT8 _) [B8V x, B8V y]
454 = Just . B8V $
455 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8))) x y
456bsrem (ITVec IT16 _) [B16V x, B16V y]
457 = Just . B16V $
458 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y
459bsrem (ITVec IT32 _) [B32V x, B32V y]
460 = Just . B32V $
461 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
462bsrem (ITVec IT64 _) [B64V x, B64V y]
463 = Just . B64V $
464 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
465bsrem _ _ = Nothing
467bsdiv :: IntTy -> [Const] -> Maybe Const
468bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y
469bsdiv (ITFixed IT8) [B8 x, B8 y]
470 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
471bsdiv (ITFixed IT16) [B16 x, B16 y]
472 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
473bsdiv (ITFixed IT32) [B32 x, B32 y]
474 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
475bsdiv (ITFixed IT64) [B64 x, B64 y]
476 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
477bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
478bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))
479bsdiv (ITVec IT8 _) [B8V x, B8V y]
480 = Just . B8V $
481 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8))) x y
482bsdiv (ITVec IT16 _) [B16V x, B16V y]
483 = Just . B16V $
484 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y
485bsdiv (ITVec IT32 _) [B32V x, B32V y]
486 = Just . B32V $
487 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
488bsdiv (ITVec IT64 _) [B64V x, B64V y]
489 = Just . B64V $
490 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
491bsdiv _ _ = Nothing
493bashr :: IntTy -> [Const] -> Maybe Const
494bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
495bashr (ITFixed IT8) [B8 x, B8 y]
496 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
497bashr (ITFixed IT16) [B16 x, B16 y]
498 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
499bashr (ITFixed IT32) [B32 x, B32 y]
500 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
501bashr (ITFixed IT64) [B64 x, B64 y]
502 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
503bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
504bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
505bashr (ITVec IT8 _) [B8V x, B8V y]
506 = Just . B8V $
507 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8))) x y
508bashr (ITVec IT16 _) [B16V x, B16V y]
509 = Just . B16V $
510 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y
511bashr (ITVec IT32 _) [B32V x, B32V y]
512 = Just . B32V $
513 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
514bashr (ITVec IT64 _) [B64V x, B64V y]
515 = Just . B64V $
516 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
517bashr _ _ = Nothing
519bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
520bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
521bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
522bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
523bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
524bUn ITBig op [BI x] = Just $ BI (op x)
525bUn ITNative op [I x] = Just $ I (op x)
526bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
527bUn (ITVec IT8 _) op [B8V x] = Just . B8V $ V.map op x
528bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x
529bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x
530bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x
531bUn _ _ _ = Nothing
533bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
534bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
535bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
536bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
537bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
538bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
539bitBin ITNative op [I x, I y] = Just $ I (op x y)
540bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
541bitBin (ITVec IT8 _) op [B8V x, B8V y] = Just . B8V $ V.zipWith op x y
542bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y
543bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y
544bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y
545bitBin _ _ _ = Nothing
547bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
548bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
549bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
550bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
551bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
552bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
553bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
554bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
555bCmp (ITVec IT8 _) op [B8V x, B8V y]
556 = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
557bCmp (ITVec IT16 _) op [B16V x, B16V y]
558 = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
559bCmp (ITVec IT32 _) op [B32V x, B32V y]
560 = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
561bCmp (ITVec IT64 _) op [B64V x, B64V y]
562 = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
563bCmp _ _ _ = Nothing
566cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
567cmpOp (ITFixed _) f = f
568cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
569cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
570cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
572sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
573sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
574sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
575sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
576sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
577sCmpOp _ f = f
579toInt :: Integral a => IntTy -> a -> Const
580toInt (ITFixed IT8) x = B8 (fromIntegral x)
581toInt (ITFixed IT16) x = B16 (fromIntegral x)
582toInt (ITFixed IT32) x = B32 (fromIntegral x)
583toInt (ITFixed IT64) x = B64 (fromIntegral x)
584toInt ITBig x = BI (fromIntegral x)
585toInt ITNative x = I (fromIntegral x)
586toInt ITChar x = Ch (chr $ fromIntegral x)
588intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
589intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
590intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
591intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
592intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
593intToInt ITBig out [BI x] = Just $ toInt out x
594intToInt ITNative out [I x] = Just $ toInt out x
595intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
596intToInt _ _ _ = Nothing
598zext :: IntTy -> IntTy -> [Const] -> Maybe Const
599zext from ITBig val = intToInt from ITBig val
600zext ITBig _ _ = Nothing
601zext f@(ITFixed from) t@(ITFixed to) val
602 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
603zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
604zext from ITNative val = intToInt from ITNative val
605zext _ _ _ = Nothing
607sext :: IntTy -> IntTy -> [Const] -> Maybe Const
608sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
609sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
610sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
611sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
612sext ITBig _ _ = Nothing
613sext from to val = intToInt from to val
615trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
616trunc ITBig to val = intToInt ITBig to val
617trunc _ ITBig _ = Nothing
618trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
619trunc ITNative to [I x] = Just $ toInt to x
620trunc from ITNative val = intToInt from ITNative val
621trunc _ _ _ = Nothing
623intToStr :: [Const] -> Maybe Const
624intToStr val | [i] <- getInt val = Just $ Str (show i)
625intToStr _ = Nothing
627getInt :: [Const] -> [Integer]
628getInt (B8 x : xs) = toInteger x : getInt xs
629getInt (B16 x : xs) = toInteger x : getInt xs
630getInt (B32 x : xs) = toInteger x : getInt xs
631getInt (B64 x : xs) = toInteger x : getInt xs
632getInt (I x : xs) = toInteger x : getInt xs
633getInt (BI x : xs) = x : getInt xs
634getInt _ = []
636strToInt :: IntTy -> [Const] -> Maybe Const
637strToInt ity [Str x] = case reads x of
638 [(n,"")] -> Just $ toInt ity (n :: Integer)
639 _ -> Just $ I 0
640strToInt _ _ = Nothing
642intToFloat :: [Const] -> Maybe Const
643intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
644intToFloat _ = Nothing
646floatToInt :: IntTy -> [Const] -> Maybe Const
647floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
648floatToInt _ _ = Nothing
650c_intToChar, c_charToInt :: [Const] -> Maybe Const
651c_intToChar [(I x)] = Just . Ch . toEnum $ x
652c_intToChar _ = Nothing
653c_charToInt [(Ch x)] = Just . I . fromEnum $ x
654c_charToInt _ = Nothing
656c_floatToStr :: [Const] -> Maybe Const
657c_floatToStr [Fl x] = Just $ Str (show x)
658c_floatToStr _ = Nothing
659c_strToFloat [Str x] = case reads x of
660 [(n,"")] -> Just $ Fl n
661 _ -> Just $ Fl 0
662c_strToFloat _ = Nothing
664p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
665p_fPrim f [Fl x] = Just $ Fl (f x)
666p_fPrim f _ = Nothing
668p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
669p_floatExp = p_fPrim exp
670p_floatLog = p_fPrim log
671p_floatSin = p_fPrim sin
672p_floatCos = p_fPrim cos
673p_floatTan = p_fPrim tan
674p_floatASin = p_fPrim asin
675p_floatACos = p_fPrim acos
676p_floatATan = p_fPrim atan
677p_floatSqrt = p_fPrim sqrt
678p_floatFloor = p_fPrim (fromInteger . floor)
679p_floatCeil = p_fPrim (fromInteger . ceiling)
681p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const
682p_strLen [Str xs] = Just $ I (length xs)
683p_strLen _ = Nothing
684p_strHead [Str (x:xs)] = Just $ Ch x
685p_strHead _ = Nothing
686p_strTail [Str (x:xs)] = Just $ Str xs
687p_strTail _ = Nothing
688p_strIndex [Str xs, I i]
689 | i < length xs = Just $ Ch (xs!!i)
690p_strIndex _ = Nothing
691p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
692p_strCons _ = Nothing
693p_strRev [Str xs] = Just $ Str (reverse xs)
694p_strRev _ = Nothing
696p_cantreduce :: a -> Maybe b
697p_cantreduce _ = Nothing