1{-# LANGUAGE RankNTypes, ScopedTypeVariables, PatternGuards #-}
3module Idris.Primitives(primitives, Prim(..)) where
15import Data.Function (on)
16import Data.Vector.Unboxed (Vector)
17import qualified Data.Vector.Unboxed as V
19data Prim = Prim { p_name :: Name,
22 p_def :: [Const] -> Maybe Const,
23 p_lexp :: (Int, PrimFn),
27ty :: [Const] -> Const -> Type
29ty (t:ts) x = Bind (MN 0 "T") (Pi (Constant t)) (ty ts x)
31total, partial :: Totality
33partial = Partial NotCovering
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 (==))
119 Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
121 Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
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)
135 Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
137 Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
139 Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
141 Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
143 Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
145 Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
147 Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
149 Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
151 Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
153 Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
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)
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)
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)
171 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)
173 Prim (UN "prim__null") (ty [] PtrType) 0 (p_cantreduce)
175 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
176 ++ concatMap vecOps vecTypes
177 ++ vecBitcasts vecTypes
180vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]
182intOps :: IntTy -> [Prim]
183intOps ity = intCmps ity ++ intArith ity ++ intConv ity
185intSCmps :: IntTy -> [Prim]
187 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
188 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
189 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
190 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
191 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
194intCmps :: IntTy -> [Prim]
195intCmps ITNative = intSCmps ITNative
198 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
199 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
200 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
201 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
204intArith :: IntTy -> [Prim]
206 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
207 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
208 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
209 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
210 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
211 , iBinOp ity "urem" (bitBin ity rem) LURem partial
212 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
213 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
214 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
215 , iBinOp ity "ashr" (bashr ity) LASHR total
216 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
217 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
218 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
219 , iUnOp ity "compl" (bUn ity complement) LCompl total
222intConv :: IntTy -> [Prim]
224 [ Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
225 (1, LIntStr ity) total
226 , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
227 (1, LStrInt ity) total
228 , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
229 (1, LIntFloat ity) total
230 , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
231 (1, LFloatInt ity) total
234vecCmps :: IntTy -> [Prim]
236 [ iCmp ity "slt" True (bCmp ity (<)) (LSLt . ATInt) total
237 , iCmp ity "slte" True (bCmp ity (<=)) (LSLe . ATInt) total
238 , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total
239 , iCmp ity "sgte" True (bCmp ity (>=)) (LSGe . ATInt) total
240 , iCmp ity "sgt" True (bCmp ity (>)) (LSGt . ATInt) total
241 , iCmp ity "lt" True (bCmp ity (<)) LLt total
242 , iCmp ity "lte" True (bCmp ity (<=)) LLe total
243 , iCmp ity "gte" True (bCmp ity (>=)) LGe total
244 , iCmp ity "gt" True (bCmp ity (>)) LGt total
247vecOps :: IntTy -> [Prim]
248vecOps ity@(ITVec elem count) =
249 [ Prim (UN $ "prim__mk" ++ intTyName ity)
250 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))
251 count (mkVecCon elem count) (count, LMkVec elem count) total
252 , Prim (UN $ "prim__index" ++ intTyName ity)
253 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))
254 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces
255 , Prim (UN $ "prim__update" ++ intTyName ity)
256 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]
257 (AType . ATInt $ ity))
258 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces
259 ] ++ intArith ity ++ vecCmps ity
261bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim
262bitcastPrim from to impl prim =
263 Prim (UN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)
266vecBitcasts :: [IntTy] -> [Prim]
267vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to)
268 | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to]
270mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b
271mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))
273mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b
274mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2)))
276concatWord8 :: (Word8, Word8) -> Word16
277concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8)
279concatWord16 :: (Word16, Word16) -> Word32
280concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16)
282concatWord32 :: (Word32, Word32) -> Word64
283concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32)
285truncWord16 :: Bool -> Word16 -> Word8
286truncWord16 True x = fromIntegral (x `shiftR` 8)
287truncWord16 False x = fromIntegral x
289truncWord32 :: Bool -> Word32 -> Word16
290truncWord32 True x = fromIntegral (x `shiftR` 16)
291truncWord32 False x = fromIntegral x
293truncWord64 :: Bool -> Word64 -> Word32
294truncWord64 True x = fromIntegral (x `shiftR` 32)
295truncWord64 False x = fromIntegral x
297bitcastVec :: ArithTy -> [Const] -> Maybe Const
298bitcastVec (ATInt (ITVec IT8 n)) [x@(B8V v)]
299 | V.length v == n = Just x
300bitcastVec (ATInt (ITVec IT16 n)) [B8V v]
301 | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v
302bitcastVec (ATInt (ITVec IT32 n)) [B8V v]
303 | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v
304bitcastVec (ATInt (ITVec IT64 n)) [B8V v]
305 | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v
307bitcastVec (ATInt (ITVec IT8 n)) [B16V v]
308 | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v
309bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)]
310 | V.length v == n = Just x
311bitcastVec (ATInt (ITVec IT32 n)) [B16V v]
312 | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v
313bitcastVec (ATInt (ITVec IT64 n)) [B16V v]
314 | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v
316bitcastVec (ATInt (ITVec IT8 n)) [B32V v]
317 | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v
318bitcastVec (ATInt (ITVec IT16 n)) [B32V v]
319 | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v
320bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)]
321 | V.length v == n = Just x
322bitcastVec (ATInt (ITVec IT64 n)) [B32V v]
323 | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v
325bitcastVec (ATInt (ITVec IT8 n)) [B64V v]
326 | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v
327bitcastVec (ATInt (ITVec IT16 n)) [B64V v]
328 | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v
329bitcastVec (ATInt (ITVec IT32 n)) [B64V v]
330 | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v
331bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)]
332 | V.length v == n = Just x
334bitcastVec _ _ = Nothing
336mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const
337mkVecCon ity count args
338 | length ints == count = Just (mkVec ity count ints)
339 | otherwise = Nothing
342 mkVec :: NativeTy -> Int -> [Integer] -> Const
343 mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))
344 mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))
345 mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))
346 mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))
348mkVecIndex count [vec, B32 i] = Just (idxVec vec)
350 idxVec :: Const -> Const
351 idxVec (B8V v) = B8 $ V.unsafeIndex v (fromIntegral i)
352 idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i)
353 idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i)
354 idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i)
355mkVecIndex _ _ = Nothing
357mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem
359 updateVec :: Const -> Const -> Maybe Const
360 updateVec (B8V v) (B8 e) = Just . B8V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
361 updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
362 updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
363 updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
364 updateVec _ _ = Nothing
365mkVecUpdate _ _ _ = Nothing
367aTyName :: ArithTy -> String
368aTyName (ATInt t) = intTyName t
369aTyName ATFloat = "Float"
371intTyName :: IntTy -> String
372intTyName ITNative = "Int"
373intTyName ITBig = "BigInt"
374intTyName (ITFixed sized) = "B" ++ show (nativeTyWidth sized)
375intTyName (ITChar) = "Char"
376intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count
378iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
379iCmp ity op self impl irop totality
380 = Prim (UN $ "prim__" ++ op ++ intTyName ity)
381 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
382 2 impl (2, irop ity) totality
384iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
385iBinOp ity op impl irop totality
386 = Prim (UN $ "prim__" ++ op ++ intTyName ity)
387 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
388 2 impl (2, irop ity) totality
389iUnOp ity op impl irop totality
390 = Prim (UN $ "prim__" ++ op ++ intTyName ity)
391 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
392 1 impl (1, irop ity) totality
394iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
395iCoerce from to op impl irop =
396 Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
397 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
399fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
400fBin op [Fl x, Fl y] = Just $ Fl (op x y)
403bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
404bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
408bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const
409bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in
413bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
414bsBin op [Str x, Str y]
415 = let i = (if op x y then 1 else 0) in
419sBin :: (String -> String -> String) -> [Const] -> Maybe Const
420sBin op [Str x, Str y] = Just $ Str (op x y)
423bsrem :: IntTy -> [Const] -> Maybe Const
424bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
425bsrem (ITFixed IT8) [B8 x, B8 y]
426 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
427bsrem (ITFixed IT16) [B16 x, B16 y]
428 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
429bsrem (ITFixed IT32) [B32 x, B32 y]
430 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
431bsrem (ITFixed IT64) [B64 x, B64 y]
432 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
433bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
434bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
435bsrem (ITVec IT8 _) [B8V x, B8V y]
437 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8))) x y
438bsrem (ITVec IT16 _) [B16V x, B16V y]
440 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y
441bsrem (ITVec IT32 _) [B32V x, B32V y]
443 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
444bsrem (ITVec IT64 _) [B64V x, B64V y]
446 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
449bsdiv :: IntTy -> [Const] -> Maybe Const
450bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y
451bsdiv (ITFixed IT8) [B8 x, B8 y]
452 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
453bsdiv (ITFixed IT16) [B16 x, B16 y]
454 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
455bsdiv (ITFixed IT32) [B32 x, B32 y]
456 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
457bsdiv (ITFixed IT64) [B64 x, B64 y]
458 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
459bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
460bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))
461bsdiv (ITVec IT8 _) [B8V x, B8V y]
463 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8))) x y
464bsdiv (ITVec IT16 _) [B16V x, B16V y]
466 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y
467bsdiv (ITVec IT32 _) [B32V x, B32V y]
469 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
470bsdiv (ITVec IT64 _) [B64V x, B64V y]
472 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
475bashr :: IntTy -> [Const] -> Maybe Const
476bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
477bashr (ITFixed IT8) [B8 x, B8 y]
478 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
479bashr (ITFixed IT16) [B16 x, B16 y]
480 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
481bashr (ITFixed IT32) [B32 x, B32 y]
482 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
483bashr (ITFixed IT64) [B64 x, B64 y]
484 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
485bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
486bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
487bashr (ITVec IT8 _) [B8V x, B8V y]
489 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8))) x y
490bashr (ITVec IT16 _) [B16V x, B16V y]
492 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y
493bashr (ITVec IT32 _) [B32V x, B32V y]
495 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
496bashr (ITVec IT64 _) [B64V x, B64V y]
498 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
501bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
502bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
503bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
504bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
505bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
506bUn ITBig op [BI x] = Just $ BI (op x)
507bUn ITNative op [I x] = Just $ I (op x)
508bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
509bUn (ITVec IT8 _) op [B8V x] = Just . B8V $ V.map op x
510bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x
511bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x
512bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x
515bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
516bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
517bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
518bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
519bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
520bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
521bitBin ITNative op [I x, I y] = Just $ I (op x y)
522bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
523bitBin (ITVec IT8 _) op [B8V x, B8V y] = Just . B8V $ V.zipWith op x y
524bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y
525bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y
526bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y
527bitBin _ _ _ = Nothing
529bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
530bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
531bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
532bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
533bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
534bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
535bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
536bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
537bCmp (ITVec IT8 _) op [B8V x, B8V y]
538 = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
539bCmp (ITVec IT16 _) op [B16V x, B16V y]
540 = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
541bCmp (ITVec IT32 _) op [B32V x, B32V y]
542 = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
543bCmp (ITVec IT64 _) op [B64V x, B64V y]
544 = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
548cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
549cmpOp (ITFixed _) f = f
550cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
551cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
552cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
554sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
555sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
556sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
557sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
558sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
561toInt :: Integral a => IntTy -> a -> Const
562toInt (ITFixed IT8) x = B8 (fromIntegral x)
563toInt (ITFixed IT16) x = B16 (fromIntegral x)
564toInt (ITFixed IT32) x = B32 (fromIntegral x)
565toInt (ITFixed IT64) x = B64 (fromIntegral x)
566toInt ITBig x = BI (fromIntegral x)
567toInt ITNative x = I (fromIntegral x)
568toInt ITChar x = Ch (chr $ fromIntegral x)
570intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
571intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
572intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
573intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
574intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
575intToInt ITBig out [BI x] = Just $ toInt out x
576intToInt ITNative out [I x] = Just $ toInt out x
577intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
578intToInt _ _ _ = Nothing
580zext :: IntTy -> IntTy -> [Const] -> Maybe Const
581zext from ITBig val = intToInt from ITBig val
582zext ITBig _ _ = Nothing
583zext f@(ITFixed from) t@(ITFixed to) val
584 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
585zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
586zext from ITNative val = intToInt from ITNative val
589sext :: IntTy -> IntTy -> [Const] -> Maybe Const
590sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
591sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
592sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
593sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
594sext ITBig _ _ = Nothing
595sext from to val = intToInt from to val
597trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
598trunc ITBig to val = intToInt ITBig to val
599trunc _ ITBig _ = Nothing
600trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
601trunc ITNative to [I x] = Just $ toInt to x
602trunc from ITNative val = intToInt from ITNative val
605intToStr :: [Const] -> Maybe Const
606intToStr val | [i] <- getInt val = Just $ Str (show i)
609getInt :: [Const] -> [Integer]
610getInt (B8 x : xs) = toInteger x : getInt xs
611getInt (B16 x : xs) = toInteger x : getInt xs
612getInt (B32 x : xs) = toInteger x : getInt xs
613getInt (B64 x : xs) = toInteger x : getInt xs
614getInt (I x : xs) = toInteger x : getInt xs
615getInt (BI x : xs) = x : getInt xs
618strToInt :: IntTy -> [Const] -> Maybe Const
619strToInt ity [Str x] = case reads x of
620 [(n,"")] -> Just $ toInt ity (n :: Integer)
622strToInt _ _ = Nothing
624intToFloat :: [Const] -> Maybe Const
625intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
626intToFloat _ = Nothing
628floatToInt :: IntTy -> [Const] -> Maybe Const
629floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
630floatToInt _ _ = Nothing
632c_intToChar, c_charToInt :: [Const] -> Maybe Const
633c_intToChar [(I x)] = Just . Ch . toEnum $ x
634c_intToChar _ = Nothing
635c_charToInt [(Ch x)] = Just . I . fromEnum $ x
636c_charToInt _ = Nothing
638c_floatToStr :: [Const] -> Maybe Const
639c_floatToStr [Fl x] = Just $ Str (show x)
640c_floatToStr _ = Nothing
641c_strToFloat [Str x] = case reads x of
642 [(n,"")] -> Just $ Fl n
644c_strToFloat _ = Nothing
646p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
647p_fPrim f [Fl x] = Just $ Fl (f x)
650p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
651p_floatExp = p_fPrim exp
652p_floatLog = p_fPrim log
653p_floatSin = p_fPrim sin
654p_floatCos = p_fPrim cos
655p_floatTan = p_fPrim tan
656p_floatASin = p_fPrim asin
657p_floatACos = p_fPrim acos
658p_floatATan = p_fPrim atan
659p_floatSqrt = p_fPrim sqrt
660p_floatFloor = p_fPrim (fromInteger . floor)
661p_floatCeil = p_fPrim (fromInteger . ceiling)
663p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const
664p_strLen [Str xs] = Just $ I (length xs)
666p_strHead [Str (x:xs)] = Just $ Ch x
668p_strTail [Str (x:xs)] = Just $ Str xs
670p_strIndex [Str xs, I i]
671 | i < length xs = Just $ Ch (xs!!i)
672p_strIndex _ = Nothing
673p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
675p_strRev [Str xs] = Just $ Str (reverse xs)
678p_cantreduce :: a -> Maybe b
679p_cantreduce _ = Nothing
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list