git.iko.soy/Idris-dev
on d9c3c21 help sign in
Idris-dev/src/Idris/Primitives.hs
679 lines 31 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.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 (MN 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 (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))
98 (2, LPlus ATFloat) total,
99 Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))
100 (2, LMinus ATFloat) total,
101 Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))
102 (2, LTimes ATFloat) total,
103 Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))
104 (2, LSDiv ATFloat) total,
105 Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))
106 (2, LEq ATFloat) total,
107 Prim (UN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))
108 (2, LSLt ATFloat) total,
109 Prim (UN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))
110 (2, LSLe ATFloat) total,
111 Prim (UN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))
112 (2, LSGt ATFloat) total,
113 Prim (UN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))
114 (2, LSGe ATFloat) total,
115 Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))
116 (2, LStrConcat) total,
117 Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))
118 (2, LStrEq) total,
119 Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
120 (2, LStrLt) total,
121 Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
122 (1, LStrLen) total,
123 -- Conversions
124 Prim (UN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)
125 (1, LChInt ITNative) total,
126 Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)
127 (1, LIntCh ITNative) total,
128 Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)
129 (1, LStrFloat) total,
130 Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)
131 (1, LFloatStr) total,
133 Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)
134 (1, LFExp) total,
135 Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
136 (1, LFLog) total,
137 Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
138 (1, LFSin) total,
139 Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
140 (1, LFCos) total,
141 Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
142 (1, LFTan) total,
143 Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
144 (1, LFASin) total,
145 Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
146 (1, LFACos) total,
147 Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
148 (1, LFATan) total,
149 Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
150 (1, LFSqrt) total,
151 Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
152 (1, LFFloor) total,
153 Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
154 (1, LFCeil) total,
156 Prim (UN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
157 (1, LStrHead) partial,
158 Prim (UN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
159 (1, LStrTail) partial,
160 Prim (UN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
161 (2, LStrCons) total,
162 Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
163 (2, LStrIndex) partial,
164 Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
165 (1, LStrRev) total,
166 Prim (UN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)
167 (1, LReadStr) partial,
168 Prim (UN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)
169 (0, LVMPtr) total,
170 -- Streams
171 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)
172 (0, LStdIn) partial
173 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
174 ++ concatMap vecOps vecTypes
175 ++ vecBitcasts vecTypes
177vecTypes :: [IntTy]
178vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]
180intOps :: IntTy -> [Prim]
181intOps ity = intCmps ity ++ intArith ity ++ intConv ity
183intSCmps :: IntTy -> [Prim]
184intSCmps ity =
185 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
186 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
187 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
188 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
189 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
190 ]
192intCmps :: IntTy -> [Prim]
193intCmps ITNative = intSCmps ITNative
194intCmps ity =
195 intSCmps ity ++
196 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
197 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
198 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
199 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
200 ]
202intArith :: IntTy -> [Prim]
203intArith ity =
204 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
205 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
206 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
207 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
208 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
209 , iBinOp ity "urem" (bitBin ity rem) LURem partial
210 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
211 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
212 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
213 , iBinOp ity "ashr" (bashr ity) LASHR total
214 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
215 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
216 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
217 , iUnOp ity "compl" (bUn ity complement) LCompl total
218 ]
220intConv :: IntTy -> [Prim]
221intConv ity =
222 [ Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
223 (1, LIntStr ity) total
224 , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
225 (1, LStrInt ity) total
226 , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
227 (1, LIntFloat ity) total
228 , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
229 (1, LFloatInt ity) total
230 ]
232vecCmps :: IntTy -> [Prim]
233vecCmps ity =
234 [ iCmp ity "slt" True (bCmp ity (<)) (LSLt . ATInt) total
235 , iCmp ity "slte" True (bCmp ity (<=)) (LSLe . ATInt) total
236 , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total
237 , iCmp ity "sgte" True (bCmp ity (>=)) (LSGe . ATInt) total
238 , iCmp ity "sgt" True (bCmp ity (>)) (LSGt . ATInt) total
239 , iCmp ity "lt" True (bCmp ity (<)) LLt total
240 , iCmp ity "lte" True (bCmp ity (<=)) LLe total
241 , iCmp ity "gte" True (bCmp ity (>=)) LGe total
242 , iCmp ity "gt" True (bCmp ity (>)) LGt total
243 ]
245vecOps :: IntTy -> [Prim]
246vecOps ity@(ITVec elem count) =
247 [ Prim (UN $ "prim__mk" ++ intTyName ity)
248 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))
249 count (mkVecCon elem count) (count, LMkVec elem count) total
250 , Prim (UN $ "prim__index" ++ intTyName ity)
251 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))
252 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces
253 , Prim (UN $ "prim__update" ++ intTyName ity)
254 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]
255 (AType . ATInt $ ity))
256 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces
257 ] ++ intArith ity ++ vecCmps ity
259bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim
260bitcastPrim from to impl prim =
261 Prim (UN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)
262 (1, prim) total
264vecBitcasts :: [IntTy] -> [Prim]
265vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to)
266 | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to]
268mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b
269mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))
271mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b
272mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2)))
274concatWord8 :: (Word8, Word8) -> Word16
275concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8)
277concatWord16 :: (Word16, Word16) -> Word32
278concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16)
280concatWord32 :: (Word32, Word32) -> Word64
281concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32)
283truncWord16 :: Bool -> Word16 -> Word8
284truncWord16 True x = fromIntegral (x `shiftR` 8)
285truncWord16 False x = fromIntegral x
287truncWord32 :: Bool -> Word32 -> Word16
288truncWord32 True x = fromIntegral (x `shiftR` 16)
289truncWord32 False x = fromIntegral x
291truncWord64 :: Bool -> Word64 -> Word32
292truncWord64 True x = fromIntegral (x `shiftR` 32)
293truncWord64 False x = fromIntegral x
295bitcastVec :: ArithTy -> [Const] -> Maybe Const
296bitcastVec (ATInt (ITVec IT8 n)) [x@(B8V v)]
297 | V.length v == n = Just x
298bitcastVec (ATInt (ITVec IT16 n)) [B8V v]
299 | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v
300bitcastVec (ATInt (ITVec IT32 n)) [B8V v]
301 | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v
302bitcastVec (ATInt (ITVec IT64 n)) [B8V v]
303 | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v
305bitcastVec (ATInt (ITVec IT8 n)) [B16V v]
306 | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v
307bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)]
308 | V.length v == n = Just x
309bitcastVec (ATInt (ITVec IT32 n)) [B16V v]
310 | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v
311bitcastVec (ATInt (ITVec IT64 n)) [B16V v]
312 | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v
314bitcastVec (ATInt (ITVec IT8 n)) [B32V v]
315 | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v
316bitcastVec (ATInt (ITVec IT16 n)) [B32V v]
317 | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v
318bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)]
319 | V.length v == n = Just x
320bitcastVec (ATInt (ITVec IT64 n)) [B32V v]
321 | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v
323bitcastVec (ATInt (ITVec IT8 n)) [B64V v]
324 | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v
325bitcastVec (ATInt (ITVec IT16 n)) [B64V v]
326 | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v
327bitcastVec (ATInt (ITVec IT32 n)) [B64V v]
328 | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v
329bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)]
330 | V.length v == n = Just x
332bitcastVec _ _ = Nothing
334mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const
335mkVecCon ity count args
336 | length ints == count = Just (mkVec ity count ints)
337 | otherwise = Nothing
338 where
339 ints = getInt args
340 mkVec :: NativeTy -> Int -> [Integer] -> Const
341 mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))
342 mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))
343 mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))
344 mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))
346mkVecIndex count [vec, B32 i] = Just (idxVec vec)
347 where
348 idxVec :: Const -> Const
349 idxVec (B8V v) = B8 $ V.unsafeIndex v (fromIntegral i)
350 idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i)
351 idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i)
352 idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i)
353mkVecIndex _ _ = Nothing
355mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem
356 where
357 updateVec :: Const -> Const -> Maybe Const
358 updateVec (B8V v) (B8 e) = Just . B8V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
359 updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
360 updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
361 updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
362 updateVec _ _ = Nothing
363mkVecUpdate _ _ _ = Nothing
365aTyName :: ArithTy -> String
366aTyName (ATInt t) = intTyName t
367aTyName ATFloat = "Float"
369intTyName :: IntTy -> String
370intTyName ITNative = "Int"
371intTyName ITBig = "BigInt"
372intTyName (ITFixed sized) = "B" ++ show (nativeTyWidth sized)
373intTyName (ITChar) = "Char"
374intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count
376iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
377iCmp ity op self impl irop totality
378 = Prim (UN $ "prim__" ++ op ++ intTyName ity)
379 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
380 2 impl (2, irop ity) totality
382iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
383iBinOp ity op impl irop totality
384 = Prim (UN $ "prim__" ++ op ++ intTyName ity)
385 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
386 2 impl (2, irop ity) totality
387iUnOp ity op impl irop totality
388 = Prim (UN $ "prim__" ++ op ++ intTyName ity)
389 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
390 1 impl (1, irop ity) totality
392iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
393iCoerce from to op impl irop =
394 Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
395 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
397fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
398fBin op [Fl x, Fl y] = Just $ Fl (op x y)
399fBin _ _ = Nothing
401bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
402bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
403 Just $ I i
404bfBin _ _ = Nothing
406bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const
407bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in
408 Just $ I i
409bcBin _ _ = Nothing
411bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
412bsBin op [Str x, Str y]
413 = let i = (if op x y then 1 else 0) in
414 Just $ I i
415bsBin _ _ = Nothing
417sBin :: (String -> String -> String) -> [Const] -> Maybe Const
418sBin op [Str x, Str y] = Just $ Str (op x y)
419sBin _ _ = Nothing
421bsrem :: IntTy -> [Const] -> Maybe Const
422bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
423bsrem (ITFixed IT8) [B8 x, B8 y]
424 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
425bsrem (ITFixed IT16) [B16 x, B16 y]
426 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
427bsrem (ITFixed IT32) [B32 x, B32 y]
428 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
429bsrem (ITFixed IT64) [B64 x, B64 y]
430 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
431bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
432bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
433bsrem (ITVec IT8 _) [B8V x, B8V y]
434 = Just . B8V $
435 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8))) x y
436bsrem (ITVec IT16 _) [B16V x, B16V y]
437 = Just . B16V $
438 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y
439bsrem (ITVec IT32 _) [B32V x, B32V y]
440 = Just . B32V $
441 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
442bsrem (ITVec IT64 _) [B64V x, B64V y]
443 = Just . B64V $
444 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
445bsrem _ _ = Nothing
447bsdiv :: IntTy -> [Const] -> Maybe Const
448bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y
449bsdiv (ITFixed IT8) [B8 x, B8 y]
450 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
451bsdiv (ITFixed IT16) [B16 x, B16 y]
452 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
453bsdiv (ITFixed IT32) [B32 x, B32 y]
454 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
455bsdiv (ITFixed IT64) [B64 x, B64 y]
456 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
457bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
458bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))
459bsdiv (ITVec IT8 _) [B8V x, B8V y]
460 = Just . B8V $
461 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8))) x y
462bsdiv (ITVec IT16 _) [B16V x, B16V y]
463 = Just . B16V $
464 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y
465bsdiv (ITVec IT32 _) [B32V x, B32V y]
466 = Just . B32V $
467 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
468bsdiv (ITVec IT64 _) [B64V x, B64V y]
469 = Just . B64V $
470 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
471bsdiv _ _ = Nothing
473bashr :: IntTy -> [Const] -> Maybe Const
474bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
475bashr (ITFixed IT8) [B8 x, B8 y]
476 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
477bashr (ITFixed IT16) [B16 x, B16 y]
478 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
479bashr (ITFixed IT32) [B32 x, B32 y]
480 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
481bashr (ITFixed IT64) [B64 x, B64 y]
482 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
483bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
484bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
485bashr (ITVec IT8 _) [B8V x, B8V y]
486 = Just . B8V $
487 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8))) x y
488bashr (ITVec IT16 _) [B16V x, B16V y]
489 = Just . B16V $
490 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y
491bashr (ITVec IT32 _) [B32V x, B32V y]
492 = Just . B32V $
493 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
494bashr (ITVec IT64 _) [B64V x, B64V y]
495 = Just . B64V $
496 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
497bashr _ _ = Nothing
499bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
500bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
501bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
502bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
503bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
504bUn ITBig op [BI x] = Just $ BI (op x)
505bUn ITNative op [I x] = Just $ I (op x)
506bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
507bUn (ITVec IT8 _) op [B8V x] = Just . B8V $ V.map op x
508bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x
509bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x
510bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x
511bUn _ _ _ = Nothing
513bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
514bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
515bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
516bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
517bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
518bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
519bitBin ITNative op [I x, I y] = Just $ I (op x y)
520bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
521bitBin (ITVec IT8 _) op [B8V x, B8V y] = Just . B8V $ V.zipWith op x y
522bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y
523bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y
524bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y
525bitBin _ _ _ = Nothing
527bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
528bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
529bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
530bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
531bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
532bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
533bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
534bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
535bCmp (ITVec IT8 _) op [B8V x, B8V y]
536 = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
537bCmp (ITVec IT16 _) op [B16V x, B16V y]
538 = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
539bCmp (ITVec IT32 _) op [B32V x, B32V y]
540 = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
541bCmp (ITVec IT64 _) op [B64V x, B64V y]
542 = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
543bCmp _ _ _ = Nothing
546cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
547cmpOp (ITFixed _) f = f
548cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
549cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
550cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
552sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
553sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
554sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
555sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
556sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
557sCmpOp _ f = f
559toInt :: Integral a => IntTy -> a -> Const
560toInt (ITFixed IT8) x = B8 (fromIntegral x)
561toInt (ITFixed IT16) x = B16 (fromIntegral x)
562toInt (ITFixed IT32) x = B32 (fromIntegral x)
563toInt (ITFixed IT64) x = B64 (fromIntegral x)
564toInt ITBig x = BI (fromIntegral x)
565toInt ITNative x = I (fromIntegral x)
566toInt ITChar x = Ch (chr $ fromIntegral x)
568intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
569intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
570intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
571intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
572intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
573intToInt ITBig out [BI x] = Just $ toInt out x
574intToInt ITNative out [I x] = Just $ toInt out x
575intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
576intToInt _ _ _ = Nothing
578zext :: IntTy -> IntTy -> [Const] -> Maybe Const
579zext from ITBig val = intToInt from ITBig val
580zext ITBig _ _ = Nothing
581zext f@(ITFixed from) t@(ITFixed to) val
582 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
583zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
584zext from ITNative val = intToInt from ITNative val
585zext _ _ _ = Nothing
587sext :: IntTy -> IntTy -> [Const] -> Maybe Const
588sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
589sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
590sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
591sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
592sext ITBig _ _ = Nothing
593sext from to val = intToInt from to val
595trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
596trunc ITBig to val = intToInt ITBig to val
597trunc _ ITBig _ = Nothing
598trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
599trunc ITNative to [I x] = Just $ toInt to x
600trunc from ITNative val = intToInt from ITNative val
601trunc _ _ _ = Nothing
603intToStr :: [Const] -> Maybe Const
604intToStr val | [i] <- getInt val = Just $ Str (show i)
605intToStr _ = Nothing
607getInt :: [Const] -> [Integer]
608getInt (B8 x : xs) = toInteger x : getInt xs
609getInt (B16 x : xs) = toInteger x : getInt xs
610getInt (B32 x : xs) = toInteger x : getInt xs
611getInt (B64 x : xs) = toInteger x : getInt xs
612getInt (I x : xs) = toInteger x : getInt xs
613getInt (BI x : xs) = x : getInt xs
614getInt _ = []
616strToInt :: IntTy -> [Const] -> Maybe Const
617strToInt ity [Str x] = case reads x of
618 [(n,"")] -> Just $ toInt ity (n :: Integer)
619 _ -> Just $ I 0
620strToInt _ _ = Nothing
622intToFloat :: [Const] -> Maybe Const
623intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
624intToFloat _ = Nothing
626floatToInt :: IntTy -> [Const] -> Maybe Const
627floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
628floatToInt _ _ = Nothing
630c_intToChar, c_charToInt :: [Const] -> Maybe Const
631c_intToChar [(I x)] = Just . Ch . toEnum $ x
632c_intToChar _ = Nothing
633c_charToInt [(Ch x)] = Just . I . fromEnum $ x
634c_charToInt _ = Nothing
636c_floatToStr :: [Const] -> Maybe Const
637c_floatToStr [Fl x] = Just $ Str (show x)
638c_floatToStr _ = Nothing
639c_strToFloat [Str x] = case reads x of
640 [(n,"")] -> Just $ Fl n
641 _ -> Just $ Fl 0
642c_strToFloat _ = Nothing
644p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
645p_fPrim f [Fl x] = Just $ Fl (f x)
646p_fPrim f _ = Nothing
648p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
649p_floatExp = p_fPrim exp
650p_floatLog = p_fPrim log
651p_floatSin = p_fPrim sin
652p_floatCos = p_fPrim cos
653p_floatTan = p_fPrim tan
654p_floatASin = p_fPrim asin
655p_floatACos = p_fPrim acos
656p_floatATan = p_fPrim atan
657p_floatSqrt = p_fPrim sqrt
658p_floatFloor = p_fPrim (fromInteger . floor)
659p_floatCeil = p_fPrim (fromInteger . ceiling)
661p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const
662p_strLen [Str xs] = Just $ I (length xs)
663p_strLen _ = Nothing
664p_strHead [Str (x:xs)] = Just $ Ch x
665p_strHead _ = Nothing
666p_strTail [Str (x:xs)] = Just $ Str xs
667p_strTail _ = Nothing
668p_strIndex [Str xs, I i]
669 | i < length xs = Just $ Ch (xs!!i)
670p_strIndex _ = Nothing
671p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
672p_strCons _ = Nothing
673p_strRev [Str xs] = Just $ Str (reverse xs)
674p_strRev _ = Nothing
676p_cantreduce :: a -> Maybe b
677p_cantreduce _ = Nothing