git.iko.soy/Idris-dev
on 49fffbc help sign in
Idris-dev/src/Idris/Primitives.hs
769 lines 36 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 Nothing (Constant t) (TType (UVar (-3)))) (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,
156 Prim (sUN "prim__negFloat") (ty [(AType ATFloat)] (AType ATFloat)) 1 (c_negFloat)
157 (1, LFNegate) total,
159 Prim (sUN "prim__strHead") (ty [StrType] (AType (ATInt ITChar))) 1 (p_strHead)
160 (1, LStrHead) partial,
161 Prim (sUN "prim__strTail") (ty [StrType] StrType) 1 (p_strTail)
162 (1, LStrTail) partial,
163 Prim (sUN "prim__strCons") (ty [(AType (ATInt ITChar)), StrType] StrType) 2 (p_strCons)
164 (2, LStrCons) total,
165 Prim (sUN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] (AType (ATInt ITChar))) 2 (p_strIndex)
166 (2, LStrIndex) partial,
167 Prim (sUN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
168 (1, LStrRev) total,
170 Prim (sUN "prim__readFile") (ty [WorldType,PtrType] StrType) 2 (p_cantreduce)
171 (2, LReadFile) total, -- total is okay, because we have 'WorldType'
172 Prim (sUN "prim__writeFile") (ty [WorldType,PtrType,StrType] (AType (ATInt ITNative))) 3 (p_cantreduce)
173 (3, LWriteFile) total,
174 Prim (sUN "prim__readString") (ty [WorldType] StrType) 1 (p_cantreduce)
175 (1, LReadStr) total, -- total is okay, because we have 'WorldType'
176 Prim (sUN "prim__writeString") (ty [WorldType,StrType] (AType (ATInt ITNative))) 2 (p_cantreduce)
177 (2, LWriteStr) total,
179 Prim (sUN "prim__vm") (ty [] PtrType) 0 (p_cantreduce)
180 (0, LVMPtr) total,
181 -- Streams
182 Prim (sUN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)
183 (0, LStdIn) total,
184 Prim (sUN "prim__stdout") (ty [] PtrType) 0 (p_cantreduce)
185 (0, LStdOut) total,
186 Prim (sUN "prim__stderr") (ty [] PtrType) 0 (p_cantreduce)
187 (0, LStdErr) total,
188 Prim (sUN "prim__null") (ty [] PtrType) 0 (p_cantreduce)
189 (0, LNullPtr) total,
190 -- Managed pointer registration
191 Prim (sUN "prim__registerPtr") (ty [PtrType, AType (ATInt ITNative)] ManagedPtrType) 2 (p_cantreduce)
192 (2, LRegisterPtr) total,
193 -- Buffers
194 Prim (sUN "prim__allocate") (ty [AType (ATInt (ITFixed IT64))] BufferType) 1 (p_allocate)
195 (1, LAllocate) total,
196 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)
197 (6, LAppendBuffer) partial,
198 Prim (sUN "prim__systemInfo") (ty [AType (ATInt ITNative)] StrType) 1 (p_cantreduce)
199 (1, LSystemInfo) total
200 ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative, ITChar]
201 ++ concatMap vecOps vecTypes
202 ++ concatMap fixedOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64] -- ITNative, ITChar, ATFloat ] ++ vecTypes
203 ++ vecBitcasts vecTypes
205vecTypes :: [IntTy]
206vecTypes = [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]
208intOps :: IntTy -> [Prim]
209intOps ity = intCmps ity ++ intArith ity ++ intConv ity
211intSCmps :: IntTy -> [Prim]
212intSCmps ity =
213 [ iCmp ity "slt" False (bCmp ity (sCmpOp ity (<))) (LSLt . ATInt) total
214 , iCmp ity "slte" False (bCmp ity (sCmpOp ity (<=))) (LSLe . ATInt) total
215 , iCmp ity "eq" False (bCmp ity (==)) (LEq . ATInt) total
216 , iCmp ity "sgte" False (bCmp ity (sCmpOp ity (>=))) (LSGe . ATInt) total
217 , iCmp ity "sgt" False (bCmp ity (sCmpOp ity (>))) (LSGt . ATInt) total
218 ]
220intCmps :: IntTy -> [Prim]
221intCmps ITNative = intSCmps ITNative
222intCmps ity =
223 intSCmps ity ++
224 [ iCmp ity "lt" False (bCmp ity (cmpOp ity (<))) LLt total
225 , iCmp ity "lte" False (bCmp ity (cmpOp ity (<=))) LLe total
226 , iCmp ity "gte" False (bCmp ity (cmpOp ity (>=))) LGe total
227 , iCmp ity "gt" False (bCmp ity (cmpOp ity (>))) LGt total
228 ]
230intArith :: IntTy -> [Prim]
231intArith ity =
232 [ iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
233 , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
234 , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
235 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
236 , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
237 , iBinOp ity "urem" (bitBin ity rem) LURem partial
238 , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
239 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
240 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
241 , iBinOp ity "ashr" (bashr ity) LASHR total
242 , iBinOp ity "and" (bitBin ity (.&.)) LAnd total
243 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
244 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
245 , iUnOp ity "compl" (bUn ity complement) LCompl total
246 ]
248intConv :: IntTy -> [Prim]
249intConv ity =
250 [ Prim (sUN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
251 (1, LIntStr ity) total
252 , Prim (sUN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
253 (1, LStrInt ity) total
254 , Prim (sUN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
255 (1, LIntFloat ity) total
256 , Prim (sUN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
257 (1, LFloatInt ity) total
258 ]
260vecCmps :: IntTy -> [Prim]
261vecCmps ity =
262 [ iCmp ity "slt" True (bCmp ity (<)) (LSLt . ATInt) total
263 , iCmp ity "slte" True (bCmp ity (<=)) (LSLe . ATInt) total
264 , iCmp ity "eq" True (bCmp ity (==)) (LEq . ATInt) total
265 , iCmp ity "sgte" True (bCmp ity (>=)) (LSGe . ATInt) total
266 , iCmp ity "sgt" True (bCmp ity (>)) (LSGt . ATInt) total
267 , iCmp ity "lt" True (bCmp ity (<)) LLt total
268 , iCmp ity "lte" True (bCmp ity (<=)) LLe total
269 , iCmp ity "gte" True (bCmp ity (>=)) LGe total
270 , iCmp ity "gt" True (bCmp ity (>)) LGt total
271 ]
273-- The TODOs in this function are documented as Issue #1617 on the issue tracker.
274--
275-- https://github.com/idris-lang/Idris-dev/issues/1617
276vecOps :: IntTy -> [Prim]
277vecOps ity@(ITVec elem count) =
278 [ Prim (sUN $ "prim__mk" ++ intTyName ity)
279 (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))
280 count (mkVecCon elem count) (count, LMkVec elem count) total
281 , Prim (sUN $ "prim__index" ++ intTyName ity)
282 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32))] (AType . ATInt . ITFixed $ elem))
283 2 (mkVecIndex count) (2, LIdxVec elem count) partial -- TODO: Ensure this reduces
284 , Prim (sUN $ "prim__update" ++ intTyName ity)
285 (ty [AType . ATInt $ ity, AType (ATInt (ITFixed IT32)), AType . ATInt . ITFixed $ elem]
286 (AType . ATInt $ ity))
287 3 (mkVecUpdate elem count) (3, LUpdateVec elem count) partial -- TODO: Ensure this reduces
288 ] ++ intArith ity ++ vecCmps ity
290bitcastPrim :: ArithTy -> ArithTy -> (ArithTy -> [Const] -> Maybe Const) -> PrimFn -> Prim
291bitcastPrim from to impl prim =
292 Prim (sUN $ "prim__bitcast" ++ aTyName from ++ "_" ++ aTyName to) (ty [AType from] (AType to)) 1 (impl to)
293 (1, prim) total
295vecBitcasts :: [IntTy] -> [Prim]
296vecBitcasts tys = [bitcastPrim from to bitcastVec (LBitCast from to)
297 | from <- map ATInt vecTypes, to <- map ATInt vecTypes, from /= to]
299fixedOps :: IntTy -> [Prim]
300fixedOps ity@(ITFixed _) =
301 map appendFun endiannesses ++
302 map peekFun endiannesses
303 where
304 endiannesses = [ Native, LE, BE ]
305 tyName = intTyName ity
306 b64 = AType (ATInt (ITFixed IT64))
307 thisTy = AType $ ATInt ity
308 appendFun en = Prim (sUN $ "prim__append" ++ tyName ++ show en)
309 (ty [BufferType, b64, b64, thisTy] BufferType)
310 4 (p_append en) (4, LAppend ity en) partial
311 peekFun en = Prim (sUN $ "prim__peek" ++ tyName ++ show en)
312 (ty [BufferType, b64] thisTy)
313 2 (p_peek ity en) (2, LPeek ity en) partial
315mapHalf :: (V.Unbox a, V.Unbox b) => ((a, a) -> b) -> Vector a -> Vector b
316mapHalf f xs = V.generate (V.length xs `div` 2) (\i -> f (xs V.! (i*2), xs V.! (i*2+1)))
318mapDouble :: (V.Unbox a, V.Unbox b) => (Bool -> a -> b) -> Vector a -> Vector b
319mapDouble f xs = V.generate (V.length xs * 2) (\i -> f (i `rem` 2 == 0) (xs V.! (i `div` 2)))
321concatWord8 :: (Word8, Word8) -> Word16
322concatWord8 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 8)
324concatWord16 :: (Word16, Word16) -> Word32
325concatWord16 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 16)
327concatWord32 :: (Word32, Word32) -> Word64
328concatWord32 (high, low) = fromIntegral high .|. (fromIntegral low `shiftL` 32)
330truncWord16 :: Bool -> Word16 -> Word8
331truncWord16 True x = fromIntegral (x `shiftR` 8)
332truncWord16 False x = fromIntegral x
334truncWord32 :: Bool -> Word32 -> Word16
335truncWord32 True x = fromIntegral (x `shiftR` 16)
336truncWord32 False x = fromIntegral x
338truncWord64 :: Bool -> Word64 -> Word32
339truncWord64 True x = fromIntegral (x `shiftR` 32)
340truncWord64 False x = fromIntegral x
342bitcastVec :: ArithTy -> [Const] -> Maybe Const
343bitcastVec (ATInt (ITVec IT8 n)) [x@(B8V v)]
344 | V.length v == n = Just x
345bitcastVec (ATInt (ITVec IT16 n)) [B8V v]
346 | V.length v == n*2 = Just . B16V . mapHalf concatWord8 $ v
347bitcastVec (ATInt (ITVec IT32 n)) [B8V v]
348 | V.length v == n*4 = Just . B32V . mapHalf concatWord16 . mapHalf concatWord8 $ v
349bitcastVec (ATInt (ITVec IT64 n)) [B8V v]
350 | V.length v == n*8 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 . mapHalf concatWord8 $ v
352bitcastVec (ATInt (ITVec IT8 n)) [B16V v]
353 | V.length v * 2 == n = Just . B8V . mapDouble truncWord16 $ v
354bitcastVec (ATInt (ITVec IT16 n)) [x@(B16V v)]
355 | V.length v == n = Just x
356bitcastVec (ATInt (ITVec IT32 n)) [B16V v]
357 | V.length v == n*2 = Just . B32V . mapHalf concatWord16 $ v
358bitcastVec (ATInt (ITVec IT64 n)) [B16V v]
359 | V.length v == n*4 = Just . B64V . mapHalf concatWord32 . mapHalf concatWord16 $ v
361bitcastVec (ATInt (ITVec IT8 n)) [B32V v]
362 | V.length v * 4 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 $ v
363bitcastVec (ATInt (ITVec IT16 n)) [B32V v]
364 | V.length v * 2 == n = Just . B16V . mapDouble truncWord32 $ v
365bitcastVec (ATInt (ITVec IT32 n)) [x@(B32V v)]
366 | V.length v == n = Just x
367bitcastVec (ATInt (ITVec IT64 n)) [B32V v]
368 | V.length v == n*2 = Just . B64V . mapHalf concatWord32 $ v
370bitcastVec (ATInt (ITVec IT8 n)) [B64V v]
371 | V.length v * 8 == n = Just . B8V . mapDouble truncWord16 . mapDouble truncWord32 . mapDouble truncWord64 $ v
372bitcastVec (ATInt (ITVec IT16 n)) [B64V v]
373 | V.length v * 4 == n = Just . B16V . mapDouble truncWord32 . mapDouble truncWord64 $ v
374bitcastVec (ATInt (ITVec IT32 n)) [B64V v]
375 | V.length v == n*2 = Just . B32V . mapDouble truncWord64 $ v
376bitcastVec (ATInt (ITVec IT64 n)) [x@(B64V v)]
377 | V.length v == n = Just x
379bitcastVec _ _ = Nothing
381mkVecCon :: NativeTy -> Int -> [Const] -> Maybe Const
382mkVecCon ity count args
383 | length ints == count = Just (mkVec ity count ints)
384 | otherwise = Nothing
385 where
386 ints = getInt args
387 mkVec :: NativeTy -> Int -> [Integer] -> Const
388 mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))
389 mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))
390 mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))
391 mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))
393mkVecIndex count [vec, B32 i] = Just (idxVec vec)
394 where
395 idxVec :: Const -> Const
396 idxVec (B8V v) = B8 $ V.unsafeIndex v (fromIntegral i)
397 idxVec (B16V v) = B16 $ V.unsafeIndex v (fromIntegral i)
398 idxVec (B32V v) = B32 $ V.unsafeIndex v (fromIntegral i)
399 idxVec (B64V v) = B64 $ V.unsafeIndex v (fromIntegral i)
400mkVecIndex _ _ = Nothing
402mkVecUpdate ity count [vec, B32 i, newElem] = updateVec vec newElem
403 where
404 updateVec :: Const -> Const -> Maybe Const
405 updateVec (B8V v) (B8 e) = Just . B8V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
406 updateVec (B16V v) (B16 e) = Just . B16V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
407 updateVec (B32V v) (B32 e) = Just . B32V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
408 updateVec (B64V v) (B64 e) = Just . B64V $ V.unsafeUpdate v (V.singleton (fromIntegral i, e))
409 updateVec _ _ = Nothing
410mkVecUpdate _ _ _ = Nothing
412aTyName :: ArithTy -> String
413aTyName (ATInt t) = intTyName t
414aTyName ATFloat = "Float"
416iCmp :: IntTy -> String -> Bool -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
417iCmp ity op self impl irop totality
418 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
419 (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt (if self then ity else ITNative))))
420 2 impl (2, irop ity) totality
422iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
423iBinOp ity op impl irop totality
424 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
425 (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
426 2 impl (2, irop ity) totality
427iUnOp ity op impl irop totality
428 = Prim (sUN $ "prim__" ++ op ++ intTyName ity)
429 (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
430 1 impl (1, irop ity) totality
432iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
433iCoerce from to op impl irop =
434 Prim (sUN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
435 (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
437fBin :: (Double -> Double -> Double) -> [Const] -> Maybe Const
438fBin op [Fl x, Fl y] = Just $ Fl (op x y)
439fBin _ _ = Nothing
441bfBin :: (Double -> Double -> Bool) -> [Const] -> Maybe Const
442bfBin op [Fl x, Fl y] = let i = (if op x y then 1 else 0) in
443 Just $ I i
444bfBin _ _ = Nothing
446bcBin :: (Char -> Char -> Bool) -> [Const] -> Maybe Const
447bcBin op [Ch x, Ch y] = let i = (if op x y then 1 else 0) in
448 Just $ I i
449bcBin _ _ = Nothing
451bsBin :: (String -> String -> Bool) -> [Const] -> Maybe Const
452bsBin op [Str x, Str y]
453 = let i = (if op x y then 1 else 0) in
454 Just $ I i
455bsBin _ _ = Nothing
457sBin :: (String -> String -> String) -> [Const] -> Maybe Const
458sBin op [Str x, Str y] = Just $ Str (op x y)
459sBin _ _ = Nothing
461bsrem :: IntTy -> [Const] -> Maybe Const
462bsrem ITBig [BI x, BI y] = Just . BI $ x `rem` y
463bsrem (ITFixed IT8) [B8 x, B8 y]
464 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
465bsrem (ITFixed IT16) [B16 x, B16 y]
466 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
467bsrem (ITFixed IT32) [B32 x, B32 y]
468 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
469bsrem (ITFixed IT64) [B64 x, B64 y]
470 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
471bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
472bsrem ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `rem` (ord y))
473bsrem (ITVec IT8 _) [B8V x, B8V y]
474 = Just . B8V $
475 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int8))) x y
476bsrem (ITVec IT16 _) [B16V x, B16V y]
477 = Just . B16V $
478 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int16))) x y
479bsrem (ITVec IT32 _) [B32V x, B32V y]
480 = Just . B32V $
481 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
482bsrem (ITVec IT64 _) [B64V x, B64V y]
483 = Just . B64V $
484 V.zipWith (\n d -> (fromIntegral (fromIntegral n `rem` fromIntegral d :: Int64))) x y
485bsrem _ _ = Nothing
487bsdiv :: IntTy -> [Const] -> Maybe Const
488bsdiv ITBig [BI x, BI y] = Just . BI $ x `div` y
489bsdiv (ITFixed IT8) [B8 x, B8 y]
490 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
491bsdiv (ITFixed IT16) [B16 x, B16 y]
492 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
493bsdiv (ITFixed IT32) [B32 x, B32 y]
494 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
495bsdiv (ITFixed IT64) [B64 x, B64 y]
496 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
497bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
498bsdiv ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `div` (ord y))
499bsdiv (ITVec IT8 _) [B8V x, B8V y]
500 = Just . B8V $
501 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int8))) x y
502bsdiv (ITVec IT16 _) [B16V x, B16V y]
503 = Just . B16V $
504 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int16))) x y
505bsdiv (ITVec IT32 _) [B32V x, B32V y]
506 = Just . B32V $
507 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
508bsdiv (ITVec IT64 _) [B64V x, B64V y]
509 = Just . B64V $
510 V.zipWith (\n d -> (fromIntegral (fromIntegral n `div` fromIntegral d :: Int64))) x y
511bsdiv _ _ = Nothing
513bashr :: IntTy -> [Const] -> Maybe Const
514bashr ITBig [BI x, BI y] = Just $ BI (x `shiftR` fromIntegral y)
515bashr (ITFixed IT8) [B8 x, B8 y]
516 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
517bashr (ITFixed IT16) [B16 x, B16 y]
518 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
519bashr (ITFixed IT32) [B32 x, B32 y]
520 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
521bashr (ITFixed IT64) [B64 x, B64 y]
522 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
523bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
524bashr ITChar [Ch x, Ch y] = Just $ Ch (chr $ (ord x) `shiftR` (ord y))
525bashr (ITVec IT8 _) [B8V x, B8V y]
526 = Just . B8V $
527 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int8))) x y
528bashr (ITVec IT16 _) [B16V x, B16V y]
529 = Just . B16V $
530 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int16))) x y
531bashr (ITVec IT32 _) [B32V x, B32V y]
532 = Just . B32V $
533 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
534bashr (ITVec IT64 _) [B64V x, B64V y]
535 = Just . B64V $
536 V.zipWith (\n d -> (fromIntegral (fromIntegral n `shiftR` fromIntegral d :: Int64))) x y
537bashr _ _ = Nothing
539bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
540bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
541bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
542bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
543bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
544bUn ITBig op [BI x] = Just $ BI (op x)
545bUn ITNative op [I x] = Just $ I (op x)
546bUn ITChar op [Ch x] = Just $ Ch (chr $ op (ord x))
547bUn (ITVec IT8 _) op [B8V x] = Just . B8V $ V.map op x
548bUn (ITVec IT16 _) op [B16V x] = Just . B16V $ V.map op x
549bUn (ITVec IT32 _) op [B32V x] = Just . B32V $ V.map op x
550bUn (ITVec IT64 _) op [B64V x] = Just . B64V $ V.map op x
551bUn _ _ _ = Nothing
553bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
554bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
555bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
556bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
557bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
558bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
559bitBin ITNative op [I x, I y] = Just $ I (op x y)
560bitBin ITChar op [Ch x, Ch y] = Just $ Ch (chr $ op (ord x) (ord y))
561bitBin (ITVec IT8 _) op [B8V x, B8V y] = Just . B8V $ V.zipWith op x y
562bitBin (ITVec IT16 _) op [B16V x, B16V y] = Just . B16V $ V.zipWith op x y
563bitBin (ITVec IT32 _) op [B32V x, B32V y] = Just . B32V $ V.zipWith op x y
564bitBin (ITVec IT64 _) op [B64V x, B64V y] = Just . B64V $ V.zipWith op x y
565bitBin _ _ _ = Nothing
567bCmp :: IntTy -> (forall a. (Integral a, Ord a) => a -> a -> Bool) -> [Const] -> Maybe Const
568bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
569bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
570bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
571bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
572bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
573bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
574bCmp ITChar op [Ch x, Ch y] = Just $ I (if (op (ord x) (ord y)) then 1 else 0)
575bCmp (ITVec IT8 _) op [B8V x, B8V y]
576 = Just . B8V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
577bCmp (ITVec IT16 _) op [B16V x, B16V y]
578 = Just . B16V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
579bCmp (ITVec IT32 _) op [B32V x, B32V y]
580 = Just . B32V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
581bCmp (ITVec IT64 _) op [B64V x, B64V y]
582 = Just . B64V . V.map (\b -> if b then -1 else 0) $ V.zipWith op x y
583bCmp _ _ _ = Nothing
586cmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
587cmpOp (ITFixed _) f = f
588cmpOp (ITNative) f = f `on` (fromIntegral :: Integral a => a -> Word)
589cmpOp (ITChar) f = f `on` ((fromIntegral :: Integral a => a -> Word))
590cmpOp _ f = let xor = (/=) in (\ x y -> (f x y) `xor` (x < 0) `xor` (y < 0))
592sCmpOp :: (Ord a, Integral a) => IntTy -> (forall b. Ord b => b -> b -> Bool) -> a -> a -> Bool
593sCmpOp (ITFixed IT8) f = f `on` (fromIntegral :: Integral a => a -> Int8)
594sCmpOp (ITFixed IT16) f = f `on` (fromIntegral :: Integral a => a -> Int16)
595sCmpOp (ITFixed IT32) f = f `on` (fromIntegral :: Integral a => a -> Int32)
596sCmpOp (ITFixed IT64) f = f `on` (fromIntegral :: Integral a => a -> Int64)
597sCmpOp _ f = f
599toInt :: Integral a => IntTy -> a -> Const
600toInt (ITFixed IT8) x = B8 (fromIntegral x)
601toInt (ITFixed IT16) x = B16 (fromIntegral x)
602toInt (ITFixed IT32) x = B32 (fromIntegral x)
603toInt (ITFixed IT64) x = B64 (fromIntegral x)
604toInt ITBig x = BI (fromIntegral x)
605toInt ITNative x = I (fromIntegral x)
606toInt ITChar x = Ch (chr $ fromIntegral x)
608intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
609intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
610intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
611intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
612intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
613intToInt ITBig out [BI x] = Just $ toInt out x
614intToInt ITNative out [I x] = Just $ toInt out x
615intToInt ITChar out [Ch x] = Just $ toInt out (ord x)
616intToInt _ _ _ = Nothing
618zext :: IntTy -> IntTy -> [Const] -> Maybe Const
619zext from ITBig val = intToInt from ITBig val
620zext ITBig _ _ = Nothing
621zext f@(ITFixed from) t@(ITFixed to) val
622 | nativeTyWidth from < nativeTyWidth to = intToInt f t val
623zext ITNative to [I x] = Just $ toInt to (fromIntegral x :: Word)
624zext from ITNative val = intToInt from ITNative val
625zext _ _ _ = Nothing
627sext :: IntTy -> IntTy -> [Const] -> Maybe Const
628sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
629sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
630sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
631sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
632sext ITBig _ _ = Nothing
633sext from to val = intToInt from to val
635trunc :: IntTy -> IntTy -> [Const] -> Maybe Const
636trunc ITBig to val = intToInt ITBig to val
637trunc _ ITBig _ = Nothing
638trunc f@(ITFixed from) t@(ITFixed to) val | nativeTyWidth from > nativeTyWidth to = intToInt f t val
639trunc ITNative to [I x] = Just $ toInt to x
640trunc from ITNative val = intToInt from ITNative val
641trunc _ _ _ = Nothing
643intToStr :: [Const] -> Maybe Const
644intToStr val | [i] <- getInt val = Just $ Str (show i)
645intToStr _ = Nothing
647getInt :: [Const] -> [Integer]
648getInt (B8 x : xs) = toInteger x : getInt xs
649getInt (B16 x : xs) = toInteger x : getInt xs
650getInt (B32 x : xs) = toInteger x : getInt xs
651getInt (B64 x : xs) = toInteger x : getInt xs
652getInt (I x : xs) = toInteger x : getInt xs
653getInt (BI x : xs) = x : getInt xs
654getInt _ = []
656strToInt :: IntTy -> [Const] -> Maybe Const
657strToInt ity [Str x] = case reads x of
658 [(n,"")] -> Just $ toInt ity (n :: Integer)
659 _ -> Just $ I 0
660strToInt _ _ = Nothing
662intToFloat :: [Const] -> Maybe Const
663intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
664intToFloat _ = Nothing
666floatToInt :: IntTy -> [Const] -> Maybe Const
667floatToInt ity [Fl x] = Just $ toInt ity (truncate x :: Integer)
668floatToInt _ _ = Nothing
670c_intToChar, c_charToInt :: [Const] -> Maybe Const
671c_intToChar [(I x)] = Just . Ch . toEnum $ x
672c_intToChar _ = Nothing
673c_charToInt [(Ch x)] = Just . I . fromEnum $ x
674c_charToInt _ = Nothing
676c_negFloat :: [Const] -> Maybe Const
677c_negFloat [Fl x] = Just $ Fl (negate x)
678c_negFloat _ = Nothing
680c_floatToStr :: [Const] -> Maybe Const
681c_floatToStr [Fl x] = Just $ Str (show x)
682c_floatToStr _ = Nothing
683c_strToFloat [Str x] = case reads x of
684 [(n,"")] -> Just $ Fl n
685 _ -> Just $ Fl 0
686c_strToFloat _ = Nothing
688p_fPrim :: (Double -> Double) -> [Const] -> Maybe Const
689p_fPrim f [Fl x] = Just $ Fl (f x)
690p_fPrim f _ = Nothing
692p_floatExp, p_floatLog, p_floatSin, p_floatCos, p_floatTan, p_floatASin, p_floatACos, p_floatATan, p_floatSqrt, p_floatFloor, p_floatCeil :: [Const] -> Maybe Const
693p_floatExp = p_fPrim exp
694p_floatLog = p_fPrim log
695p_floatSin = p_fPrim sin
696p_floatCos = p_fPrim cos
697p_floatTan = p_fPrim tan
698p_floatASin = p_fPrim asin
699p_floatACos = p_fPrim acos
700p_floatATan = p_fPrim atan
701p_floatSqrt = p_fPrim sqrt
702p_floatFloor = p_fPrim (fromInteger . floor)
703p_floatCeil = p_fPrim (fromInteger . ceiling)
705p_strLen, p_strHead, p_strTail, p_strIndex, p_strCons, p_strRev :: [Const] -> Maybe Const
706p_strLen [Str xs] = Just $ I (length xs)
707p_strLen _ = Nothing
708p_strHead [Str (x:xs)] = Just $ Ch x
709p_strHead _ = Nothing
710p_strTail [Str (x:xs)] = Just $ Str xs
711p_strTail _ = Nothing
712p_strIndex [Str xs, I i]
713 | i < length xs = Just $ Ch (xs!!i)
714p_strIndex _ = Nothing
715p_strCons [Ch x, Str xs] = Just $ Str (x:xs)
716p_strCons _ = Nothing
717p_strRev [Str xs] = Just $ Str (reverse xs)
718p_strRev _ = Nothing
720p_allocate, p_appendBuffer :: [Const] -> Maybe Const
721p_allocate [B64 _] = Just $ B8V V.empty
722p_allocate n = Nothing
723p_appendBuffer [B8V vect1, B64 size1, B64 count, B64 size2, B64 off, B8V vect2] =
724 Just $ B8V (foldl (V.++)
725 (V.slice 0 (fromIntegral size1) vect1)
726 (replicate (fromIntegral count) (V.slice (fromIntegral off) (fromIntegral size2) vect2)))
727p_appendBuffer n = Nothing
728p_append :: Endianness -> [Const] -> Maybe Const
729p_append en [B8V vect, B64 size, B64 count, val] =
730 let bytes = case val of
731 B8 x -> [x]
732 B16 x -> [fromIntegral x, fromIntegral (shiftR x 8)]
733 B32 x -> map (fromIntegral . shiftR x) [0,8..24]
734 B64 x -> map (fromIntegral . shiftR x) [0,8..56]
735 in Just $ B8V (foldl V.snoc
736 (V.slice 0 (fromIntegral size) vect)
737 (concat (replicate (fromIntegral count)
738 (case en of
739 BE -> reverse bytes
740 _ -> bytes))))
741p_append _ _ = Nothing
743p_peek :: IntTy -> Endianness -> [Const] -> Maybe Const
744p_peek (ITFixed IT8) _ [B8V vect, B64 offset] = Just $ B8 (vect V.! fromIntegral offset)
745p_peek (ITFixed IT16) en [B8V vect, B64 offset] =
746 let bytes = [0..1]
747 in Just $ B16 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))
748 0
749 (case en of
750 BE -> bytes
751 _ -> reverse bytes))
752p_peek (ITFixed IT32) en [B8V vect, B64 offset] =
753 let bytes = [0..1]
754 in Just $ B32 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))
755 0
756 (case en of
757 BE -> bytes
758 _ -> reverse bytes))
759p_peek (ITFixed IT64) en [B8V vect, B64 offset] =
760 let bytes = [0..1]
761 in Just $ B64 (foldl (\full byte -> shiftL full 8 .|. fromIntegral (vect V.! (fromIntegral offset+byte)))
762 0
763 (case en of
764 BE -> bytes
765 _ -> reverse bytes))
766p_peek _ _ _ = Nothing
768p_cantreduce :: a -> Maybe b
769p_cantreduce _ = Nothing