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