git.iko.soy/Idris-dev
on 2aed52a help sign in
Idris-dev/src/Idris/Primitives.hs
752 lines 35 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, iopartial :: Totality
32total = Total []
33partial = Partial NotCovering
34iopartial = Partial ExternalIO
36primitives :: [Prim]
37primitives =
38 -- operators
39 [iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt,
40 iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt,
41 iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt,
42 iCoerce (ITFixed IT8) ITBig "zext" zext LZExt,
43 iCoerce (ITFixed IT8) ITNative "zext" zext LZExt,
44 iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt,
45 iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt,
46 iCoerce (ITFixed IT16) ITBig "zext" zext LZExt,
47 iCoerce (ITFixed IT16) ITNative "zext" zext LZExt,
48 iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt,
49 iCoerce (ITFixed IT32) ITBig "zext" zext LZExt,
50 iCoerce (ITFixed IT32) ITNative "zext" zext LZExt,
51 iCoerce (ITFixed IT64) ITBig "zext" zext LZExt,
52 iCoerce ITNative ITBig "zext" zext LZExt,
53 iCoerce ITNative (ITFixed IT64) "zext" zext LZExt,
54 iCoerce ITNative (ITFixed IT32) "zext" zext LZExt,
55 iCoerce ITNative (ITFixed IT16) "zext" zext LZExt,
56 iCoerce ITChar ITBig "zext" zext LZExt,
58 iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt,
59 iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt,
60 iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt,
61 iCoerce (ITFixed IT8) ITBig "sext" sext LSExt,
62 iCoerce (ITFixed IT8) ITNative "sext" sext LSExt,
63 iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt,
64 iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt,
65 iCoerce (ITFixed IT16) ITBig "sext" sext LSExt,
66 iCoerce (ITFixed IT16) ITNative "sext" sext LSExt,
67 iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt,
68 iCoerce (ITFixed IT32) ITBig "sext" sext LSExt,
69 iCoerce (ITFixed IT32) ITNative "sext" sext LSExt,
70 iCoerce (ITFixed IT64) ITBig "sext" sext LSExt,
71 iCoerce ITNative ITBig "sext" sext LSExt,
72 iCoerce ITNative ITBig "sext" sext LSExt,
73 iCoerce ITNative (ITFixed IT64) "sext" sext LSExt,
74 iCoerce ITNative (ITFixed IT32) "sext" sext LSExt,
75 iCoerce ITNative (ITFixed IT16) "sext" sext LSExt,
76 iCoerce ITChar ITBig "sext" sext LSExt,
78 iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc,
79 iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc,
80 iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc,
81 iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc,
82 iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc,
83 iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc,
84 iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc,
85 iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc,
86 iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc,
87 iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc,
88 iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc,
89 iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc,
90 iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc,
91 iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc,
92 iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc,
93 iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc,
94 iCoerce ITBig ITNative "trunc" trunc LTrunc,
95 iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,
96 iCoerce ITBig ITChar "trunc" trunc LTrunc,
98 Prim (sUN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))
99 (2, LPlus ATFloat) total,
100 Prim (sUN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))
101 (2, LMinus ATFloat) total,
102 Prim (sUN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))
103 (2, LTimes ATFloat) total,
104 Prim (sUN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))
105 (2, LSDiv ATFloat) total,
106 Prim (sUN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))
107 (2, LEq ATFloat) total,
108 Prim (sUN "prim__sltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))
109 (2, LSLt ATFloat) total,
110 Prim (sUN "prim__slteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))
111 (2, LSLe ATFloat) total,
112 Prim (sUN "prim__sgtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))
113 (2, LSGt ATFloat) total,
114 Prim (sUN "prim__sgteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))
115 (2, LSGe ATFloat) total,
116 Prim (sUN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))
117 (2, LStrConcat) total,
118 Prim (sUN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))
119 (2, LStrEq) total,
120 Prim (sUN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
121 (2, LStrLt) total,
122 Prim (sUN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
123 (1, LStrLen) total,
124 -- Conversions
125 Prim (sUN "prim__charToInt") (ty [(AType (ATInt ITChar))] (AType (ATInt ITNative))) 1 (c_charToInt)
126 (1, LChInt ITNative) total,
127 Prim (sUN "prim__intToChar") (ty [(AType (ATInt ITNative))] (AType (ATInt ITChar))) 1 (c_intToChar)
128 (1, LIntCh ITNative) total,
129 Prim (sUN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)
130 (1, LStrFloat) total,
131 Prim (sUN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)
132 (1, LFloatStr) total,
134 Prim (sUN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)
135 (1, LFExp) total,
136 Prim (sUN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
137 (1, LFLog) total,
138 Prim (sUN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
139 (1, LFSin) total,
140 Prim (sUN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
141 (1, LFCos) total,
142 Prim (sUN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
143 (1, LFTan) total,
144 Prim (sUN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
145 (1, LFASin) total,
146 Prim (sUN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
147 (1, LFACos) total,
148 Prim (sUN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
149 (1, LFATan) total,
150 Prim (sUN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
151 (1, LFSqrt) total,
152 Prim (sUN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
153 (1, LFFloor) total,
154 Prim (sUN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
155 (1, LFCeil) total,
157 Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
158 (1, LStrHead) partial,
159 Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
160 (1, LStrTail) partial,
161 Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
162 (2, LStrCons) total,
163 Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
164 (2, LStrIndex) partial,
165 Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
166 (1, LStrRev) total,
167 Prim (sUN "prim__readString") (ty [PtrType] StrType) 1 (p_cantreduce)
168 (1, LReadStr) iopartial,
169 Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)
170 (0, LVMPtr) total,
171 -- Streams
172 Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)
173 (0, LStdIn) iopartial,
174 Prim (sUN "prim__stdout") (ty [] PtrType) 0 (p_cantreduce)
175 (0, LStdOut) iopartial,
176 Prim (sUN "prim__stderr") (ty [] PtrType) 0 (p_cantreduce)
177 (0, LStdErr) iopartial,
178 Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)
179 (0, LNullPtr) total,
180 -- Managed pointer registration
181 Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)
182 (2, LRegisterPtr) total,
183 -- Buffers
184 Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_allocate)
185 (1, LAllocate) total,
186 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_appendBuffer)
187 (6, LAppendBuffer) partial,
188 Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)
189 (1, LSystemInfo) total
190 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
191 ++ concatMap vecOps vecTypes
192 ++ concatMap fixedOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64] -- ITNative, ITChar, ATFloat ] ++ vecTypes
193 ++ vecBitcasts vecTypes
195vecTypes :: [IntTy]
196vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]
198intOps :: IntTy -> [Prim]
199intOps ity = intCmps ity ++ intArith ity ++ intConv ity
201intSCmps :: IntTy -> [Prim]
202intSCmps ity =
203 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
204 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
205 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
206 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
207 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
208 ]
210intCmps :: IntTy -> [Prim]
211intCmps ITNative = intSCmps ITNative
212intCmps ity =
213 intSCmps ity ++
214 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
215 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
216 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
217 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
218 ]
220intArith :: IntTy -> [Prim]
221intArith ity =
222 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
223 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
224 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
225 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
226 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
227 , iBinOp ity "urem" (bitBin ity rem) LURem partial
228 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
229 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
230 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
231 , iBinOp ity "ashr" (bashr ity) LASHR total
232 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
233 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
234 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
235 , iUnOp ity "compl" (bUn ity complement) LCompl total
236 ]
238intConv :: IntTy -> [Prim]
239intConv ity =
240 [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
241 (1, LIntStr ity) total
242 , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
243 (1, LStrInt ity) total
244 , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
245 (1, LIntFloat ity) total
246 , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
247 (1, LFloatInt ity) total
248 ]
250vecCmps :: IntTy -> [Prim]
251vecCmps ity =
252 [ iCmp ity "slt" True (bCmp ity (<)) (LSLt . ATInt) total
253 , iCmp ity "slte" True (bCmp ity (<=)) (LSLe . ATInt) total
254 , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total
255 , iCmp ity "sgte" True (bCmp ity (>=)) (LSGe . ATInt) total
256 , iCmp ity "sgt" True (bCmp ity (>)) (LSGt . ATInt) total
257 , iCmp ity "lt" True (bCmp ity (<)) LLt total
258 , iCmp ity "lte" True (bCmp ity (<=)) LLe total
259 , iCmp ity "gte" True (bCmp ity (>=)) LGe total
260 , iCmp ity "gt" True (bCmp ity (>)) LGt total
261 ]
263vecOps :: IntTy -> [Prim]
264vecOps ity@(ITVec elem count) =
265 [ Prim (sUN $ "prim__mk" ++ intTyName ity)
266 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))
267 count (mkVecCon elem count) (count, LMkVec elem count) total
268 , Prim (sUN $ "prim__index" ++ intTyName ity)
269 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))
270 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces
271 , Prim (sUN $ "prim__update" ++ intTyName ity)
272 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]
273 (AType . ATInt $ ity))
274 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces
275 ] ++ intArith ity ++ vecCmps ity
277bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim
278bitcastPrim from to impl prim =
279 Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)
280 (1, prim) total
282vecBitcasts :: [IntTy] -> [Prim]
283vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to)
284 | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to]
286fixedOps :: IntTy -> [Prim]
287fixedOps ity@(ITFixed _) =
288 map appendFun endiannesses ++
289 map peekFun endiannesses
290 where
291 endiannesses = [ Native, LE, BE ]
292 tyName = intTyName ity
293 b64 = AType (ATInt (ITFixed IT64))
294 thisTy = AType $ ATInt ity
295 appendFun en = Prim (sUN $ "prim__append" ++ tyName ++ show en)
296 (ty [BufferType, b64, b64, thisTy] BufferType)
297 4 (p_append en) (4, LAppend ity en) partial
298 peekFun en = Prim (sUN $ "prim__peek" ++ tyName ++ show en)
299 (ty [BufferType, b64] thisTy)
300 2 (p_peek ity en) (2, LPeek ity en) partial
302mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b
303mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))
305mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b
306mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2)))
308concatWord8 :: (Word8, Word8) -> Word16
309concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8)
311concatWord16 :: (Word16, Word16) -> Word32
312concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16)
314concatWord32 :: (Word32, Word32) -> Word64
315concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32)
317truncWord16 :: Bool -> Word16 -> Word8
318truncWord16 True x = fromIntegral (x `shiftR` 8)
319truncWord16 False x = fromIntegral x
321truncWord32 :: Bool -> Word32 -> Word16
322truncWord32 True x = fromIntegral (x `shiftR` 16)
323truncWord32 False x = fromIntegral x
325truncWord64 :: Bool -> Word64 -> Word32
326truncWord64 True x = fromIntegral (x `shiftR` 32)
327truncWord64 False x = fromIntegral x
329bitcastVec :: ArithTy -> [Const] -> Maybe Const
330bitcastVec (ATInt (ITVec IT8 n)) [x@(B8V v)]
331 | V.length v == n = Just x
332bitcastVec (ATInt (ITVec IT16 n)) [B8V v]
333 | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v
334bitcastVec (ATInt (ITVec IT32 n)) [B8V v]
335 | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v
336bitcastVec (ATInt (ITVec IT64 n)) [B8V v]
337 | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v
339bitcastVec (ATInt (ITVec IT8 n)) [B16V v]
340 | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v
341bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)]
342 | V.length v == n = Just x
343bitcastVec (ATInt (ITVec IT32 n)) [B16V v]
344 | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v
345bitcastVec (ATInt (ITVec IT64 n)) [B16V v]
346 | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v
348bitcastVec (ATInt (ITVec IT8 n)) [B32V v]
349 | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v
350bitcastVec (ATInt (ITVec IT16 n)) [B32V v]
351 | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v
352bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)]
353 | V.length v == n = Just x
354bitcastVec (ATInt (ITVec IT64 n)) [B32V v]
355 | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v
357bitcastVec (ATInt (ITVec IT8 n)) [B64V v]
358 | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v
359bitcastVec (ATInt (ITVec IT16 n)) [B64V v]
360 | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v
361bitcastVec (ATInt (ITVec IT32 n)) [B64V v]
362 | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v
363bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)]
364 | V.length v == n = Just x
366bitcastVec _ _ = Nothing
368mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const
369mkVecCon ity count args
370 | length ints == count = Just (mkVec ity count ints)
371 | otherwise = Nothing
372 where
373 ints = getInt args
374 mkVec :: NativeTy -> Int -> [Integer] -> Const
375 mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))
376 mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))
377 mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))
378 mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))
380mkVecIndex count [vec, B32 i] = Just (idxVec vec)
381 where
382 idxVec :: Const -> Const
383 idxVec (B8V v) = B8 $ V.unsafeIndex v (fromIntegral i)
384 idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i)
385 idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i)
386 idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i)
387mkVecIndex _ _ = Nothing
389mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem
390 where
391 updateVec :: Const -> Const -> Maybe Const
392 updateVec (B8V v) (B8 e) = Just . B8V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
393 updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
394 updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
395 updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
396 updateVec _ _ = Nothing
397mkVecUpdate _ _ _ = Nothing
399aTyName :: ArithTy -> String
400aTyName (ATInt t) = intTyName t
401aTyName ATFloat = "Float"
403iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
404iCmp ity op self impl irop totality
405 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
406 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
407 2 impl (2, irop ity) totality
409iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
410iBinOp ity op impl irop totality
411 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
412 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
413 2 impl (2, irop ity) totality
414iUnOp ity op impl irop totality
415 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
416 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
417 1 impl (1, irop ity) totality
419iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
420iCoerce from to op impl irop =
421 Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
422 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
424fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
425fBin op [Fl x, Fl y] = Just $ Fl (op x y)
426fBin _ _ = Nothing
428bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
429bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
430 Just $ I i
431bfBin _ _ = Nothing
433bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const
434bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in
435 Just $ I i
436bcBin _ _ = Nothing
438bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
439bsBin op [Str x, Str y]
440 = let i = (if op x y then 1 else 0) in
441 Just $ I i
442bsBin _ _ = Nothing
444sBin :: (String -> String -> String) -> [Const] -> Maybe Const
445sBin op [Str x, Str y] = Just $ Str (op x y)
446sBin _ _ = Nothing
448bsrem :: IntTy -> [Const] -> Maybe Const
449bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
450bsrem (ITFixed IT8) [B8 x, B8 y]
451 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
452bsrem (ITFixed IT16) [B16 x, B16 y]
453 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
454bsrem (ITFixed IT32) [B32 x, B32 y]
455 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
456bsrem (ITFixed IT64) [B64 x, B64 y]
457 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
458bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
459bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
460bsrem (ITVec IT8 _) [B8V x, B8V y]
461 = Just . B8V $
462 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8))) x y
463bsrem (ITVec IT16 _) [B16V x, B16V y]
464 = Just . B16V $
465 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y
466bsrem (ITVec IT32 _) [B32V x, B32V y]
467 = Just . B32V $
468 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
469bsrem (ITVec IT64 _) [B64V x, B64V y]
470 = Just . B64V $
471 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
472bsrem _ _ = Nothing
474bsdiv :: IntTy -> [Const] -> Maybe Const
475bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y
476bsdiv (ITFixed IT8) [B8 x, B8 y]
477 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
478bsdiv (ITFixed IT16) [B16 x, B16 y]
479 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
480bsdiv (ITFixed IT32) [B32 x, B32 y]
481 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
482bsdiv (ITFixed IT64) [B64 x, B64 y]
483 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
484bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
485bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))
486bsdiv (ITVec IT8 _) [B8V x, B8V y]
487 = Just . B8V $
488 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8))) x y
489bsdiv (ITVec IT16 _) [B16V x, B16V y]
490 = Just . B16V $
491 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y
492bsdiv (ITVec IT32 _) [B32V x, B32V y]
493 = Just . B32V $
494 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
495bsdiv (ITVec IT64 _) [B64V x, B64V y]
496 = Just . B64V $
497 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
498bsdiv _ _ = Nothing
500bashr :: IntTy -> [Const] -> Maybe Const
501bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
502bashr (ITFixed IT8) [B8 x, B8 y]
503 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
504bashr (ITFixed IT16) [B16 x, B16 y]
505 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
506bashr (ITFixed IT32) [B32 x, B32 y]
507 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
508bashr (ITFixed IT64) [B64 x, B64 y]
509 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
510bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
511bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
512bashr (ITVec IT8 _) [B8V x, B8V y]
513 = Just . B8V $
514 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8))) x y
515bashr (ITVec IT16 _) [B16V x, B16V y]
516 = Just . B16V $
517 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y
518bashr (ITVec IT32 _) [B32V x, B32V y]
519 = Just . B32V $
520 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
521bashr (ITVec IT64 _) [B64V x, B64V y]
522 = Just . B64V $
523 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
524bashr _ _ = Nothing
526bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
527bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
528bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
529bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
530bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
531bUn ITBig op [BI x] = Just $ BI (op x)
532bUn ITNative op [I x] = Just $ I (op x)
533bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
534bUn (ITVec IT8 _) op [B8V x] = Just . B8V $ V.map op x
535bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x
536bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x
537bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x
538bUn _ _ _ = Nothing
540bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
541bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
542bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
543bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
544bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
545bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
546bitBin ITNative op [I x, I y] = Just $ I (op x y)
547bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
548bitBin (ITVec IT8 _) op [B8V x, B8V y] = Just . B8V $ V.zipWith op x y
549bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y
550bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y
551bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y
552bitBin _ _ _ = Nothing
554bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
555bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
556bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
557bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
558bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
559bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
560bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
561bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
562bCmp (ITVec IT8 _) op [B8V x, B8V y]
563 = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
564bCmp (ITVec IT16 _) op [B16V x, B16V y]
565 = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
566bCmp (ITVec IT32 _) op [B32V x, B32V y]
567 = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
568bCmp (ITVec IT64 _) op [B64V x, B64V y]
569 = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
570bCmp _ _ _ = Nothing
573cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
574cmpOp (ITFixed _) f = f
575cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
576cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
577cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
579sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
580sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
581sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
582sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
583sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
584sCmpOp _ f = f
586toInt :: Integral a => IntTy -> a -> Const
587toInt (ITFixed IT8) x = B8 (fromIntegral x)
588toInt (ITFixed IT16) x = B16 (fromIntegral x)
589toInt (ITFixed IT32) x = B32 (fromIntegral x)
590toInt (ITFixed IT64) x = B64 (fromIntegral x)
591toInt ITBig x = BI (fromIntegral x)
592toInt ITNative x = I (fromIntegral x)
593toInt ITChar x = Ch (chr $ fromIntegral x)
595intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
596intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
597intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
598intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
599intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
600intToInt ITBig out [BI x] = Just $ toInt out x
601intToInt ITNative out [I x] = Just $ toInt out x
602intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
603intToInt _ _ _ = Nothing
605zext :: IntTy -> IntTy -> [Const] -> Maybe Const
606zext from ITBig val = intToInt from ITBig val
607zext ITBig _ _ = Nothing
608zext f@(ITFixed from) t@(ITFixed to) val
609 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
610zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
611zext from ITNative val = intToInt from ITNative val
612zext _ _ _ = Nothing
614sext :: IntTy -> IntTy -> [Const] -> Maybe Const
615sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
616sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
617sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
618sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
619sext ITBig _ _ = Nothing
620sext from to val = intToInt from to val
622trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
623trunc ITBig to val = intToInt ITBig to val
624trunc _ ITBig _ = Nothing
625trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
626trunc ITNative to [I x] = Just $ toInt to x
627trunc from ITNative val = intToInt from ITNative val
628trunc _ _ _ = Nothing
630intToStr :: [Const] -> Maybe Const
631intToStr val | [i] <- getInt val = Just $ Str (show i)
632intToStr _ = Nothing
634getInt :: [Const] -> [Integer]
635getInt (B8 x : xs) = toInteger x : getInt xs
636getInt (B16 x : xs) = toInteger x : getInt xs
637getInt (B32 x : xs) = toInteger x : getInt xs
638getInt (B64 x : xs) = toInteger x : getInt xs
639getInt (I x : xs) = toInteger x : getInt xs
640getInt (BI x : xs) = x : getInt xs
641getInt _ = []
643strToInt :: IntTy -> [Const] -> Maybe Const
644strToInt ity [Str x] = case reads x of
645 [(n,"")] -> Just $ toInt ity (n :: Integer)
646 _ -> Just $ I 0
647strToInt _ _ = Nothing
649intToFloat :: [Const] -> Maybe Const
650intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
651intToFloat _ = Nothing
653floatToInt :: IntTy -> [Const] -> Maybe Const
654floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
655floatToInt _ _ = Nothing
657c_intToChar, c_charToInt :: [Const] -> Maybe Const
658c_intToChar [(I x)] = Just . Ch . toEnum $ x
659c_intToChar _ = Nothing
660c_charToInt [(Ch x)] = Just . I . fromEnum $ x
661c_charToInt _ = Nothing
663c_floatToStr :: [Const] -> Maybe Const
664c_floatToStr [Fl x] = Just $ Str (show x)
665c_floatToStr _ = Nothing
666c_strToFloat [Str x] = case reads x of
667 [(n,"")] -> Just $ Fl n
668 _ -> Just $ Fl 0
669c_strToFloat _ = Nothing
671p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
672p_fPrim f [Fl x] = Just $ Fl (f x)
673p_fPrim f _ = Nothing
675p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
676p_floatExp = p_fPrim exp
677p_floatLog = p_fPrim log
678p_floatSin = p_fPrim sin
679p_floatCos = p_fPrim cos
680p_floatTan = p_fPrim tan
681p_floatASin = p_fPrim asin
682p_floatACos = p_fPrim acos
683p_floatATan = p_fPrim atan
684p_floatSqrt = p_fPrim sqrt
685p_floatFloor = p_fPrim (fromInteger . floor)
686p_floatCeil = p_fPrim (fromInteger . ceiling)
688p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const
689p_strLen [Str xs] = Just $ I (length xs)
690p_strLen _ = Nothing
691p_strHead [Str (x:xs)] = Just $ Ch x
692p_strHead _ = Nothing
693p_strTail [Str (x:xs)] = Just $ Str xs
694p_strTail _ = Nothing
695p_strIndex [Str xs, I i]
696 | i < length xs = Just $ Ch (xs!!i)
697p_strIndex _ = Nothing
698p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
699p_strCons _ = Nothing
700p_strRev [Str xs] = Just $ Str (reverse xs)
701p_strRev _ = Nothing
703p_allocate, p_appendBuffer :: [Const] -> Maybe Const
704p_allocate [B64 _] = Just $ B8V V.empty
705p_allocate n = Nothing
706p_appendBuffer [B8V vect1, B64 size1, B64 count, B64 size2, B64 off, B8V vect2] =
707 Just $ B8V (foldl (V.++)
708 (V.slice 0 (fromIntegral size1) vect1)
709 (replicate (fromIntegral count) (V.slice (fromIntegral off) (fromIntegral size2) vect2)))
710p_appendBuffer n = Nothing
711p_append :: Endianness -> [Const] -> Maybe Const
712p_append en [B8V vect, B64 size, B64 count, val] =
713 let bytes = case val of
714 B8 x -> [x]
715 B16 x -> [fromIntegral x, fromIntegral (shiftR x 8)]
716 B32 x -> map (fromIntegral . shiftR x) [0,8..24]
717 B64 x -> map (fromIntegral . shiftR x) [0,8..56]
718 in Just $ B8V (foldl V.snoc
719 (V.slice 0 (fromIntegral size) vect)
720 (concat (replicate (fromIntegral count)
721 (case en of
722 BE -> reverse bytes
723 _ -> bytes))))
724p_append _ _ = Nothing
726p_peek :: IntTy -> Endianness -> [Const] -> Maybe Const
727p_peek (ITFixed IT8) _ [B8V vect, B64 offset] = Just $ B8 (vect V.! fromIntegral offset)
728p_peek (ITFixed IT16) en [B8V vect, B64 offset] =
729 let bytes = [0..1]
730 in Just $ B16 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))
731 0
732 (case en of
733 BE -> bytes
734 _ -> reverse bytes))
735p_peek (ITFixed IT32) en [B8V vect, B64 offset] =
736 let bytes = [0..1]
737 in Just $ B32 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))
738 0
739 (case en of
740 BE -> bytes
741 _ -> reverse bytes))
742p_peek (ITFixed IT64) en [B8V vect, B64 offset] =
743 let bytes = [0..1]
744 in Just $ B64 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))
745 0
746 (case en of
747 BE -> bytes
748 _ -> reverse bytes))
749p_peek _ _ _ = Nothing
751p_cantreduce :: a -> Maybe b
752p_cantreduce _ = Nothing