git.iko.soy/Idris-dev
on master help sign in
Beginnings of integer SIMD support (no backend yet)
commit0aa3fd6b3c49ab6100b6c49be4b3692ee724d199 authorBenjamin Saunders <besaunde@sfu.ca> dateMon 17 Jun 2013, 17:05 (13 years ago) parent8c02d2a
18 files changed+695−607
compare with master
unifiedsplit
idris.cabal+2−1 src/Core/CaseTree.hs+14−8 src/Core/Evaluate.hs+15−10 src/Core/Execute.hs+26−23 src/Core/TT.hs+56−18 src/Core/Typecheck.hs+12−7 src/IRTS/CodegenC.hs+88−77 src/IRTS/CodegenJava.hs+79−79 src/IRTS/CodegenJavaScript.hs+29−29 src/IRTS/CodegenLLVM.hs+86−81 src/IRTS/Compiler.hs+12−12 src/IRTS/LParser.hs+29−29 src/IRTS/Lang.hs+6−27 src/Idris/ElabDecls.hs+1−1 src/Idris/ElabTerm.hs+15−15 src/Idris/IBC.hs+21−15 src/Idris/Parser.hs+7−7 src/Idris/Primitives.hs+197−168
idris.cabal+2−1
@@ -272,7 +272,8 @@ Executable idris
272272 haskeline>=0.7, split, directory,
273273 containers, process, transformers, filepath,
274274 directory, binary, bytestring, text, pretty,
275− language-java>=0.2.2, libffi, llvm-general==3.3.3.*
275+ language-java>=0.2.2, libffi, llvm-general==3.3.3.*,
276+ vector
276277
277278 Extensions: MultiParamTypeClasses, FunctionalDependencies,
278279 FlexibleInstances, TemplateHaskell
src/Core/CaseTree.hs+14−8
@@ -228,17 +228,18 @@ toPat tc tms = evalState (mapM (\x -> toPat' x []) tms) []
228228 toPat' (P (TCon t a) n _) args | tc
229229 = do args' <- mapM (\x -> toPat' x []) args
230230 return $ PCon n t args'
231− toPat' (Constant IType) [] | tc = return $ PCon (UN "Int") 1 []
232− toPat' (Constant FlType) [] | tc = return $ PCon (UN "Float") 2 []
231+ toPat' (Constant (AType (ATInt ITNative))) []
232+ | tc = return $ PCon (UN "Int") 1 []
233+ toPat' (Constant (AType ATFloat)) [] | tc = return $ PCon (UN "Float") 2 []
233234 toPat' (Constant ChType) [] | tc = return $ PCon (UN "Char") 3 []
234235 toPat' (Constant StrType) [] | tc = return $ PCon (UN "String") 4 []
235236 toPat' (Constant PtrType) [] | tc = return $ PCon (UN "Ptr") 5 []
236− toPat' (Constant BIType) [] | tc = return $ PCon (UN "Integer") 6 []
237− toPat' (Constant B8Type) [] | tc = return $ PCon (UN "Bits8") 7 []
238− toPat' (Constant B16Type) [] | tc = return $ PCon (UN "Bits16") 8 []
239− toPat' (Constant B32Type) [] | tc = return $ PCon (UN "Bits32") 9 []
240− toPat' (Constant B64Type) [] | tc = return $ PCon (UN "Bits64") 10 []
241−
237+ toPat' (Constant (AType (ATInt ITBig))) []
238+ | tc = return $ PCon (UN "Integer") 6 []
239+ toPat' (Constant (AType (ATInt (ITFixed n)))) []
240+ | tc = return $ PCon (UN (fixedN n)) (7 + fromEnum n) [] -- 7-10 inclusive
241+ toPat' (Constant (AType (ATInt (ITVec ity count)))) []
242+ | tc = return $ PCon (UN (fixedN ity)) ((fromEnum ity + 1) * 1000 + count) [] -- 1000-5000 inclusive
242243 toPat' (P Bound n _) [] = do ns <- get
243244 if n `elem` ns
244245 then return PAny
@@ -248,6 +249,11 @@ toPat tc tms = evalState (mapM (\x -> toPat' x []) tms) []
248249 toPat' (Constant x) [] = return $ PConst x
249250 toPat' _ _ = return PAny
250251
252+ fixedN IT8 = "Bits8"
253+ fixedN IT16 = "Bits16"
254+ fixedN IT32 = "Bits32"
255+ fixedN IT64 = "Bits64"
256+
251257
252258data Partition = Cons [Clause]
253259 | Vars [Clause]
src/Core/Evaluate.hs+15−10
@@ -329,11 +329,16 @@ eval traceon ctxt ntimes genv tm opts = ev ntimes [] True [] tm where
329329
330330 findConst c [] = Nothing
331331 findConst c (ConstCase c' v : xs) | c == c' = Just v
332− findConst IType (ConCase n 1 [] v : xs) = Just v
333− findConst FlType (ConCase n 2 [] v : xs) = Just v
332+ findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v
333+ findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v
334334 findConst ChType (ConCase n 3 [] v : xs) = Just v
335335 findConst StrType (ConCase n 4 [] v : xs) = Just v
336− findConst PtrType (ConCase n 5 [] v : xs) = Just v
336+ findConst PtrType (ConCase n 5 [] v : xs) = Just v
337+ findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v
338+ findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs)
339+ | tag == 7 + fromEnum ity = Just v
340+ findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs)
341+ | tag == (fromEnum ity + 1) * 1000 + count = Just v
337342 findConst c (_ : xs) = findConst c xs
338343
339344 getValArgs tm = getValArgs' tm []
@@ -517,16 +522,16 @@ eval_hnf ctxt statics genv tm = ev [] tm where
517522
518523 findConst c [] = Nothing
519524 findConst c (ConstCase c' v : xs) | c == c' = Just v
520− findConst IType (ConCase n 1 [] v : xs) = Just v
521− findConst FlType (ConCase n 2 [] v : xs) = Just v
525+ findConst (AType (ATInt ITNative)) (ConCase n 1 [] v : xs) = Just v
526+ findConst (AType ATFloat) (ConCase n 2 [] v : xs) = Just v
522527 findConst ChType (ConCase n 3 [] v : xs) = Just v
523528 findConst StrType (ConCase n 4 [] v : xs) = Just v
524529 findConst PtrType (ConCase n 5 [] v : xs) = Just v
525− findConst BIType (ConCase n 6 [] v : xs) = Just v
526− findConst B8Type (ConCase n 7 [] v : xs) = Just v
527− findConst B16Type (ConCase n 8 [] v : xs) = Just v
528− findConst B32Type (ConCase n 9 [] v : xs) = Just v
529− findConst B64Type (ConCase n 10 [] v : xs) = Just v
530+ findConst (AType (ATInt ITBig)) (ConCase n 6 [] v : xs) = Just v
531+ findConst (AType (ATInt (ITFixed ity))) (ConCase n tag [] v : xs)
532+ | tag == 7 + fromEnum ity = Just v
533+ findConst (AType (ATInt (ITVec ity count))) (ConCase n tag [] v : xs)
534+ | tag == (fromEnum ity + 1) * 1000 + count = Just v
530535 findConst c (_ : xs) = findConst c xs
531536
532537 getValArgs (HApp t env args) = (t, env, args)
src/Core/Execute.hs+26−23
@@ -3,9 +3,7 @@ module Core.Execute (execute) where
33
44import Idris.AbsSyntax
55import Idris.AbsSyntaxTree
6−import IRTS.Lang( IntTy(..)
7− , intTyToConst
8− , FType(..))
6+import IRTS.Lang(FType(..))
97
108import Idris.Primitives(Prim(..), primitives)
119
@@ -387,8 +385,7 @@ chooseAlt _ [] = Nothing
387385idrisType :: FType -> ExecVal
388386idrisType FUnit = EP Ref unitTy EErased
389387idrisType ft = EConstant (idr ft)
390− where idr (FInt ty) = intTyToConst ty
391− idr FDouble = FlType
388+ where idr (FArith ty) = AType ty
392389 idr FChar = ChType
393390 idr FString = StrType
394391 idr FPtr = PtrType
@@ -404,18 +401,24 @@ call (FFun name argTypes retType) args =
404401 Just f -> do res <- call' f args retType
405402 return . Just . ioWrap $ res
406403 where call' :: ForeignFun -> [ExecVal] -> FType -> Exec ExecVal
407− call' (Fun _ h) args (FInt ITNative) = do res <- execIO $ callFFI h retCInt (prepArgs args)
408− return (EConstant (I (fromIntegral res)))
409− call' (Fun _ h) args (FInt IT8) = do res <- execIO $ callFFI h retCChar (prepArgs args)
410− return (EConstant (B8 (fromIntegral res)))
411− call' (Fun _ h) args (FInt IT16) = do res <- execIO $ callFFI h retCWchar (prepArgs args)
412− return (EConstant (B16 (fromIntegral res)))
413− call' (Fun _ h) args (FInt IT32) = do res <- execIO $ callFFI h retCInt (prepArgs args)
414− return (EConstant (B32 (fromIntegral res)))
415− call' (Fun _ h) args (FInt IT64) = do res <- execIO $ callFFI h retCLong (prepArgs args)
416− return (EConstant (B64 (fromIntegral res)))
417− call' (Fun _ h) args FDouble = do res <- execIO $ callFFI h retCDouble (prepArgs args)
418− return (EConstant (Fl (realToFrac res)))
404+ call' (Fun _ h) args (FArith (ATInt ITNative)) = do
405+ res <- execIO $ callFFI h retCInt (prepArgs args)
406+ return (EConstant (I (fromIntegral res)))
407+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT8))) = do
408+ res <- execIO $ callFFI h retCChar (prepArgs args)
409+ return (EConstant (B8 (fromIntegral res)))
410+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT16))) = do
411+ res <- execIO $ callFFI h retCWchar (prepArgs args)
412+ return (EConstant (B16 (fromIntegral res)))
413+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT32))) = do
414+ res <- execIO $ callFFI h retCInt (prepArgs args)
415+ return (EConstant (B32 (fromIntegral res)))
416+ call' (Fun _ h) args (FArith (ATInt (ITFixed IT64))) = do
417+ res <- execIO $ callFFI h retCLong (prepArgs args)
418+ return (EConstant (B64 (fromIntegral res)))
419+ call' (Fun _ h) args (FArith ATFloat) = do
420+ res <- execIO $ callFFI h retCDouble (prepArgs args)
421+ return (EConstant (Fl (realToFrac res)))
419422 call' (Fun _ h) args FChar = do res <- execIO $ callFFI h retCChar (prepArgs args)
420423 return (EConstant (Ch (castCCharToChar res)))
421424 call' (Fun _ h) args FString = do res <- execIO $ callFFI h retCString (prepArgs args)
@@ -456,15 +459,15 @@ foreignFromTT t = case (unApplyV t) of
456459getFTy :: ExecVal -> Maybe FType
457460getFTy (EApp (EP _ (UN "FIntT") _) (EP _ (UN intTy) _)) =
458461 case intTy of
459− "ITNative" -> Just $ FInt ITNative
460− "IT8" -> Just $ FInt IT8
461− "IT16" -> Just $ FInt IT16
462− "IT32" -> Just $ FInt IT32
463− "IT64" -> Just $ FInt IT64
462+ "ITNative" -> Just (FArith (ATInt ITNative))
463+ "IT8" -> Just (FArith (ATInt (ITFixed IT8)))
464+ "IT16" -> Just (FArith (ATInt (ITFixed IT16)))
465+ "IT32" -> Just (FArith (ATInt (ITFixed IT32)))
466+ "IT64" -> Just (FArith (ATInt (ITFixed IT64)))
464467 _ -> Nothing
465468getFTy (EP _ (UN t) _) =
466469 case t of
467− "FFloat" -> Just FDouble
470+ "FFloat" -> Just (FArith ATFloat)
468471 "FChar" -> Just FChar
469472 "FString" -> Just FString
470473 "FPtr" -> Just FPtr
src/Core/TT.hs+56−18
@@ -25,8 +25,11 @@ import Debug.Trace
2525import qualified Data.Map as Map
2626import Data.Char
2727import Data.List
28+import Data.Vector.Unboxed (Vector)
29+import qualified Data.Vector.Unboxed as V
2830import qualified Data.Binary as B
2931import Data.Binary hiding (get, put)
32+import Foreign.Storable (sizeOf)
3033
3134import Util.Pretty hiding (Str)
3235
@@ -274,12 +277,46 @@ addAlist :: Show a => [(Name, a)] -> Ctxt a -> Ctxt a
274277addAlist [] ctxt = ctxt
275278addAlist ((n, tm) : ds) ctxt = addDef n tm (addAlist ds ctxt)
276279
277−data Const = I Int | BI Integer | Fl Double | Ch Char | Str String
278− | IType | BIType | FlType | ChType | StrType
280+data NativeTy = IT8 | IT16 | IT32 | IT64
281+ deriving (Show, Eq, Ord, Enum)
282+
283+instance Pretty NativeTy where
284+ pretty IT8 = text "Bits8"
285+ pretty IT16 = text "Bits16"
286+ pretty IT32 = text "Bits32"
287+ pretty IT64 = text "Bits64"
288+
289+data IntTy = ITFixed NativeTy | ITNative | ITBig
290+ | ITVec NativeTy Int
291+ deriving (Show, Eq, Ord)
292+
293+data ArithTy = ATInt IntTy | ATFloat -- TODO: Float vectors
294+ deriving (Show, Eq, Ord)
295+
296+instance Pretty ArithTy where
297+ pretty (ATInt ITNative) = text "Int"
298+ pretty (ATInt ITBig) = text "BigInt"
299+ pretty (ATInt (ITFixed n)) = pretty n
300+ pretty (ATInt (ITVec e c)) = pretty e <> text "x" <> (text . show $ c)
301+ pretty ATFloat = text "Float"
302+
303+nativeTyWidth :: NativeTy -> Int
304+nativeTyWidth IT8 = 8
305+nativeTyWidth IT16 = 16
306+nativeTyWidth IT32 = 32
307+nativeTyWidth IT64 = 64
308+
309+{-# DEPRECATED intTyWidth "Non-total function, use nativeTyWidth and appropriate casing" #-}
310+intTyWidth :: IntTy -> Int
311+intTyWidth (ITFixed n) = nativeTyWidth n
312+intTyWidth ITNative = 8 * sizeOf (0 :: Int)
313+intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"
279314
315+data Const = I Int | BI Integer | Fl Double | Ch Char | Str String
280316 | B8 Word8 | B16 Word16 | B32 Word32 | B64 Word64
281− | B8Type | B16Type | B32Type | B64Type
282−
317+ | B8V (Vector Word8) | B16V (Vector Word16)
318+ | B32V (Vector Word32) | B64V (Vector Word64)
319+ | AType ArithTy | ChType | StrType
283320 | PtrType | VoidType | Forgot
284321 deriving (Eq, Ord)
285322{-!
@@ -295,18 +332,12 @@ instance Pretty Const where
295332 pretty (Fl f) = text . show $ f
296333 pretty (Ch c) = text . show $ c
297334 pretty (Str s) = text s
298− pretty IType = text "Int"
299− pretty BIType = text "BigInt"
300− pretty FlType = text "Float"
335+ pretty (AType a) = pretty a
301336 pretty ChType = text "Char"
302337 pretty StrType = text "String"
303338 pretty PtrType = text "Ptr"
304339 pretty VoidType = text "Void"
305340 pretty Forgot = text "Forgot"
306− pretty B8Type = text "Bits8"
307− pretty B16Type = text "Bits16"
308− pretty B32Type = text "Bits32"
309− pretty B64Type = text "Bits64"
310341 pretty (B8 w) = text . show $ w
311342 pretty (B16 w) = text . show $ w
312343 pretty (B32 w) = text . show $ w
@@ -728,6 +759,11 @@ type WkEnv = WkEnvTT Name
728759instance (Eq n, Show n) => Show (TT n) where
729760 show t = showEnv [] t
730761
762+itBitsName IT8 = "Bits8"
763+itBitsName IT16 = "Bits16"
764+itBitsName IT32 = "Bits32"
765+itBitsName IT64 = "Bits64"
766+
731767instance Show Const where
732768 show (I i) = show i
733769 show (BI i) = show i ++ "L"
@@ -738,16 +774,18 @@ instance Show Const where
738774 show (B16 x) = show x
739775 show (B32 x) = show x
740776 show (B64 x) = show x
741− show IType = "Int"
742− show BIType = "Integer"
743− show FlType = "Float"
777+ show (B8V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"
778+ show (B16V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"
779+ show (B32V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"
780+ show (B64V x) = "<" ++ intercalate "," (map show (V.toList x)) ++ ">"
781+ show (AType ATFloat) = "Float"
782+ show (AType (ATInt ITBig)) = "Integer"
783+ show (AType (ATInt ITNative)) = "Int"
784+ show (AType (ATInt (ITFixed it))) = itBitsName it
785+ show (AType (ATInt (ITVec it c))) = itBitsName it ++ "x" ++ show c
744786 show ChType = "Char"
745787 show StrType = "String"
746788 show PtrType = "Ptr"
747− show B8Type = "Bits8"
748− show B16Type = "Bits16"
749− show B32Type = "Bits32"
750− show B64Type = "Bits64"
751789 show VoidType = "Void"
752790
753791showEnv env t = showEnv' env t False
src/Core/Typecheck.hs+12−7
@@ -5,6 +5,7 @@ module Core.Typecheck where
55
66import Control.Monad.State
77import Debug.Trace
8+import qualified Data.Vector.Unboxed as V (length)
89
910import Core.TT
1011import Core.Evaluate
@@ -98,15 +99,19 @@ check' holes ctxt env top = chk env top where
9899 return (TType (UVar v), TType (UVar (v+1)))
99100 chk env (RConstant Forgot) = return (Erased, Erased)
100101 chk env (RConstant c) = return (Constant c, constType c)
101− where constType (I _) = Constant IType
102− constType (BI _) = Constant BIType
103− constType (Fl _) = Constant FlType
102+ where constType (I _) = Constant (AType (ATInt ITNative))
103+ constType (BI _) = Constant (AType (ATInt ITBig))
104+ constType (Fl _) = Constant (AType ATFloat)
104105 constType (Ch _) = Constant ChType
105106 constType (Str _) = Constant StrType
106− constType (B8 _) = Constant B8Type
107− constType (B16 _) = Constant B16Type
108− constType (B32 _) = Constant B32Type
109− constType (B64 _) = Constant B64Type
107+ constType (B8 _) = Constant (AType (ATInt (ITFixed IT8)))
108+ constType (B16 _) = Constant (AType (ATInt (ITFixed IT16)))
109+ constType (B32 _) = Constant (AType (ATInt (ITFixed IT32)))
110+ constType (B64 _) = Constant (AType (ATInt (ITFixed IT64)))
111+ constType (B8V a) = Constant (AType (ATInt (ITVec IT8 (V.length a))))
112+ constType (B16V a) = Constant (AType (ATInt (ITVec IT16 (V.length a))))
113+ constType (B32V a) = Constant (AType (ATInt (ITVec IT32 (V.length a))))
114+ constType (B64V a) = Constant (AType (ATInt (ITVec IT64 (V.length a))))
110115 constType Forgot = Erased
111116 constType _ = TType (UVal 0)
112117 chk env (RForce t) = do (_, ty) <- chk env t
src/IRTS/CodegenC.hs+88−77
@@ -229,39 +229,41 @@ bcc i (ERROR str) = indent i ++ "fprintf(stderr, " ++ show str ++ "); assert(0);
229229
230230
231231
232−c_irts (FInt ITNative) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
233−c_irts (FInt ty) l x = l ++ "idris_b" ++ show (intTyWidth ty) ++ "const(vm, " ++ x ++ ")"
232+c_irts (FArith (ATInt ITNative)) l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
233+c_irts (FArith (ATInt (ITFixed ity))) l x
234+ = l ++ "idris_b" ++ show (nativeTyWidth ity) ++ "const(vm, " ++ x ++ ")"
234235c_irts FChar l x = l ++ "MKINT((i_int)(" ++ x ++ "))"
235236c_irts FString l x = l ++ "MKSTR(vm, " ++ x ++ ")"
236237c_irts FUnit l x = x
237238c_irts FPtr l x = l ++ "MKPTR(vm, " ++ x ++ ")"
238−c_irts FDouble l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
239+c_irts (FArith ATFloat) l x = l ++ "MKFLOAT(vm, " ++ x ++ ")"
239240c_irts FAny l x = l ++ x
240241
241−irts_c (FInt ITNative) x = "GETINT(" ++ x ++ ")"
242−irts_c (FInt ty) x = "(" ++ x ++ "->info.bits" ++ show (intTyWidth ty) ++ ")"
242+irts_c (FArith (ATInt ITNative)) x = "GETINT(" ++ x ++ ")"
243+irts_c (FArith (ATInt (ITFixed ity))) x
244+ = "(" ++ x ++ "->info.bits" ++ show (nativeTyWidth ity) ++ ")"
243245irts_c FChar x = "GETINT(" ++ x ++ ")"
244246irts_c FString x = "GETSTR(" ++ x ++ ")"
245247irts_c FUnit x = x
246248irts_c FPtr x = "GETPTR(" ++ x ++ ")"
247−irts_c FDouble x = "GETFLOAT(" ++ x ++ ")"
249+irts_c (FArith ATFloat) x = "GETFLOAT(" ++ x ++ ")"
248250irts_c FAny x = x
249251
250−bitOp v op ty args = v ++ "idris_b" ++ show (intTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
252+bitOp v op ty args = v ++ "idris_b" ++ show (nativeTyWidth ty) ++ op ++ "(vm, " ++ intercalate ", " (map creg args) ++ ")"
251253
252254bitCoerce v op input output arg
253− = v ++ "idris_b" ++ show (intTyWidth input) ++ op ++ show (intTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
255+ = v ++ "idris_b" ++ show (nativeTyWidth input) ++ op ++ show (nativeTyWidth output) ++ "(vm, " ++ creg arg ++ ")"
254256
255−signedTy :: IntTy -> String
256−signedTy t = "int" ++ show (intTyWidth t) ++ "_t"
257+signedTy :: NativeTy -> String
258+signedTy t = "int" ++ show (nativeTyWidth t) ++ "_t"
257259
258−doOp v (LPlus ITNative) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
259−doOp v (LMinus ITNative) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
260−doOp v (LTimes ITNative) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
260+doOp v (LPlus (ATInt ITNative)) [l, r] = v ++ "ADD(" ++ creg l ++ ", " ++ creg r ++ ")"
261+doOp v (LMinus (ATInt ITNative)) [l, r] = v ++ "INTOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
262+doOp v (LTimes (ATInt ITNative)) [l, r] = v ++ "MULT(" ++ creg l ++ ", " ++ creg r ++ ")"
261263doOp v (LUDiv ITNative) [l, r] = v ++ "UINTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
262−doOp v (LSDiv ITNative) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
264+doOp v (LSDiv (ATInt ITNative)) [l, r] = v ++ "INTOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
263265doOp v (LURem ITNative) [l, r] = v ++ "UINTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
264−doOp v (LSRem ITNative) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
266+doOp v (LSRem (ATInt ITNative)) [l, r] = v ++ "INTOP(%," ++ creg l ++ ", " ++ creg r ++ ")"
265267doOp v (LAnd ITNative) [l, r] = v ++ "INTOP(&," ++ creg l ++ ", " ++ creg r ++ ")"
266268doOp v (LOr ITNative) [l, r] = v ++ "INTOP(|," ++ creg l ++ ", " ++ creg r ++ ")"
267269doOp v (LXOr ITNative) [l, r] = v ++ "INTOP(^," ++ creg l ++ ", " ++ creg r ++ ")"
@@ -269,34 +271,34 @@ doOp v (LSHL ITNative) [l, r] = v ++ "INTOP(<<," ++ creg l ++ ", " ++ creg r ++
269271doOp v (LLSHR ITNative) [l, r] = v ++ "UINTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
270272doOp v (LASHR ITNative) [l, r] = v ++ "INTOP(>>," ++ creg l ++ ", " ++ creg r ++ ")"
271273doOp v (LCompl ITNative) [x] = v ++ "INTOP(~," ++ creg x ++ ")"
272−doOp v (LEq ITNative) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
273−doOp v (LLt ITNative) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
274−doOp v (LLe ITNative) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
275−doOp v (LGt ITNative) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
276−doOp v (LGe ITNative) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
277−
278−doOp v LFPlus [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
279−doOp v LFMinus [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
280−doOp v LFTimes [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
281−doOp v LFDiv [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
282−doOp v LFEq [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
283−doOp v LFLt [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
284−doOp v LFLe [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
285−doOp v LFGt [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
286−doOp v LFGe [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
274+doOp v (LEq (ATInt ITNative)) [l, r] = v ++ "INTOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
275+doOp v (LLt (ATInt ITNative)) [l, r] = v ++ "INTOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
276+doOp v (LLe (ATInt ITNative)) [l, r] = v ++ "INTOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
277+doOp v (LGt (ATInt ITNative)) [l, r] = v ++ "INTOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
278+doOp v (LGe (ATInt ITNative)) [l, r] = v ++ "INTOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
279+
280+doOp v (LPlus ATFloat) [l, r] = v ++ "FLOATOP(+," ++ creg l ++ ", " ++ creg r ++ ")"
281+doOp v (LMinus ATFloat) [l, r] = v ++ "FLOATOP(-," ++ creg l ++ ", " ++ creg r ++ ")"
282+doOp v (LTimes ATFloat) [l, r] = v ++ "FLOATOP(*," ++ creg l ++ ", " ++ creg r ++ ")"
283+doOp v (LSDiv ATFloat) [l, r] = v ++ "FLOATOP(/," ++ creg l ++ ", " ++ creg r ++ ")"
284+doOp v (LEq ATFloat) [l, r] = v ++ "FLOATBOP(==," ++ creg l ++ ", " ++ creg r ++ ")"
285+doOp v (LLt ATFloat) [l, r] = v ++ "FLOATBOP(<," ++ creg l ++ ", " ++ creg r ++ ")"
286+doOp v (LLe ATFloat) [l, r] = v ++ "FLOATBOP(<=," ++ creg l ++ ", " ++ creg r ++ ")"
287+doOp v (LGt ATFloat) [l, r] = v ++ "FLOATBOP(>," ++ creg l ++ ", " ++ creg r ++ ")"
288+doOp v (LGe ATFloat) [l, r] = v ++ "FLOATBOP(>=," ++ creg l ++ ", " ++ creg r ++ ")"
287289
288290doOp v (LIntFloat ITBig) [x] = v ++ "idris_castBigFloat(vm, " ++ creg x ++ ")"
289291doOp v (LFloatInt ITBig) [x] = v ++ "idris_castFloatBig(vm, " ++ creg x ++ ")"
290−doOp v (LPlus ITBig) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
291−doOp v (LMinus ITBig) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
292−doOp v (LTimes ITBig) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
293−doOp v (LSDiv ITBig) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
294−doOp v (LSRem ITBig) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
295−doOp v (LEq ITBig) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
296−doOp v (LLt ITBig) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
297−doOp v (LLe ITBig) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
298−doOp v (LGt ITBig) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
299−doOp v (LGe ITBig) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
292+doOp v (LPlus (ATInt ITBig)) [l, r] = v ++ "idris_bigPlus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
293+doOp v (LMinus (ATInt ITBig)) [l, r] = v ++ "idris_bigMinus(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
294+doOp v (LTimes (ATInt ITBig)) [l, r] = v ++ "idris_bigTimes(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
295+doOp v (LSDiv (ATInt ITBig)) [l, r] = v ++ "idris_bigDivide(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
296+doOp v (LSRem (ATInt ITBig)) [l, r] = v ++ "idris_bigMod(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
297+doOp v (LEq (ATInt ITBig)) [l, r] = v ++ "idris_bigEq(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
298+doOp v (LLt (ATInt ITBig)) [l, r] = v ++ "idris_bigLt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
299+doOp v (LLe (ATInt ITBig)) [l, r] = v ++ "idris_bigLe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
300+doOp v (LGt (ATInt ITBig)) [l, r] = v ++ "idris_bigGt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
301+doOp v (LGe (ATInt ITBig)) [l, r] = v ++ "idris_bigGe(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
300302
301303doOp v LStrConcat [l,r] = v ++ "idris_concat(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
302304doOp v LStrLt [l,r] = v ++ "idris_strlt(vm, " ++ creg l ++ ", " ++ creg r ++ ")"
@@ -318,43 +320,52 @@ doOp v LReadStr [x] = v ++ "idris_readStr(vm, GETPTR(" ++ creg x ++ "))"
318320doOp _ LPrintNum [x] = "printf(\"%ld\\n\", GETINT(" ++ creg x ++ "))"
319321doOp _ LPrintStr [x] = "fputs(GETSTR(" ++ creg x ++ "), stdout)"
320322
321−doOp v (LLt ty) [x, y] = bitOp v "Lt" ty [x, y]
322−doOp v (LLe ty) [x, y] = bitOp v "Lte" ty [x, y]
323−doOp v (LEq ty) [x, y] = bitOp v "Eq" ty [x, y]
324−doOp v (LGe ty) [x, y] = bitOp v "Gte" ty [x, y]
325−doOp v (LGt ty) [x, y] = bitOp v "Gt" ty [x, y]
326−
327−doOp v (LSHL ty) [x, y] = bitOp v "Shl" ty [x, y]
328−doOp v (LLSHR ty) [x, y] = bitOp v "LShr" ty [x, y]
329−doOp v (LASHR ty) [x, y] = bitOp v "AShr" ty [x, y]
330−doOp v (LAnd ty) [x, y] = bitOp v "And" ty [x, y]
331−doOp v (LOr ty) [x, y] = bitOp v "Or" ty [x, y]
332−doOp v (LXOr ty) [x, y] = bitOp v "Xor" ty [x, y]
333−doOp v (LCompl ty) [x] = bitOp v "Compl" ty [x]
334−
335−doOp v (LPlus ty) [x, y] = bitOp v "Plus" ty [x, y]
336−doOp v (LMinus ty) [x, y] = bitOp v "Minus" ty [x, y]
337−doOp v (LTimes ty) [x, y] = bitOp v "Times" ty [x, y]
338−doOp v (LUDiv ty) [x, y] = bitOp v "UDiv" ty [x, y]
339−doOp v (LSDiv ty) [x, y] = bitOp v "SDiv" ty [x, y]
340−doOp v (LURem ty) [x, y] = bitOp v "URem" ty [x, y]
341−doOp v (LSRem ty) [x, y] = bitOp v "SRem" ty [x, y]
342−
343−doOp v (LSExt from ITBig) [x] = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"
344−doOp v (LSExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
345−doOp v (LSExt from ITNative) [x] = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ "))"
346−doOp v (LSExt from to) [x]
347− | intTyWidth from < intTyWidth to = bitCoerce v "S" from to x
348−doOp v (LZExt ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"
349−doOp v (LZExt from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"
350−doOp v (LZExt from ITBig) [x] = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"
351−doOp v (LZExt from to) [x]
352− | intTyWidth from < intTyWidth to = bitCoerce v "Z" from to x
353−doOp v (LTrunc ITNative to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
354−doOp v (LTrunc from ITNative) [x] = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (intTyWidth from) ++ ")"
355−doOp v (LTrunc ITBig to) [x] = v ++ "idris_b" ++ show (intTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
356−doOp v (LTrunc from to) [x]
357− | intTyWidth from > intTyWidth to = bitCoerce v "T" from to x
323+doOp v (LLt (ATInt (ITFixed ty))) [x, y] = bitOp v "Lt" ty [x, y]
324+doOp v (LLe (ATInt (ITFixed ty))) [x, y] = bitOp v "Lte" ty [x, y]
325+doOp v (LEq (ATInt (ITFixed ty))) [x, y] = bitOp v "Eq" ty [x, y]
326+doOp v (LGe (ATInt (ITFixed ty))) [x, y] = bitOp v "Gte" ty [x, y]
327+doOp v (LGt (ATInt (ITFixed ty))) [x, y] = bitOp v "Gt" ty [x, y]
328+
329+doOp v (LSHL (ITFixed ty)) [x, y] = bitOp v "Shl" ty [x, y]
330+doOp v (LLSHR (ITFixed ty)) [x, y] = bitOp v "LShr" ty [x, y]
331+doOp v (LASHR (ITFixed ty)) [x, y] = bitOp v "AShr" ty [x, y]
332+doOp v (LAnd (ITFixed ty)) [x, y] = bitOp v "And" ty [x, y]
333+doOp v (LOr (ITFixed ty)) [x, y] = bitOp v "Or" ty [x, y]
334+doOp v (LXOr (ITFixed ty)) [x, y] = bitOp v "Xor" ty [x, y]
335+doOp v (LCompl (ITFixed ty)) [x] = bitOp v "Compl" ty [x]
336+
337+doOp v (LPlus (ATInt (ITFixed ty))) [x, y] = bitOp v "Plus" ty [x, y]
338+doOp v (LMinus (ATInt (ITFixed ty))) [x, y] = bitOp v "Minus" ty [x, y]
339+doOp v (LTimes (ATInt (ITFixed ty))) [x, y] = bitOp v "Times" ty [x, y]
340+doOp v (LUDiv (ITFixed ty)) [x, y] = bitOp v "UDiv" ty [x, y]
341+doOp v (LSDiv (ATInt (ITFixed ty))) [x, y] = bitOp v "SDiv" ty [x, y]
342+doOp v (LURem (ITFixed ty)) [x, y] = bitOp v "URem" ty [x, y]
343+doOp v (LSRem (ATInt (ITFixed ty))) [x, y] = bitOp v "SRem" ty [x, y]
344+
345+doOp v (LSExt (ITFixed from) ITBig) [x]
346+ = v ++ "MKBIGSI(vm, (" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
347+doOp v (LSExt ITNative (ITFixed to)) [x]
348+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
349+doOp v (LSExt (ITFixed from) ITNative) [x]
350+ = v ++ "MKINT((i_int)((" ++ signedTy from ++ ")" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ "))"
351+doOp v (LSExt (ITFixed from) (ITFixed to)) [x]
352+ | nativeTyWidth from < nativeTyWidth to = bitCoerce v "S" from to x
353+doOp v (LZExt ITNative (ITFixed to)) [x]
354+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, (uintptr_t)GETINT(" ++ creg x ++ ")"
355+doOp v (LZExt (ITFixed from) ITNative) [x]
356+ = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
357+doOp v (LZExt (ITFixed from) ITBig) [x]
358+ = v ++ "MKBIGUI(vm, " ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
359+doOp v (LZExt (ITFixed from) (ITFixed to)) [x]
360+ | nativeTyWidth from < nativeTyWidth to = bitCoerce v "Z" from to x
361+doOp v (LTrunc ITNative (ITFixed to)) [x]
362+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, GETINT(" ++ creg x ++ "))"
363+doOp v (LTrunc (ITFixed from) ITNative) [x]
364+ = v ++ "MKINT((i_int)" ++ creg x ++ "->info.bits" ++ show (nativeTyWidth from) ++ ")"
365+doOp v (LTrunc ITBig (ITFixed to)) [x]
366+ = v ++ "idris_b" ++ show (nativeTyWidth to) ++ "const(vm, ISINT(" ++ creg x ++ ") ? GETINT(" ++ creg x ++ ") : mpz_get_ui(GETMPZ(" ++ creg x ++ ")))"
367+doOp v (LTrunc (ITFixed from) (ITFixed to)) [x]
368+ | nativeTyWidth from > nativeTyWidth to = bitCoerce v "T" from to x
358369
359370doOp v LFExp [x] = v ++ flUnOp "exp" (creg x)
360371doOp v LFLog [x] = v ++ flUnOp "log" (creg x)
src/IRTS/CodegenJava.hs+79−79
@@ -472,17 +472,17 @@ longType :: ClassType
472472longType = ClassType [(Ident "Long", [])]
473473
474474nextIntTy :: IntTy -> IntTy
475−nextIntTy IT8 = IT16
476−nextIntTy IT16 = IT32
477−nextIntTy IT32 = IT64
478−nextIntTy IT64 = IT64
479−nextIntTy ITNative = IT64
475+nextIntTy (ITFixed IT8) = (ITFixed IT16)
476+nextIntTy (ITFixed IT16) = (ITFixed IT32)
477+nextIntTy (ITFixed IT32) = (ITFixed IT64)
478+nextIntTy (ITFixed IT64) = (ITFixed IT64)
479+nextIntTy ITNative = (ITFixed IT64)
480480
481481intTyToIdent :: IntTy -> Ident
482−intTyToIdent IT8 = Ident "Byte"
483−intTyToIdent IT16 = Ident "Short"
484−intTyToIdent IT32 = Ident "Integer"
485−intTyToIdent IT64 = Ident "Long"
482+intTyToIdent (ITFixed IT8) = Ident "Byte"
483+intTyToIdent (ITFixed IT16) = Ident "Short"
484+intTyToIdent (ITFixed IT32) = Ident "Integer"
485+intTyToIdent (ITFixed IT64) = Ident "Long"
486486intTyToIdent ITNative = Ident "Integer"
487487intTyToIdent ITBig = Ident "BigInteger"
488488
@@ -490,17 +490,17 @@ intTyToClass :: IntTy -> ClassType
490490intTyToClass ty = ClassType [(intTyToIdent ty, [])]
491491
492492intTyToMethod :: IntTy -> String
493−intTyToMethod IT8 = "byteValue"
494−intTyToMethod IT16 = "shortValue"
495−intTyToMethod IT32 = "intValue"
496−intTyToMethod IT64 = "longValue"
493+intTyToMethod (ITFixed IT8) = "byteValue"
494+intTyToMethod (ITFixed IT16) = "shortValue"
495+intTyToMethod (ITFixed IT32) = "intValue"
496+intTyToMethod (ITFixed IT64) = "longValue"
497497intTyToMethod ITNative = "intValue"
498498
499499intTyToPrimTy :: IntTy -> PrimType
500−intTyToPrimTy IT8 = ByteT
501−intTyToPrimTy IT16 = ShortT
502−intTyToPrimTy IT32 = IntT
503−intTyToPrimTy IT64 = LongT
500+intTyToPrimTy (ITFixed IT8) = ByteT
501+intTyToPrimTy (ITFixed IT16) = ShortT
502+intTyToPrimTy (ITFixed IT32) = IntT
503+intTyToPrimTy (ITFixed IT64) = LongT
504504intTyToPrimTy ITNative = IntT
505505
506506bigIntegerType :: ClassType
@@ -995,24 +995,24 @@ mkStringAtIndex var indexExp =
995995 <$> mkVarAccess (Just stringType) var
996996
997997mkForeignType :: FType -> Maybe ClassType
998−mkForeignType (FInt ty) = return (intTyToClass ty)
998+mkForeignType (FArith (ATInt ity)) = return (intTyToClass ity)
999+mkForeignType (FArith ATFloat) = return doubleType
9991000mkForeignType FChar = return integerType
10001001mkForeignType FString = return stringType
10011002mkForeignType FPtr = return objectType
1002−mkForeignType FDouble = return doubleType
10031003mkForeignType FAny = return objectType
10041004mkForeignType FUnit = Nothing
10051005
10061006mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
1007−mkForeignVarAccess (FInt ty) var =
1007+mkForeignVarAccess (FArith (ATInt ty)) var =
10081008 (\ var -> MethodInv $ PrimaryMethodCall var
10091009 []
10101010 (Ident (intTyToMethod ty))
10111011 []
10121012 )
10131013 <$> mkVarAccess (Just $ intTyToClass ty) var
1014−mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FInt IT32) var
1015−mkForeignVarAccess FDouble var =
1014+mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess (FArith (ATInt (ITFixed IT32))) var
1015+mkForeignVarAccess (FArith ATFloat) var =
10161016 (\ var -> MethodInv $ PrimaryMethodCall (var)
10171017 []
10181018 (Ident "doubleValue")
@@ -1022,13 +1022,13 @@ mkForeignVarAccess FDouble var =
10221022mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
10231023
10241024mkFromForeignType :: FType -> Exp -> Exp
1025−mkFromForeignType (FInt ty) from =
1025+mkFromForeignType (FArith (ATInt ty)) from =
10261026 MethodInv $ TypeMethodCall (J.Name [intTyToIdent ty])
10271027 []
10281028 (Ident "valueOf")
10291029 [from]
1030−mkFromForeignType FChar from = mkFromForeignType (FInt IT32) from
1031−mkFromForeignType FDouble from =
1030+mkFromForeignType FChar from = mkFromForeignType (FArith (ATInt (ITFixed IT32))) from
1031+mkFromForeignType (FArith ATFloat) from =
10321032 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
10331033 []
10341034 (Ident "valueOf")
@@ -1269,78 +1269,78 @@ mkExp (SConst (BI x)) =
12691269mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
12701270mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
12711271mkExp (SConst (Str x)) = return $ Lit $ String x
1272−mkExp (SConst IType) = return $ mkClass integerType
1273−mkExp (SConst BIType) = return $ mkClass bigIntegerType
1274−mkExp (SConst FlType) = return $ mkClass doubleType
1272+mkExp (SConst (AType (ATInt ITNative))) = return $ mkClass integerType
1273+mkExp (SConst (AType (ATInt ITBig))) = return $ mkClass bigIntegerType
1274+mkExp (SConst (AType ATFloat)) = return $ mkClass doubleType
12751275mkExp (SConst ChType) = return $ mkClass charType
12761276mkExp (SConst StrType) = return $ mkClass stringType
12771277mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
12781278mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
12791279mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
12801280mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
1281−mkExp (SConst (B8Type))= return $ mkClass byteType
1282−mkExp (SConst (B16Type)) = return $ mkClass shortType
1283−mkExp (SConst (B32Type)) = return $ mkClass integerType
1284−mkExp (SConst (B64Type)) = return $ mkClass longType
1281+mkExp (SConst (AType (ATInt (ITFixed IT8)))) = return $ mkClass byteType
1282+mkExp (SConst (AType (ATInt (ITFixed IT16)))) = return $ mkClass shortType
1283+mkExp (SConst (AType (ATInt (ITFixed IT32)))) = return $ mkClass integerType
1284+mkExp (SConst (AType (ATInt (ITFixed IT64)))) = return $ mkClass longType
12851285mkExp (SConst (PtrType)) = return $ mkClass objectType
12861286mkExp (SConst (VoidType)) = return $ mkClass voidType
12871287mkExp (SConst (Forgot)) = return $ mkClass objectType
12881288mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1289−mkExp (SOp (LPlus ITNative) args) = mkExp (SOp (LPlus IT32) args)
1290−mkExp (SOp (LMinus ITNative) args) = mkExp (SOp (LMinus IT32) args)
1291−mkExp (SOp (LTimes ITNative) args) = mkExp (SOp (LTimes IT32) args)
1292−mkExp (SOp (LSDiv ITNative) args) = mkExp (SOp (LSDiv IT32) args)
1293−mkExp (SOp (LSRem ITNative) args) = mkExp (SOp (LSRem IT32) args)
1294−mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd IT32) args)
1295−mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr IT32) args)
1296−mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr IT32) args)
1297−mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl IT32) args)
1298−mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL IT32) args)
1299−mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR IT32) args)
1300−mkExp (SOp (LEq ITNative) args) = mkExp (SOp (LEq IT32) args)
1301−mkExp (SOp (LLt ITNative) args) = mkExp (SOp (LLt IT32) args)
1302−mkExp (SOp (LLe ITNative) args) = mkExp (SOp (LLe IT32) args)
1303−mkExp (SOp (LGt ITNative) args) = mkExp (SOp (LGt IT32) args)
1304−mkExp (SOp (LGe ITNative) args) = mkExp (SOp (LGe IT32) args)
1305−mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1306−mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1307−mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1308−mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
1309−mkExp (SOp LFEq args) =
1289+mkExp (SOp (LPlus (ATInt ITNative)) args) = mkExp (SOp (LPlus (ATInt (ITFixed IT32))) args)
1290+mkExp (SOp (LMinus (ATInt ITNative)) args) = mkExp (SOp (LMinus (ATInt (ITFixed IT32))) args)
1291+mkExp (SOp (LTimes (ATInt ITNative)) args) = mkExp (SOp (LTimes (ATInt (ITFixed IT32))) args)
1292+mkExp (SOp (LSDiv (ATInt ITNative)) args) = mkExp (SOp (LSDiv (ATInt (ITFixed IT32))) args)
1293+mkExp (SOp (LSRem (ATInt ITNative)) args) = mkExp (SOp (LSRem (ATInt (ITFixed IT32))) args)
1294+mkExp (SOp (LAnd ITNative) args) = mkExp (SOp (LAnd (ITFixed IT32)) args)
1295+mkExp (SOp (LOr ITNative) args) = mkExp (SOp (LOr (ITFixed IT32)) args)
1296+mkExp (SOp (LXOr ITNative) args) = mkExp (SOp (LXOr (ITFixed IT32)) args)
1297+mkExp (SOp (LCompl ITNative) args) = mkExp (SOp (LCompl (ITFixed IT32)) args)
1298+mkExp (SOp (LSHL ITNative) args) = mkExp (SOp (LSHL (ITFixed IT32)) args)
1299+mkExp (SOp (LASHR ITNative) args) = mkExp (SOp (LASHR (ITFixed IT32)) args)
1300+mkExp (SOp (LEq (ATInt ITNative)) args) = mkExp (SOp (LEq (ATInt (ITFixed IT32))) args)
1301+mkExp (SOp (LLt (ATInt ITNative)) args) = mkExp (SOp (LLt (ATInt (ITFixed IT32))) args)
1302+mkExp (SOp (LLe (ATInt ITNative)) args) = mkExp (SOp (LLe (ATInt (ITFixed IT32))) args)
1303+mkExp (SOp (LGt (ATInt ITNative)) args) = mkExp (SOp (LGt (ATInt (ITFixed IT32))) args)
1304+mkExp (SOp (LGe (ATInt ITNative)) args) = mkExp (SOp (LGe (ATInt (ITFixed IT32))) args)
1305+mkExp (SOp (LPlus ATFloat) args) = mkBinOpExp doubleType Add args
1306+mkExp (SOp (LMinus ATFloat) args) = mkBinOpExp doubleType Sub args
1307+mkExp (SOp (LTimes ATFloat) args) = mkBinOpExp doubleType Mult args
1308+mkExp (SOp (LSDiv ATFloat) args) = mkBinOpExp doubleType Div args
1309+mkExp (SOp (LEq ATFloat) args) =
13101310 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1311−mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1312−mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1313−mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1314−mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1315−mkExp (SOp (LPlus ITBig) args) = mkMethodOpChain1 id bigIntegerType "add" args
1316−mkExp (SOp (LMinus ITBig) args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1317−mkExp (SOp (LTimes ITBig) args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1318−mkExp (SOp (LSDiv ITBig) args) = mkMethodOpChain1 id bigIntegerType "divide" args
1319−mkExp (SOp (LSRem ITBig) args) = mkMethodOpChain1 id bigIntegerType "mod" args
1320−mkExp (SOp (LEq ITBig) args) =
1311+mkExp (SOp (LLt ATFloat) args) = mkLogicalBinOpExp integerType LThan args
1312+mkExp (SOp (LLe ATFloat) args) = mkLogicalBinOpExp integerType LThanE args
1313+mkExp (SOp (LGt ATFloat) args) = mkLogicalBinOpExp integerType GThan args
1314+mkExp (SOp (LGe ATFloat) args) = mkLogicalBinOpExp integerType GThanE args
1315+mkExp (SOp (LPlus (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "add" args
1316+mkExp (SOp (LMinus (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1317+mkExp (SOp (LTimes (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1318+mkExp (SOp (LSDiv (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "divide" args
1319+mkExp (SOp (LSRem (ATInt ITBig)) args) = mkMethodOpChain1 id bigIntegerType "mod" args
1320+mkExp (SOp (LEq (ATInt ITBig)) args) =
13211321 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1322−mkExp (SOp (LLt ITBig) args) =
1322+mkExp (SOp (LLt (ATInt ITBig)) args) =
13231323 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
13241324 . mkPartialOrder SLt
13251325 )
13261326 bigIntegerType
13271327 "compareTo"
13281328 args
1329−mkExp (SOp (LLe ITBig) args) =
1329+mkExp (SOp (LLe (ATInt ITBig)) args) =
13301330 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
13311331 . mkPartialOrder SLe
13321332 )
13331333 bigIntegerType
13341334 "compareTo"
13351335 args
1336−mkExp (SOp (LGt ITBig) args) =
1336+mkExp (SOp (LGt (ATInt ITBig)) args) =
13371337 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
13381338 . mkPartialOrder SGt
13391339 )
13401340 bigIntegerType
13411341 "compareTo"
13421342 args
1343−mkExp (SOp (LGe ITBig) args) =
1343+mkExp (SOp (LGe (ATInt ITBig)) args) =
13441344 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
13451345 . mkPartialOrder SGe
13461346 )
@@ -1397,16 +1397,16 @@ mkExp (SOp LPrintNum [arg]) =
13971397mkExp (SOp LPrintStr [arg]) =
13981398 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
13991399mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1400−mkExp (SOp (LLt ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args
1401−mkExp (SOp (LLe ty) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args
1402−mkExp (SOp (LEq ty) args) =
1400+mkExp (SOp (LLt (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) LThan args
1401+mkExp (SOp (LLe (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) LThanE args
1402+mkExp (SOp (LEq (ATInt ty)) args) =
14031403 mkMethodOpChain1 (mkBoolToNumber (intTyToClass ty)) (intTyToClass ty) "equals" args
1404−mkExp (SOp (LGt ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args
1405−mkExp (SOp (LGe ty) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args
1406−mkExp (SOp (LPlus ty) args) = mkBinOpExp (intTyToClass ty) Add args
1407−mkExp (SOp (LMinus ty) args) = mkBinOpExp (intTyToClass ty) Sub args
1408−mkExp (SOp (LTimes ty) args) = mkBinOpExp (intTyToClass ty) Mult args
1409−mkExp (SOp (LUDiv IT64) (arg:args)) = do
1404+mkExp (SOp (LGt (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) GThan args
1405+mkExp (SOp (LGe (ATInt ty)) args) = mkLogicalBinOpExp (intTyToClass ty) GThanE args
1406+mkExp (SOp (LPlus (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Add args
1407+mkExp (SOp (LMinus (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Sub args
1408+mkExp (SOp (LTimes (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Mult args
1409+mkExp (SOp (LUDiv (ITFixed IT64)) (arg:args)) = do
14101410 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
14111411 return $ foldl (\ exp arg ->
14121412 MethodInv $ PrimaryMethodCall
@@ -1436,8 +1436,8 @@ mkExp (SOp (LUDiv ty) args) =
14361436 (intTyToClass ty)
14371437 Div
14381438 args
1439−mkExp (SOp (LSDiv ty) args) = mkBinOpExp (intTyToClass ty) Div args
1440−mkExp (SOp (LURem IT64) (arg:args)) = do
1439+mkExp (SOp (LSDiv (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Div args
1440+mkExp (SOp (LURem (ITFixed IT64)) (arg:args)) = do
14411441 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
14421442 return $ foldl (\ exp arg ->
14431443 MethodInv $ PrimaryMethodCall
@@ -1467,7 +1467,7 @@ mkExp (SOp (LURem ty) args) =
14671467 (intTyToClass ty)
14681468 Rem
14691469 args
1470−mkExp (SOp (LSRem ty) args) = mkBinOpExp (intTyToClass ty) Rem args
1470+mkExp (SOp (LSRem (ATInt ty)) args) = mkBinOpExp (intTyToClass ty) Rem args
14711471mkExp (SOp (LSHL ty) args) = mkBinOpExp (intTyToClass ty) LShift args
14721472mkExp (SOp (LLSHR ty) args) = mkBinOpExp (intTyToClass ty) RRShift args
14731473mkExp (SOp (LASHR ty) args) = mkBinOpExp (intTyToClass ty) RShift args
src/IRTS/CodegenJavaScript.hs+29−29
@@ -143,11 +143,11 @@ translateConstant (BI i) = "__IDRRT__.bigInt('" ++ show i ++ "')"
143143translateConstant (Fl f) = show f
144144translateConstant (Ch c) = show c
145145translateConstant (Str s) = show s
146−translateConstant IType = "__IDRRT__.Int"
146+translateConstant (AType (ATInt ITNative)) = "__IDRRT__.Int"
147147translateConstant ChType = "__IDRRT__.Char"
148148translateConstant StrType = "__IDRRT__.String"
149−translateConstant BIType = "__IDRRT__.Integer"
150−translateConstant FlType = "__IDRRT__.Float"
149+translateConstant (AType (ATInt ITBig)) = "__IDRRT__.Integer"
150+translateConstant (AType ATFloat) = "__IDRRT__.Float"
151151translateConstant PtrType = "__IDRRT__.Ptr"
152152translateConstant Forgot = "__IDRRT__.Forgot"
153153translateConstant c =
@@ -245,44 +245,44 @@ translateExpression (SOp op vars)
245245 | (LCompl _) <- op
246246 , (arg:_) <- vars = '~' : translateVariableName arg
247247
248− | (LPlus ITBig) <- op
248+ | (LPlus (ATInt ITBig)) <- op
249249 , (lhs:rhs:_) <- vars = translateBinaryOp ".add(" lhs rhs ++ ")"
250− | (LMinus ITBig) <- op
250+ | (LMinus (ATInt ITBig)) <- op
251251 , (lhs:rhs:_) <- vars = translateBinaryOp ".minus(" lhs rhs ++ ")"
252− | (LTimes ITBig) <- op
252+ | (LTimes (ATInt ITBig)) <- op
253253 , (lhs:rhs:_) <- vars = translateBinaryOp ".times(" lhs rhs ++ ")"
254− | (LSDiv ITBig) <- op
254+ | (LSDiv (ATInt ITBig)) <- op
255255 , (lhs:rhs:_) <- vars = translateBinaryOp ".divide(" lhs rhs ++ ")"
256− | (LSRem ITBig) <- op
256+ | (LSRem (ATInt ITBig)) <- op
257257 , (lhs:rhs:_) <- vars = translateBinaryOp ".mod(" lhs rhs ++ ")"
258− | (LEq ITBig) <- op
258+ | (LEq (ATInt ITBig)) <- op
259259 , (lhs:rhs:_) <- vars = translateBinaryOp ".equals(" lhs rhs ++ ")"
260− | (LLt ITBig) <- op
260+ | (LLt (ATInt ITBig)) <- op
261261 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesser(" lhs rhs ++ ")"
262− | (LLe ITBig) <- op
262+ | (LLe (ATInt ITBig)) <- op
263263 , (lhs:rhs:_) <- vars = translateBinaryOp ".lesserOrEquals(" lhs rhs ++ ")"
264− | (LGt ITBig) <- op
264+ | (LGt (ATInt ITBig)) <- op
265265 , (lhs:rhs:_) <- vars = translateBinaryOp ".greater(" lhs rhs ++ ")"
266− | (LGe ITBig) <- op
266+ | (LGe (ATInt ITBig)) <- op
267267 , (lhs:rhs:_) <- vars = translateBinaryOp ".greaterOrEquals(" lhs rhs ++ ")"
268268
269− | LFPlus <- op
269+ | (LPlus ATFloat) <- op
270270 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
271− | LFMinus <- op
271+ | (LMinus ATFloat) <- op
272272 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
273− | LFTimes <- op
273+ | (LTimes ATFloat) <- op
274274 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
275− | LFDiv <- op
275+ | (LSDiv ATFloat) <- op
276276 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
277− | LFEq <- op
277+ | (LEq ATFloat) <- op
278278 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
279− | LFLt <- op
279+ | (LLt ATFloat) <- op
280280 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
281− | LFLe <- op
281+ | (LLe ATFloat) <- op
282282 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
283− | LFGt <- op
283+ | (LGt ATFloat) <- op
284284 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
285− | LFGe <- op
285+ | (LGe ATFloat) <- op
286286 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
287287
288288 | LStrConcat <- op
@@ -470,13 +470,13 @@ translateCase _ (SDefaultCase e) =
470470 createIfBlock "true" (translateExpression e)
471471
472472translateCase var (SConstCase ty e)
473− | ChType <- ty = matchHelper "Char"
474− | StrType <- ty = matchHelper "String"
475− | IType <- ty = matchHelper "Int"
476− | BIType <- ty = matchHelper "Integer"
477− | FlType <- ty = matchHelper "Float"
478− | PtrType <- ty = matchHelper "Ptr"
479− | Forgot <- ty = matchHelper "Forgot"
473+ | ChType <- ty = matchHelper "Char"
474+ | StrType <- ty = matchHelper "String"
475+ | PtrType <- ty = matchHelper "Ptr"
476+ | Forgot <- ty = matchHelper "Forgot"
477+ | (AType ATFloat) <- ty = matchHelper "Float"
478+ | (AType (ATInt ITBig)) <- ty = matchHelper "Integer"
479+ | (AType (ATInt ITNative)) <- ty = matchHelper "Int"
480480 where
481481 matchHelper tyName = translateTypeMatch var tyName e
482482
src/IRTS/CodegenLLVM.hs+86−81
@@ -5,6 +5,7 @@ import IRTS.CodegenCommon
55import IRTS.Lang
66import IRTS.Simplified
77import qualified Core.TT as TT
8+import Core.TT (ArithTy(..), IntTy(..), NativeTy(..), nativeTyWidth)
89
910import Util.System
1011import Paths_idris
@@ -80,12 +81,8 @@ codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
8081failInIO :: ErrorT String IO a -> IO a
8182failInIO = either fail return <=< runErrorT
8283
83−itWidth :: IntTy -> Word32
84−itWidth ITNative = 32
85−itWidth x = fromIntegral $ intTyWidth x
86−
8784outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
88−outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
85+outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
8986outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
9087outputModule tm file Executable m = withTmpFile $ \obj -> do
9188 outputModule tm obj Object m
@@ -586,7 +583,7 @@ cgChainCase :: Operand -> Maybe SExp -> [SAlt] -> Codegen (Maybe Operand)
586583cgChainCase caseValPtr defExp alts = do
587584 let (caseTy, comparator) =
588585 case head alts of
589− SConstCase (TT.BI _) _ -> (FInt ITBig, "__gmpz_cmp")
586+ SConstCase (TT.BI _) _ -> (FArith (ATInt ITBig), "__gmpz_cmp")
590587 SConstCase (TT.Str _) _ -> (FString, "strcmp")
591588 caseVal <- unbox caseTy caseValPtr
592589 defBlockName <- getName "default"
@@ -719,12 +716,12 @@ cgConst' (TT.Str s) = C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fro
719716cgConst' x = ierror $ "Unsupported constant: " ++ show x
720717
721718cgConst :: TT.Const -> Codegen Operand
722−cgConst c@(TT.I _) = box (FInt ITNative) (ConstantOperand $ cgConst' c)
723−cgConst c@(TT.B8 _) = box (FInt IT8) (ConstantOperand $ cgConst' c)
724−cgConst c@(TT.B16 _) = box (FInt IT16) (ConstantOperand $ cgConst' c)
725−cgConst c@(TT.B32 _) = box (FInt IT32) (ConstantOperand $ cgConst' c)
726−cgConst c@(TT.B64 _) = box (FInt IT64) (ConstantOperand $ cgConst' c)
727−cgConst c@(TT.Fl _) = box FDouble (ConstantOperand $ cgConst' c)
719+cgConst c@(TT.I _) = box (FArith (ATInt ITNative)) (ConstantOperand $ cgConst' c)
720+cgConst c@(TT.B8 _) = box (FArith (ATInt (ITFixed IT8))) (ConstantOperand $ cgConst' c)
721+cgConst c@(TT.B16 _) = box (FArith (ATInt (ITFixed IT16))) (ConstantOperand $ cgConst' c)
722+cgConst c@(TT.B32 _) = box (FArith (ATInt (ITFixed IT32))) (ConstantOperand $ cgConst' c)
723+cgConst c@(TT.B64 _) = box (FArith (ATInt (ITFixed IT64))) (ConstantOperand $ cgConst' c)
724+cgConst c@(TT.Fl _) = box (FArith ATFloat) (ConstantOperand $ cgConst' c)
728725cgConst c@(TT.Ch _) = box FChar (ConstantOperand $ cgConst' c)
729726cgConst c@(TT.Str s) = do
730727 str <- addGlobal' (ArrayType (1 + fromIntegral (length s)) (IntegerType 8)) (cgConst' c)
@@ -736,7 +733,7 @@ cgConst c@(TT.BI i) = do
736733 , ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0, C.Int 32 0]
737734 , ConstantOperand $ C.Int 32 10
738735 ]
739− box (FInt ITBig) mpz
736+ box (FArith (ATInt ITBig)) mpz
740737cgConst x = return $ ConstantOperand nullValue
741738
742739numDigits :: Integer -> Integer -> Integer
@@ -782,72 +779,80 @@ ffunDecl name rty argtys =
782779 }
783780
784781ftyToTy :: FType -> Type
785−ftyToTy (FInt ITNative) = IntegerType 32
786−ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
787−ftyToTy (FInt ty) = IntegerType (itWidth ty)
782+ftyToTy (FArith (ATInt ITNative)) = IntegerType 32
783+ftyToTy (FArith (ATInt ITBig)) = PointerType mpzTy (AddrSpace 0)
784+ftyToTy (FArith (ATInt (ITFixed ty))) = IntegerType (fromIntegral $ nativeTyWidth ty)
788785ftyToTy FChar = IntegerType 32
789786ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
790787ftyToTy FUnit = VoidType
791788ftyToTy FPtr = PointerType (IntegerType 8) (AddrSpace 0)
792−ftyToTy FDouble = FloatingPointType 64 IEEE
789+ftyToTy (FArith ATFloat) = FloatingPointType 64 IEEE
793790ftyToTy FAny = valueType
794791
792+-- Only use when known not to be ITBig
793+itWidth :: IntTy -> Word32
794+itWidth ITNative = 32
795+itWidth (ITFixed x) = fromIntegral $ nativeTyWidth x
796+
795797cgOp :: PrimFn -> [Operand] -> Codegen Operand
796798cgOp (LTrunc ITBig ity) [x] = do
797− nx <- unbox (FInt ITBig) x
799+ nx <- unbox (FArith (ATInt ITBig)) x
798800 val <- inst $ simpleCall "mpz_get_ull" [nx]
799801 v <- case ity of
800− IT64 -> return val
801− _ -> inst $ Trunc val (IntegerType $ itWidth ity) []
802− box (FInt ity) v
802+ (ITFixed IT64) -> return val
803+ _ -> inst $ Trunc val (ftyToTy (FArith (ATInt ity))) []
804+ box (FArith (ATInt ity)) v
803805cgOp (LZExt from ITBig) [x] = do
804− nx <- unbox (FInt from) x
806+ nx <- unbox (FArith (ATInt from)) x
805807 nx' <- case from of
806− IT64 -> return nx
808+ (ITFixed IT64) -> return nx
807809 _ -> inst $ ZExt nx (IntegerType 64) []
808810 mpz <- alloc mpzTy
809811 inst' $ simpleCall "mpz_init_set_ull" [mpz, nx']
810− box (FInt ITBig) mpz
812+ box (FArith (ATInt ITBig)) mpz
811813cgOp (LSExt from ITBig) [x] = do
812− nx <- unbox (FInt from) x
814+ nx <- unbox (FArith (ATInt from)) x
813815 nx' <- case from of
814− IT64 -> return nx
816+ (ITFixed IT64) -> return nx
815817 _ -> inst $ SExt nx (IntegerType 64) []
816818 mpz <- alloc mpzTy
817819 inst' $ simpleCall "mpz_init_set_sll" [mpz, nx']
818− box (FInt ITBig) mpz
819−
820−cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
821−cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
822−cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
823−cgOp (LGe ITBig) [x,y] = mpzCmp IPred.SGE x y
824−cgOp (LGt ITBig) [x,y] = mpzCmp IPred.SGT x y
825−cgOp (LPlus ITBig) [x,y] = mpzBin "add" x y
826−cgOp (LMinus ITBig) [x,y] = mpzBin "sub" x y
827−cgOp (LTimes ITBig) [x,y] = mpzBin "mul" x y
828−cgOp (LSDiv ITBig) [x,y] = mpzBin "fdiv_q" x y
829−cgOp (LSRem ITBig) [x,y] = mpzBin "fdiv_r" x y
820+ box (FArith (ATInt ITBig)) mpz
821+
822+cgOp (LLt (ATInt ITBig)) [x,y] = mpzCmp IPred.SLT x y
823+cgOp (LLe (ATInt ITBig)) [x,y] = mpzCmp IPred.SLE x y
824+cgOp (LEq (ATInt ITBig)) [x,y] = mpzCmp IPred.EQ x y
825+cgOp (LGe (ATInt ITBig)) [x,y] = mpzCmp IPred.SGE x y
826+cgOp (LGt (ATInt ITBig)) [x,y] = mpzCmp IPred.SGT x y
827+cgOp (LPlus (ATInt ITBig)) [x,y] = mpzBin "add" x y
828+cgOp (LMinus (ATInt ITBig)) [x,y] = mpzBin "sub" x y
829+cgOp (LTimes (ATInt ITBig)) [x,y] = mpzBin "mul" x y
830+cgOp (LSDiv (ATInt ITBig)) [x,y] = mpzBin "fdiv_q" x y
831+cgOp (LSRem (ATInt ITBig)) [x,y] = mpzBin "fdiv_r" x y
830832cgOp (LAnd ITBig) [x,y] = mpzBin "and" x y
831833cgOp (LOr ITBig) [x,y] = mpzBin "ior" x y
832834cgOp (LXOr ITBig) [x,y] = mpzBin "xor" x y
833835cgOp (LCompl ITBig) [x] = mpzUn "com" x
834836
835−cgOp (LTrunc from to) [x] | itWidth from > itWidth to = iCoerce Trunc from to x
836−cgOp (LZExt from to) [x] | itWidth from < itWidth to = iCoerce ZExt from to x
837−cgOp (LSExt from to) [x] | itWidth from < itWidth to = iCoerce SExt from to x
838−
839−cgOp (LLt ity) [x,y] = iCmp ity IPred.SLT x y
840−cgOp (LLe ity) [x,y] = iCmp ity IPred.SLE x y
841−cgOp (LEq ity) [x,y] = iCmp ity IPred.EQ x y
842−cgOp (LGe ity) [x,y] = iCmp ity IPred.SGE x y
843−cgOp (LGt ity) [x,y] = iCmp ity IPred.SGT x y
844−cgOp (LPlus ity) [x,y] = ibin ity x y (Add False False)
845−cgOp (LMinus ity) [x,y] = ibin ity x y (Sub False False)
846−cgOp (LTimes ity) [x,y] = ibin ity x y (Mul False False)
837+cgOp (LTrunc (ITFixed from) (ITFixed to)) [x]
838+ | nativeTyWidth from > nativeTyWidth to = iCoerce Trunc from to x
839+cgOp (LZExt (ITFixed from) (ITFixed to)) [x]
840+ | nativeTyWidth from < nativeTyWidth to = iCoerce ZExt from to x
841+cgOp (LSExt (ITFixed from) (ITFixed to)) [x]
842+ | nativeTyWidth from < nativeTyWidth to = iCoerce SExt from to x
843+
844+cgOp (LLt (ATInt ity)) [x,y] = iCmp ity IPred.SLT x y
845+cgOp (LLe (ATInt ity)) [x,y] = iCmp ity IPred.SLE x y
846+cgOp (LEq (ATInt ity)) [x,y] = iCmp ity IPred.EQ x y
847+cgOp (LGe (ATInt ity)) [x,y] = iCmp ity IPred.SGE x y
848+cgOp (LGt (ATInt ity)) [x,y] = iCmp ity IPred.SGT x y
849+cgOp (LPlus (ATInt ity)) [x,y] = ibin ity x y (Add False False)
850+cgOp (LMinus (ATInt ity)) [x,y] = ibin ity x y (Sub False False)
851+cgOp (LTimes (ATInt ity)) [x,y] = ibin ity x y (Mul False False)
852+cgOp (LSDiv (ATInt ity)) [x,y] = ibin ity x y (SDiv False)
853+cgOp (LSRem (ATInt ity)) [x,y] = ibin ity x y SRem
847854cgOp (LUDiv ity) [x,y] = ibin ity x y (UDiv False)
848855cgOp (LURem ity) [x,y] = ibin ity x y URem
849−cgOp (LSDiv ity) [x,y] = ibin ity x y (SDiv False)
850−cgOp (LSRem ity) [x,y] = ibin ity x y SRem
851856cgOp (LAnd ity) [x,y] = ibin ity x y And
852857cgOp (LOr ity) [x,y] = ibin ity x y Or
853858cgOp (LXOr ity) [x,y] = ibin ity x y Xor
@@ -864,7 +869,7 @@ cgOp LStrEq [x,y] = do
864869 cmp <- inst $ simpleCall "strcmp" [x', y']
865870 flag <- inst $ ICmp IPred.EQ cmp (ConstantOperand (C.Int 32 0)) []
866871 val <- inst $ ZExt flag (IntegerType 32) []
867− box (FInt IT32) val
872+ box (FArith (ATInt (ITFixed IT32))) val
868873
869874cgOp LStrLt [x,y] = do
870875 nx <- unbox FString x
@@ -872,10 +877,10 @@ cgOp LStrLt [x,y] = do
872877 cmp <- inst $ simpleCall "strcmp" [nx, ny]
873878 flag <- inst $ ICmp IPred.ULT cmp (ConstantOperand (C.Int 32 0)) []
874879 val <- inst $ ZExt flag (IntegerType 32) []
875− box (FInt IT32) val
880+ box (FArith (ATInt (ITFixed IT32))) val
876881
877882cgOp (LIntStr ITBig) [x] = do
878− x' <- unbox (FInt ITBig) x
883+ x' <- unbox (FArith (ATInt ITBig)) x
879884 ustr <- inst $ simpleCall "__gmpz_get_str"
880885 [ ConstantOperand (C.Null (PointerType (IntegerType 8) (AddrSpace 0)))
881886 , ConstantOperand (C.Int 32 10)
@@ -883,7 +888,7 @@ cgOp (LIntStr ITBig) [x] = do
883888 ]
884889 box FString ustr
885890cgOp (LIntStr ity) [x] = do
886− x' <- unbox (FInt ity) x
891+ x' <- unbox (FArith (ATInt ity)) x
887892 x'' <- if itWidth ity < 64
888893 then inst $ SExt x' (IntegerType 64) []
889894 else return x'
@@ -892,7 +897,7 @@ cgOp (LStrInt ITBig) [s] = do
892897 ns <- unbox FString s
893898 mpz <- alloc mpzTy
894899 inst $ simpleCall "__gmpz_init_set_str" [mpz, ns, ConstantOperand $ C.Int 32 10]
895− box (FInt ITBig) mpz
900+ box (FArith (ATInt ITBig)) mpz
896901cgOp (LStrInt ity) [s] = do
897902 ns <- unbox FString s
898903 nx <- inst $ simpleCall "strtoll"
@@ -901,9 +906,9 @@ cgOp (LStrInt ity) [s] = do
901906 , ConstantOperand $ C.Int 32 10
902907 ]
903908 nx' <- case ity of
904− IT64 -> return nx
909+ (ITFixed IT64) -> return nx
905910 _ -> inst $ Trunc nx (IntegerType (itWidth ity)) []
906− box (FInt ity) nx'
911+ box (FArith (ATInt ity)) nx'
907912
908913cgOp LStrConcat [x,y] = cgStrCat x y
909914
@@ -922,7 +927,7 @@ cgOp LStrHead [c] = do
922927
923928cgOp LStrIndex [s, i] = do
924929 ns <- unbox FString s
925− ni <- unbox (FInt IT32) i
930+ ni <- unbox (FArith (ATInt (ITFixed IT32))) i
926931 p <- inst $ GetElementPtr True ns [ni] []
927932 c <- inst $ Load False p Nothing 0 []
928933 c' <- inst $ ZExt c (IntegerType 32) []
@@ -941,7 +946,7 @@ cgOp LStrLen [s] = do
941946 32 -> return len
942947 x | x > 32 -> inst $ Trunc len (IntegerType 32) []
943948 | x < 32 -> inst $ ZExt len (IntegerType 32) []
944− box (FInt IT32) len'
949+ box (FArith (ATInt (ITFixed IT32))) len'
945950
946951cgOp LReadStr [p] = do
947952 np <- unbox FPtr p
@@ -964,11 +969,11 @@ cgOp LStdErr [] = do
964969cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
965970 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
966971
967−iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> IntTy -> IntTy -> Operand -> Codegen Operand
972+iCoerce :: (Operand -> Type -> InstructionMetadata -> Instruction) -> NativeTy -> NativeTy -> Operand -> Codegen Operand
968973iCoerce operator from to x = do
969− x' <- unbox (FInt from) x
970− x'' <- inst $ operator x' (IntegerType $ itWidth to) []
971− box (FInt to) x''
974+ x' <- unbox (FArith (ATInt (ITFixed from))) x
975+ x'' <- inst $ operator x' (ftyToTy (FArith (ATInt (ITFixed from)))) []
976+ box (FArith (ATInt (ITFixed to))) x''
972977
973978cgStrCat :: Operand -> Operand -> Codegen Operand
974979cgStrCat x y = do
@@ -994,50 +999,50 @@ cgStrCat x y = do
994999ibin :: IntTy -> Operand -> Operand
9951000 -> (Operand -> Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
9961001ibin ity x y instCon = do
997− nx <- unbox (FInt ity) x
998− ny <- unbox (FInt ity) y
1002+ nx <- unbox (FArith (ATInt ity)) x
1003+ ny <- unbox (FArith (ATInt ity)) y
9991004 nr <- inst $ instCon nx ny []
1000− box (FInt ity) nr
1005+ box (FArith (ATInt ity)) nr
10011006
10021007iun :: IntTy -> Operand -> (Operand -> InstructionMetadata -> Instruction) -> Codegen Operand
10031008iun ity x instCon = do
1004− nx <- unbox (FInt ity) x
1009+ nx <- unbox (FArith (ATInt ity)) x
10051010 nr <- inst $ instCon nx []
1006− box (FInt ity) nr
1011+ box (FArith (ATInt ity)) nr
10071012
10081013iCmp :: IntTy -> IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
10091014iCmp ity pred x y = do
1010− nx <- unbox (FInt ity) x
1011− ny <- unbox (FInt ity) y
1015+ nx <- unbox (FArith (ATInt ity)) x
1016+ ny <- unbox (FArith (ATInt ity)) y
10121017 nr <- inst $ ICmp pred nx ny []
10131018 nr' <- inst $ ZExt nr (IntegerType 32) []
1014− box (FInt IT32) nr'
1019+ box (FArith (ATInt (ITFixed IT32))) nr'
10151020
10161021mpzBin :: String -> Operand -> Operand -> Codegen Operand
10171022mpzBin name x y = do
1018− nx <- unbox (FInt ITBig) x
1019− ny <- unbox (FInt ITBig) y
1023+ nx <- unbox (FArith (ATInt ITBig)) x
1024+ ny <- unbox (FArith (ATInt ITBig)) y
10201025 nz <- alloc mpzTy
10211026 inst' $ simpleCall "__gmpz_init" [nz]
10221027 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx, ny]
1023− box (FInt ITBig) nz
1028+ box (FArith (ATInt ITBig)) nz
10241029
10251030mpzUn :: String -> Operand -> Codegen Operand
10261031mpzUn name x = do
1027− nx <- unbox (FInt ITBig) x
1032+ nx <- unbox (FArith (ATInt ITBig)) x
10281033 nz <- alloc mpzTy
10291034 inst' $ simpleCall "__gmpz_init" [nz]
10301035 inst' $ simpleCall ("__gmpz_" ++ name) [nz, nx]
1031− box (FInt ITBig) nz
1036+ box (FArith (ATInt ITBig)) nz
10321037
10331038mpzCmp :: IPred.IntegerPredicate -> Operand -> Operand -> Codegen Operand
10341039mpzCmp pred x y = do
1035− nx <- unbox (FInt ITBig) x
1036− ny <- unbox (FInt ITBig) y
1040+ nx <- unbox (FArith (ATInt ITBig)) x
1041+ ny <- unbox (FArith (ATInt ITBig)) y
10371042 cmp <- inst $ simpleCall "__gmpz_cmp" [nx, ny]
10381043 result <- inst $ ICmp pred cmp (ConstantOperand (C.Int 32 0)) []
10391044 i <- inst $ ZExt result (IntegerType 32) []
1040− box (FInt IT32) i
1045+ box (FArith (ATInt (ITFixed IT32))) i
10411046
10421047simpleCall :: String -> [Operand] -> Instruction
10431048simpleCall name args =
src/IRTS/Compiler.hs+12−12
@@ -299,7 +299,7 @@ mkIty' _ = FAny
299299-- would be better if these FInt types were evaluated at compile time
300300-- TODO: add %eval directive for such things
301301
302−mkIty "FFloat" = FDouble
302+mkIty "FFloat" = FArith ATFloat
303303mkIty "FInt" = mkIntIty "ITNative"
304304mkIty "FChar" = mkIntIty "IT8"
305305mkIty "FShort" = mkIntIty "IT16"
@@ -311,11 +311,11 @@ mkIty "FFunction" = FFunction
311311mkIty "FFunctionIO" = FFunctionIO
312312mkIty x = error $ "Unknown type " ++ x
313313
314−mkIntIty "ITNative" = FInt ITNative
315−mkIntIty "IT8" = FInt IT8
316−mkIntIty "IT16" = FInt IT16
317−mkIntIty "IT32" = FInt IT32
318−mkIntIty "IT64" = FInt IT64
314+mkIntIty "ITNative" = FArith (ATInt ITNative)
315+mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))
316+mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))
317+mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))
318+mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))
319319
320320zname = NS (UN "O") ["Nat","Prelude"]
321321sname = NS (UN "S") ["Nat","Prelude"]
@@ -369,15 +369,15 @@ instance ToIR SC where
369369 matchable (Str _) = True
370370 matchable _ = False
371371
372− matchableTy IType = True
373− matchableTy BIType = True
372+ matchableTy (AType (ATInt ITNative)) = True
373+ matchableTy (AType (ATInt ITBig)) = True
374374 matchableTy ChType = True
375375 matchableTy StrType = True
376376
377− matchableTy B8Type = True
378− matchableTy B16Type = True
379− matchableTy B32Type = True
380− matchableTy B64Type = True
377+ matchableTy (AType (ATInt (ITFixed IT8))) = True
378+ matchableTy (AType (ATInt (ITFixed IT16))) = True
379+ matchableTy (AType (ATInt (ITFixed IT32))) = True
380+ matchableTy (AType (ATInt (ITFixed IT64))) = True
381381
382382 matchableTy _ = False
383383
src/IRTS/LParser.hs+29−29
@@ -92,39 +92,39 @@ pLDecl = do reserved "data"
9292
9393pLExp = buildExpressionParser optable pLExp'
9494
95−optable = [[binary "*" (\x y -> LOp (LTimes ITNative) [x,y]) AssocLeft,
96− binary "/" (\x y -> LOp (LSDiv ITNative) [x,y]) AssocLeft,
97− binary "*." (\x y -> LOp LFTimes [x,y]) AssocLeft,
98− binary "/." (\x y -> LOp LFDiv [x,y]) AssocLeft,
99− binary "*:" (\x y -> LOp (LTimes ITBig) [x,y]) AssocLeft,
100− binary "/:" (\x y -> LOp (LSDiv ITBig) [x,y]) AssocLeft
95+optable = [[binary "*" (\x y -> LOp (LTimes (ATInt ITNative)) [x,y]) AssocLeft,
96+ binary "/" (\x y -> LOp (LSDiv (ATInt ITNative)) [x,y]) AssocLeft,
97+ binary "*." (\x y -> LOp (LTimes ATFloat) [x,y]) AssocLeft,
98+ binary "/." (\x y -> LOp (LSDiv ATFloat) [x,y]) AssocLeft,
99+ binary "*:" (\x y -> LOp (LTimes (ATInt ITBig)) [x,y]) AssocLeft,
100+ binary "/:" (\x y -> LOp (LSDiv (ATInt ITBig)) [x,y]) AssocLeft
101101 ],
102102 [
103− binary "+" (\x y -> LOp (LPlus ITNative) [x,y]) AssocLeft,
104− binary "-" (\x y -> LOp (LMinus ITNative) [x,y]) AssocLeft,
103+ binary "+" (\x y -> LOp (LPlus (ATInt ITNative)) [x,y]) AssocLeft,
104+ binary "-" (\x y -> LOp (LMinus (ATInt ITNative)) [x,y]) AssocLeft,
105105 binary "++" (\x y -> LOp LStrConcat [x,y]) AssocLeft,
106− binary "+." (\x y -> LOp LFPlus [x,y]) AssocLeft,
107− binary "-." (\x y -> LOp LFMinus [x,y]) AssocLeft,
108− binary "+:" (\x y -> LOp (LPlus ITBig) [x,y]) AssocLeft,
109− binary "-:" (\x y -> LOp (LMinus ITBig) [x,y]) AssocLeft
106+ binary "+." (\x y -> LOp (LPlus ATFloat) [x,y]) AssocLeft,
107+ binary "-." (\x y -> LOp (LMinus ATFloat) [x,y]) AssocLeft,
108+ binary "+:" (\x y -> LOp (LPlus (ATInt ITBig)) [x,y]) AssocLeft,
109+ binary "-:" (\x y -> LOp (LMinus (ATInt ITBig)) [x,y]) AssocLeft
110110 ],
111111 [
112− binary "==" (\x y -> LOp (LEq ITNative) [x, y]) AssocNone,
113− binary "==." (\x y -> LOp LFEq [x, y]) AssocNone,
114− binary "<" (\x y -> LOp (LLt ITNative) [x, y]) AssocNone,
115− binary "<." (\x y -> LOp LFLt [x, y]) AssocNone,
116− binary ">" (\x y -> LOp (LGt ITNative) [x, y]) AssocNone,
117− binary ">." (\x y -> LOp LFGt [x, y]) AssocNone,
118− binary "<=" (\x y -> LOp (LLe ITNative) [x, y]) AssocNone,
119− binary "<=." (\x y -> LOp LFLe [x, y]) AssocNone,
120− binary ">=" (\x y -> LOp (LGe ITNative) [x, y]) AssocNone,
121− binary ">=." (\x y -> LOp LFGe [x, y]) AssocNone,
112+ binary "==" (\x y -> LOp (LEq (ATInt ITNative)) [x, y]) AssocNone,
113+ binary "==." (\x y -> LOp (LEq ATFloat) [x, y]) AssocNone,
114+ binary "<" (\x y -> LOp (LLt (ATInt ITNative)) [x, y]) AssocNone,
115+ binary "<." (\x y -> LOp (LLt ATFloat) [x, y]) AssocNone,
116+ binary ">" (\x y -> LOp (LGt (ATInt ITNative)) [x, y]) AssocNone,
117+ binary ">." (\x y -> LOp (LGt ATFloat) [x, y]) AssocNone,
118+ binary "<=" (\x y -> LOp (LLe (ATInt ITNative)) [x, y]) AssocNone,
119+ binary "<=." (\x y -> LOp (LLe ATFloat) [x, y]) AssocNone,
120+ binary ">=" (\x y -> LOp (LGe (ATInt ITNative)) [x, y]) AssocNone,
121+ binary ">=." (\x y -> LOp (LGe ATFloat) [x, y]) AssocNone,
122122
123− binary "==:" (\x y -> LOp (LEq ITBig) [x, y]) AssocNone,
124− binary "<:" (\x y -> LOp (LLt ITBig) [x, y]) AssocNone,
125− binary ">:" (\x y -> LOp (LGt ITBig) [x, y]) AssocNone,
126− binary "<=:" (\x y -> LOp (LLe ITBig) [x, y]) AssocNone,
127− binary ">=:" (\x y -> LOp (LGe ITBig) [x, y]) AssocNone
123+ binary "==:" (\x y -> LOp (LEq (ATInt ITBig)) [x, y]) AssocNone,
124+ binary "<:" (\x y -> LOp (LLt (ATInt ITBig)) [x, y]) AssocNone,
125+ binary ">:" (\x y -> LOp (LGt (ATInt ITBig)) [x, y]) AssocNone,
126+ binary "<=:" (\x y -> LOp (LLe (ATInt ITBig)) [x, y]) AssocNone,
127+ binary ">=:" (\x y -> LOp (LGe (ATInt ITBig)) [x, y]) AssocNone
128128 ]]
129129
130130binary name f assoc = Infix (do reservedOp name; return f) assoc
@@ -164,8 +164,8 @@ pLExp' = try (do lchar '%'; pCast)
164164
165165pLang = do reserved "C"; return LANG_C
166166
167−pType = do reserved "Int"; return (FInt ITNative)
168− <|> do reserved "Float"; return FDouble
167+pType = do reserved "Int"; return (FArith (ATInt ITNative))
168+ <|> do reserved "Float"; return (FArith ATFloat)
169169 <|> do reserved "String"; return FString
170170 <|> do reserved "Unit"; return FUnit
171171 <|> do reserved "Ptr"; return FPtr
src/IRTS/Lang.hs+6−27
@@ -3,7 +3,6 @@ module IRTS.Lang where
33import Core.TT
44import Control.Monad.State hiding(lift)
55import Data.List
6−import Foreign.Storable (sizeOf)
76import Debug.Trace
87
98data LVar = Loc Int | Glob Name
@@ -29,33 +28,12 @@ data LExp = LV LVar
2928-- Primitive operators. Backends are not *required* to implement all
3029-- of these, but should report an error if they are unable
3130
32−data IntTy = ITNative | IT8 | IT16 | IT32 | IT64 | ITBig
33− deriving (Show, Eq)
34−
35−intTyWidth :: IntTy -> Int
36−intTyWidth IT8 = 8
37−intTyWidth IT16 = 16
38−intTyWidth IT32 = 32
39−intTyWidth IT64 = 64
40−intTyWidth ITNative = 8 * sizeOf (0 :: Int)
41−intTyWidth ITBig = error "IRTS.Lang.intTyWidth: Big integers have variable width"
42−
43−intTyToConst :: IntTy -> Const
44−intTyToConst IT8 = B8Type
45−intTyToConst IT16 = B16Type
46−intTyToConst IT32 = B32Type
47−intTyToConst IT64 = B64Type
48−intTyToConst ITBig = BIType
49−intTyToConst ITNative = IType
50−
51−data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy
52− | LUDiv IntTy | LSDiv IntTy | LURem IntTy | LSRem IntTy
31+data PrimFn = LPlus ArithTy | LMinus ArithTy | LTimes ArithTy
32+ | LUDiv IntTy | LSDiv ArithTy | LURem IntTy | LSRem ArithTy
5333 | LAnd IntTy | LOr IntTy | LXOr IntTy | LCompl IntTy
5434 | LSHL IntTy | LLSHR IntTy | LASHR IntTy
55− | LEq IntTy | LLt IntTy | LLe IntTy | LGt IntTy | LGe IntTy
35+ | LEq ArithTy | LLt ArithTy | LLe ArithTy | LGt ArithTy | LGe ArithTy
5636 | LSExt IntTy IntTy | LZExt IntTy IntTy | LTrunc IntTy IntTy
57− | LFPlus | LFMinus | LFTimes | LFDiv
58− | LFEq | LFLt | LFLe | LFGt | LFGe
5937 | LStrConcat | LStrLt | LStrEq | LStrLen
6038 | LIntFloat IntTy | LFloatInt IntTy | LIntStr IntTy | LStrInt IntTy
6139 | LFloatStr | LStrFloat | LChInt IntTy | LIntCh IntTy
@@ -64,6 +42,8 @@ data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy
6442 | LFExp | LFLog | LFSin | LFCos | LFTan | LFASin | LFACos | LFATan
6543 | LFSqrt | LFFloor | LFCeil
6644
45+ | LMkVec NativeTy Int
46+
6747 | LStrHead | LStrTail | LStrCons | LStrIndex | LStrRev
6848 | LStdIn | LStdOut | LStdErr
6949
@@ -79,14 +59,13 @@ data PrimFn = LPlus IntTy | LMinus IntTy | LTimes IntTy
7959data FLang = LANG_C
8060 deriving (Show, Eq)
8161
82−data FType = FInt IntTy
62+data FType = FArith ArithTy
8363 | FFunction
8464 | FFunctionIO
8565 | FChar
8666 | FString
8767 | FUnit
8868 | FPtr
89− | FDouble
9069 | FAny
9170 deriving (Show, Eq)
9271
src/Idris/ElabDecls.hs+1−1
@@ -1174,7 +1174,7 @@ elabInstance info syn fc cs n ps t expn ds
11741174-- mapM_ (elabDecl EAll info) (concat fns)
11751175 where
11761176 intInst = case ps of
1177− [PConstant IType] -> True
1177+ [PConstant (AType (ATInt ITNative))] -> True
11781178 _ -> False
11791179
11801180 checkNotOverlapping i t n
src/Idris/ElabTerm.hs+15−15
@@ -653,7 +653,7 @@ resolveTC depth fn ist
653653
654654 needsDefault t num@(P _ (NS (UN "Num") ["Builtins"]) _) [P Bound a _]
655655 = do focus a
656− fill (RConstant IType) -- default Int
656+ fill (RConstant (AType (ATInt ITNative))) -- default Int
657657 solve
658658 return False
659659 needsDefault t f as
@@ -1060,15 +1060,15 @@ reifyTTBinderApp reif f [t]
10601060reifyTTBinderApp _ f args = fail ("Unknown reflection binder: " ++ show (f, args))
10611061
10621062reifyTTConst :: Term -> ElabD Const
1063−reifyTTConst (P _ n _) | n == reflm "IType" = return $ IType
1064−reifyTTConst (P _ n _) | n == reflm "BIType" = return $ BIType
1065−reifyTTConst (P _ n _) | n == reflm "FlType" = return $ FlType
1063+reifyTTConst (P _ n _) | n == reflm "IType" = return (AType (ATInt ITNative))
1064+reifyTTConst (P _ n _) | n == reflm "BIType" = return (AType (ATInt ITBig))
1065+reifyTTConst (P _ n _) | n == reflm "FlType" = return (AType ATFloat)
10661066reifyTTConst (P _ n _) | n == reflm "ChType" = return $ ChType
10671067reifyTTConst (P _ n _) | n == reflm "StrType" = return $ StrType
1068−reifyTTConst (P _ n _) | n == reflm "B8Type" = return $ B8Type
1069−reifyTTConst (P _ n _) | n == reflm "B16Type" = return $ B16Type
1070−reifyTTConst (P _ n _) | n == reflm "B32Type" = return $ B32Type
1071−reifyTTConst (P _ n _) | n == reflm "B64Type" = return $ B64Type
1068+reifyTTConst (P _ n _) | n == reflm "B8Type" = return (AType (ATInt (ITFixed IT8)))
1069+reifyTTConst (P _ n _) | n == reflm "B16Type" = return (AType (ATInt (ITFixed IT16)))
1070+reifyTTConst (P _ n _) | n == reflm "B32Type" = return (AType (ATInt (ITFixed IT32)))
1071+reifyTTConst (P _ n _) | n == reflm "B64Type" = return (AType (ATInt (ITFixed IT64)))
10721072reifyTTConst (P _ n _) | n == reflm "PtrType" = return $ PtrType
10731073reifyTTConst (P _ n _) | n == reflm "VoidType" = return $ VoidType
10741074reifyTTConst (P _ n _) | n == reflm "Forgot" = return $ Forgot
@@ -1178,19 +1178,19 @@ reflectConstant c@(BI _) = reflCall "BI" [RConstant c]
11781178reflectConstant c@(Fl _) = reflCall "Fl" [RConstant c]
11791179reflectConstant c@(Ch _) = reflCall "Ch" [RConstant c]
11801180reflectConstant c@(Str _) = reflCall "Str" [RConstant c]
1181−reflectConstant (IType) = Var (reflm "IType")
1182−reflectConstant (BIType) = Var (reflm "BIType")
1183−reflectConstant (FlType) = Var (reflm "FlType")
1181+reflectConstant (AType (ATInt ITNative)) = Var (reflm "IType")
1182+reflectConstant (AType (ATInt ITBig)) = Var (reflm "BIType")
1183+reflectConstant (AType ATFloat) = Var (reflm "FlType")
11841184reflectConstant (ChType) = Var (reflm "ChType")
11851185reflectConstant (StrType) = Var (reflm "StrType")
11861186reflectConstant c@(B8 _) = reflCall "B8" [RConstant c]
11871187reflectConstant c@(B16 _) = reflCall "B16" [RConstant c]
11881188reflectConstant c@(B32 _) = reflCall "B32" [RConstant c]
11891189reflectConstant c@(B64 _) = reflCall "B64" [RConstant c]
1190−reflectConstant (B8Type) = Var (reflm "B8Type")
1191−reflectConstant (B16Type) = Var (reflm "B16Type")
1192−reflectConstant (B32Type) = Var (reflm "B32Type")
1193−reflectConstant (B64Type) = Var (reflm "B64Type")
1190+reflectConstant (AType (ATInt (ITFixed IT8))) = Var (reflm "B8Type")
1191+reflectConstant (AType (ATInt (ITFixed IT16))) = Var (reflm "B16Type")
1192+reflectConstant (AType (ATInt (ITFixed IT32))) = Var (reflm "B32Type")
1193+reflectConstant (AType (ATInt (ITFixed IT64))) = Var (reflm "B64Type")
11941194reflectConstant (PtrType) = Var (reflm "PtrType")
11951195reflectConstant (VoidType) = Var (reflm "VoidType")
11961196reflectConstant (Forgot) = Var (reflm "Forgot")
src/Idris/IBC.hs+21−15
@@ -364,7 +364,7 @@ instance Binary Name where
364364 3 -> return NErased
365365 _ -> error "Corrupted binary data for Name"
366366
367−
367+
368368instance Binary Const where
369369 put x
370370 = case x of
@@ -383,17 +383,18 @@ instance Binary Const where
383383 B32 x1 -> putWord8 7 >> put x1
384384 B64 x1 -> putWord8 8 >> put x1
385385
386− IType -> putWord8 9
387− BIType -> putWord8 10
388− FlType -> putWord8 11
386+ (AType (ATInt ITNative)) -> putWord8 9
387+ (AType (ATInt ITBig)) -> putWord8 10
388+ (AType ATFloat) -> putWord8 11
389389 ChType -> putWord8 12
390390 StrType -> putWord8 13
391391 PtrType -> putWord8 14
392392 Forgot -> putWord8 15
393− B8Type -> putWord8 16
394− B16Type -> putWord8 17
395− B32Type -> putWord8 18
396− B64Type -> putWord8 19
393+ (AType (ATInt (ITFixed ity))) -> put (16 + fromEnum ity) -- 16-19 inclusive
394+ (AType (ATInt (ITVec ity count))) -> do
395+ putWord8 20
396+ putWord8 (fromIntegral . fromEnum $ ity)
397+ putWord8 (fromIntegral count)
397398 get
398399 = do i <- getWord8
399400 case i of
@@ -412,18 +413,23 @@ instance Binary Const where
412413 7 -> fmap B32 get
413414 8 -> fmap B64 get
414415
415− 9 -> return IType
416− 10 -> return BIType
417− 11 -> return FlType
416+ 9 -> return (AType (ATInt ITNative))
417+ 10 -> return (AType (ATInt ITBig))
418+ 11 -> return (AType ATFloat)
418419 12 -> return ChType
419420 13 -> return StrType
420421 14 -> return PtrType
421422 15 -> return Forgot
422423
423− 16 -> return B8Type
424− 17 -> return B16Type
425− 18 -> return B32Type
426− 19 -> return B64Type
424+ 16 -> return (AType (ATInt (ITFixed IT8)))
425+ 17 -> return (AType (ATInt (ITFixed IT16)))
426+ 18 -> return (AType (ATInt (ITFixed IT32)))
427+ 19 -> return (AType (ATInt (ITFixed IT64)))
428+
429+ 20 -> do
430+ e <- getWord8
431+ c <- getWord8
432+ return (AType (ATInt (ITVec (toEnum . fromIntegral $ e) (fromIntegral c))))
427433
428434 _ -> error "Corrupted binary data for Const"
429435
src/Idris/Parser.hs+7−7
@@ -1139,16 +1139,16 @@ pIdiom syn
11391139 return (PIdiom fc e)
11401140
11411141pConstant :: IParser Const
1142−pConstant = do reserved "Integer";return BIType
1143− <|> do reserved "Int"; return IType
1142+pConstant = do reserved "Integer";return (AType (ATInt ITBig))
1143+ <|> do reserved "Int"; return (AType (ATInt ITNative))
11441144 <|> do reserved "Char"; return ChType
1145− <|> do reserved "Float"; return FlType
1145+ <|> do reserved "Float"; return (AType ATFloat)
11461146 <|> do reserved "String"; return StrType
11471147 <|> do reserved "Ptr"; return PtrType
1148− <|> do reserved "Bits8"; return B8Type
1149− <|> do reserved "Bits16"; return B16Type
1150− <|> do reserved "Bits32"; return B32Type
1151− <|> do reserved "Bits64"; return B64Type
1148+ <|> do reserved "Bits8"; return (AType (ATInt (ITFixed IT8)))
1149+ <|> do reserved "Bits16"; return (AType (ATInt (ITFixed IT16)))
1150+ <|> do reserved "Bits32"; return (AType (ATInt (ITFixed IT32)))
1151+ <|> do reserved "Bits64"; return (AType (ATInt (ITFixed IT64)))
11521152 <|> try (do f <- float; return $ Fl f)
11531153 <|> try (do i <- natural; return $ BI i)
11541154 <|> try (do s <- strlit; return $ Str s)
src/Idris/Primitives.hs+197−168
@@ -11,6 +11,7 @@ import Core.Evaluate
1111import Data.Bits
1212import Data.Word
1313import Data.Int
14+import qualified Data.Vector.Unboxed as V
1415
1516data Prim = Prim { p_name :: Name,
1617 p_type :: Type,
@@ -31,130 +32,130 @@ partial = Partial NotCovering
3132primitives :: [Prim]
3233primitives =
3334 -- operators
34− [Prim (UN "prim__eqChar") (ty [ChType, ChType] IType) 2 (bcBin (==))
35− (2, LEq ITNative) total,
36− Prim (UN "prim__ltChar") (ty [ChType, ChType] IType) 2 (bcBin (<))
37− (2, LLt ITNative) total,
38− Prim (UN "prim__lteChar") (ty [ChType, ChType] IType) 2 (bcBin (<=))
39− (2, LLe ITNative) total,
40− Prim (UN "prim__gtChar") (ty [ChType, ChType] IType) 2 (bcBin (>))
41− (2, LGt ITNative) total,
42− Prim (UN "prim__gteChar") (ty [ChType, ChType] IType) 2 (bcBin (>=))
43− (2, LGe ITNative) total,
44−
45− iCoerce IT8 IT16 "zext" zext LZExt,
46− iCoerce IT8 IT32 "zext" zext LZExt,
47− iCoerce IT8 IT64 "zext" zext LZExt,
48− iCoerce IT8 ITBig "zext" zext LZExt,
49− iCoerce IT8 ITNative "zext" zext LZExt,
50− iCoerce IT16 IT32 "zext" zext LZExt,
51− iCoerce IT16 IT64 "zext" zext LZExt,
52− iCoerce IT16 ITBig "zext" zext LZExt,
53− iCoerce IT16 ITNative "zext" zext LZExt,
54− iCoerce IT32 IT64 "zext" zext LZExt,
55− iCoerce IT32 ITBig "zext" zext LZExt,
56− iCoerce IT32 ITNative "zext" zext LZExt,
57− iCoerce IT64 ITBig "zext" zext LZExt,
35+ [Prim (UN "prim__eqChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (==))
36+ (2, LEq (ATInt ITNative)) total,
37+ Prim (UN "prim__ltChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (<))
38+ (2, LLt (ATInt ITNative)) total,
39+ Prim (UN "prim__lteChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (<=))
40+ (2, LLe (ATInt ITNative)) total,
41+ Prim (UN "prim__gtChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (>))
42+ (2, LGt (ATInt ITNative)) total,
43+ Prim (UN "prim__gteChar") (ty [ChType, ChType] (AType (ATInt ITNative))) 2 (bcBin (>=))
44+ (2, LGe (ATInt ITNative)) total,
45+
46+ iCoerce (ITFixed IT8) (ITFixed IT16) "zext" zext LZExt,
47+ iCoerce (ITFixed IT8) (ITFixed IT32) "zext" zext LZExt,
48+ iCoerce (ITFixed IT8) (ITFixed IT64) "zext" zext LZExt,
49+ iCoerce (ITFixed IT8) ITBig "zext" zext LZExt,
50+ iCoerce (ITFixed IT8) ITNative "zext" zext LZExt,
51+ iCoerce (ITFixed IT16) (ITFixed IT32) "zext" zext LZExt,
52+ iCoerce (ITFixed IT16) (ITFixed IT64) "zext" zext LZExt,
53+ iCoerce (ITFixed IT16) ITBig "zext" zext LZExt,
54+ iCoerce (ITFixed IT16) ITNative "zext" zext LZExt,
55+ iCoerce (ITFixed IT32) (ITFixed IT64) "zext" zext LZExt,
56+ iCoerce (ITFixed IT32) ITBig "zext" zext LZExt,
57+ iCoerce (ITFixed IT32) ITNative "zext" zext LZExt,
58+ iCoerce (ITFixed IT64) ITBig "zext" zext LZExt,
5859 iCoerce ITNative ITBig "zext" zext LZExt,
59− iCoerce ITNative IT64 "zext" zext LZExt,
60− iCoerce ITNative IT32 "zext" zext LZExt,
61− iCoerce ITNative IT16 "zext" zext LZExt,
62−
63− iCoerce IT8 IT16 "sext" sext LSExt,
64− iCoerce IT8 IT32 "sext" sext LSExt,
65− iCoerce IT8 IT64 "sext" sext LSExt,
66− iCoerce IT8 ITBig "sext" sext LSExt,
67− iCoerce IT8 ITNative "sext" sext LSExt,
68− iCoerce IT16 IT32 "sext" sext LSExt,
69− iCoerce IT16 IT64 "sext" sext LSExt,
70− iCoerce IT16 ITBig "sext" sext LSExt,
71− iCoerce IT16 ITNative "sext" sext LSExt,
72− iCoerce IT32 IT64 "sext" sext LSExt,
73− iCoerce IT32 ITBig "sext" sext LSExt,
74− iCoerce IT32 ITNative "sext" sext LSExt,
75− iCoerce IT64 ITBig "sext" sext LSExt,
60+ iCoerce ITNative (ITFixed IT64) "zext" zext LZExt,
61+ iCoerce ITNative (ITFixed IT32) "zext" zext LZExt,
62+ iCoerce ITNative (ITFixed IT16) "zext" zext LZExt,
63+
64+ iCoerce (ITFixed IT8) (ITFixed IT16) "sext" sext LSExt,
65+ iCoerce (ITFixed IT8) (ITFixed IT32) "sext" sext LSExt,
66+ iCoerce (ITFixed IT8) (ITFixed IT64) "sext" sext LSExt,
67+ iCoerce (ITFixed IT8) ITBig "sext" sext LSExt,
68+ iCoerce (ITFixed IT8) ITNative "sext" sext LSExt,
69+ iCoerce (ITFixed IT16) (ITFixed IT32) "sext" sext LSExt,
70+ iCoerce (ITFixed IT16) (ITFixed IT64) "sext" sext LSExt,
71+ iCoerce (ITFixed IT16) ITBig "sext" sext LSExt,
72+ iCoerce (ITFixed IT16) ITNative "sext" sext LSExt,
73+ iCoerce (ITFixed IT32) (ITFixed IT64) "sext" sext LSExt,
74+ iCoerce (ITFixed IT32) ITBig "sext" sext LSExt,
75+ iCoerce (ITFixed IT32) ITNative "sext" sext LSExt,
76+ iCoerce (ITFixed IT64) ITBig "sext" sext LSExt,
7677 iCoerce ITNative ITBig "sext" sext LSExt,
7778 iCoerce ITNative ITBig "sext" sext LSExt,
78− iCoerce ITNative IT64 "sext" sext LSExt,
79− iCoerce ITNative IT32 "sext" sext LSExt,
80− iCoerce ITNative IT16 "sext" sext LSExt,
81−
82− iCoerce IT16 IT8 "trunc" trunc LTrunc,
83− iCoerce IT32 IT8 "trunc" trunc LTrunc,
84− iCoerce IT64 IT8 "trunc" trunc LTrunc,
85− iCoerce ITBig IT8 "trunc" trunc LTrunc,
86− iCoerce ITNative IT8 "trunc" trunc LTrunc,
87− iCoerce IT32 IT16 "trunc" trunc LTrunc,
88− iCoerce IT64 IT16 "trunc" trunc LTrunc,
89− iCoerce ITBig IT16 "trunc" trunc LTrunc,
90− iCoerce ITNative IT16 "trunc" trunc LTrunc,
91− iCoerce IT64 IT32 "trunc" trunc LTrunc,
92− iCoerce ITBig IT32 "trunc" trunc LTrunc,
93− iCoerce ITNative IT32 "trunc" trunc LTrunc,
94− iCoerce ITBig IT64 "trunc" trunc LTrunc,
95− iCoerce IT16 ITNative "trunc" trunc LTrunc,
96− iCoerce IT32 ITNative "trunc" trunc LTrunc,
97− iCoerce IT64 ITNative "trunc" trunc LTrunc,
79+ iCoerce ITNative (ITFixed IT64) "sext" sext LSExt,
80+ iCoerce ITNative (ITFixed IT32) "sext" sext LSExt,
81+ iCoerce ITNative (ITFixed IT16) "sext" sext LSExt,
82+
83+ iCoerce (ITFixed IT16) (ITFixed IT8) "trunc" trunc LTrunc,
84+ iCoerce (ITFixed IT32) (ITFixed IT8) "trunc" trunc LTrunc,
85+ iCoerce (ITFixed IT64) (ITFixed IT8) "trunc" trunc LTrunc,
86+ iCoerce ITBig (ITFixed IT8) "trunc" trunc LTrunc,
87+ iCoerce ITNative (ITFixed IT8) "trunc" trunc LTrunc,
88+ iCoerce (ITFixed IT32) (ITFixed IT16) "trunc" trunc LTrunc,
89+ iCoerce (ITFixed IT64) (ITFixed IT16) "trunc" trunc LTrunc,
90+ iCoerce ITBig (ITFixed IT16) "trunc" trunc LTrunc,
91+ iCoerce ITNative (ITFixed IT16) "trunc" trunc LTrunc,
92+ iCoerce (ITFixed IT64) (ITFixed IT32) "trunc" trunc LTrunc,
93+ iCoerce ITBig (ITFixed IT32) "trunc" trunc LTrunc,
94+ iCoerce ITNative (ITFixed IT32) "trunc" trunc LTrunc,
95+ iCoerce ITBig (ITFixed IT64) "trunc" trunc LTrunc,
96+ iCoerce (ITFixed IT16) ITNative "trunc" trunc LTrunc,
97+ iCoerce (ITFixed IT32) ITNative "trunc" trunc LTrunc,
98+ iCoerce (ITFixed IT64) ITNative "trunc" trunc LTrunc,
9899 iCoerce ITBig ITNative "trunc" trunc LTrunc,
99− iCoerce ITNative IT64 "trunc" trunc LTrunc,
100−
101− Prim (UN "prim__addFloat") (ty [FlType, FlType] FlType) 2 (fBin (+))
102− (2, LFPlus) total,
103− Prim (UN "prim__subFloat") (ty [FlType, FlType] FlType) 2 (fBin (-))
104− (2, LFMinus) total,
105− Prim (UN "prim__mulFloat") (ty [FlType, FlType] FlType) 2 (fBin (*))
106− (2, LFTimes) total,
107− Prim (UN "prim__divFloat") (ty [FlType, FlType] FlType) 2 (fBin (/))
108− (2, LFDiv) total,
109− Prim (UN "prim__eqFloat") (ty [FlType, FlType] IType) 2 (bfBin (==))
110− (2, LFEq) total,
111− Prim (UN "prim__ltFloat") (ty [FlType, FlType] IType) 2 (bfBin (<))
112− (2, LFLt) total,
113− Prim (UN "prim__lteFloat") (ty [FlType, FlType] IType) 2 (bfBin (<=))
114− (2, LFLe) total,
115− Prim (UN "prim__gtFloat") (ty [FlType, FlType] IType) 2 (bfBin (>))
116− (2, LFGt) total,
117− Prim (UN "prim__gteFloat") (ty [FlType, FlType] IType) 2 (bfBin (>=))
118− (2, LFGe) total,
100+ iCoerce ITNative (ITFixed IT64) "trunc" trunc LTrunc,
101+
102+ Prim (UN "prim__addFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (+))
103+ (2, LPlus ATFloat) total,
104+ Prim (UN "prim__subFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (-))
105+ (2, LMinus ATFloat) total,
106+ Prim (UN "prim__mulFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (*))
107+ (2, LTimes ATFloat) total,
108+ Prim (UN "prim__divFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType ATFloat)) 2 (fBin (/))
109+ (2, LSDiv ATFloat) total,
110+ Prim (UN "prim__eqFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (==))
111+ (2, LEq ATFloat) total,
112+ Prim (UN "prim__ltFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<))
113+ (2, LLt ATFloat) total,
114+ Prim (UN "prim__lteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (<=))
115+ (2, LLe ATFloat) total,
116+ Prim (UN "prim__gtFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>))
117+ (2, LGt ATFloat) total,
118+ Prim (UN "prim__gteFloat") (ty [(AType ATFloat), (AType ATFloat)] (AType (ATInt ITNative))) 2 (bfBin (>=))
119+ (2, LGe ATFloat) total,
119120 Prim (UN "prim__concat") (ty [StrType, StrType] StrType) 2 (sBin (++))
120121 (2, LStrConcat) total,
121− Prim (UN "prim__eqString") (ty [StrType, StrType] IType) 2 (bsBin (==))
122+ Prim (UN "prim__eqString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (==))
122123 (2, LStrEq) total,
123− Prim (UN "prim__ltString") (ty [StrType, StrType] IType) 2 (bsBin (<))
124+ Prim (UN "prim__ltString") (ty [StrType, StrType] (AType (ATInt ITNative))) 2 (bsBin (<))
124125 (2, LStrLt) total,
125− Prim (UN "prim_lenString") (ty [StrType] IType) 1 (p_strLen)
126+ Prim (UN "prim_lenString") (ty [StrType] (AType (ATInt ITNative))) 1 (p_strLen)
126127 (1, LStrLen) total,
127128 -- Conversions
128− Prim (UN "prim__charToInt") (ty [ChType] IType) 1 (c_charToInt)
129+ Prim (UN "prim__charToInt") (ty [ChType] (AType (ATInt ITNative))) 1 (c_charToInt)
129130 (1, LChInt ITNative) total,
130− Prim (UN "prim__intToChar") (ty [IType] ChType) 1 (c_intToChar)
131+ Prim (UN "prim__intToChar") (ty [(AType (ATInt ITNative))] ChType) 1 (c_intToChar)
131132 (1, LIntCh ITNative) total,
132− Prim (UN "prim__strToFloat") (ty [StrType] FlType) 1 (c_strToFloat)
133+ Prim (UN "prim__strToFloat") (ty [StrType] (AType ATFloat)) 1 (c_strToFloat)
133134 (1, LStrFloat) total,
134− Prim (UN "prim__floatToStr") (ty [FlType] StrType) 1 (c_floatToStr)
135+ Prim (UN "prim__floatToStr") (ty [(AType ATFloat)] StrType) 1 (c_floatToStr)
135136 (1, LFloatStr) total,
136137
137− Prim (UN "prim__floatExp") (ty [FlType] FlType) 1 (p_floatExp)
138− (1, LFExp) total,
139− Prim (UN "prim__floatLog") (ty [FlType] FlType) 1 (p_floatLog)
138+ Prim (UN "prim__floatExp") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatExp)
139+ (1, LFExp) total,
140+ Prim (UN "prim__floatLog") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatLog)
140141 (1, LFLog) total,
141− Prim (UN "prim__floatSin") (ty [FlType] FlType) 1 (p_floatSin)
142+ Prim (UN "prim__floatSin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSin)
142143 (1, LFSin) total,
143− Prim (UN "prim__floatCos") (ty [FlType] FlType) 1 (p_floatCos)
144+ Prim (UN "prim__floatCos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCos)
144145 (1, LFCos) total,
145− Prim (UN "prim__floatTan") (ty [FlType] FlType) 1 (p_floatTan)
146+ Prim (UN "prim__floatTan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatTan)
146147 (1, LFTan) total,
147− Prim (UN "prim__floatASin") (ty [FlType] FlType) 1 (p_floatASin)
148+ Prim (UN "prim__floatASin") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatASin)
148149 (1, LFASin) total,
149− Prim (UN "prim__floatACos") (ty [FlType] FlType) 1 (p_floatACos)
150+ Prim (UN "prim__floatACos") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatACos)
150151 (1, LFACos) total,
151− Prim (UN "prim__floatATan") (ty [FlType] FlType) 1 (p_floatATan)
152+ Prim (UN "prim__floatATan") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatATan)
152153 (1, LFATan) total,
153− Prim (UN "prim__floatSqrt") (ty [FlType] FlType) 1 (p_floatSqrt)
154+ Prim (UN "prim__floatSqrt") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatSqrt)
154155 (1, LFSqrt) total,
155− Prim (UN "prim__floatFloor") (ty [FlType] FlType) 1 (p_floatFloor)
156+ Prim (UN "prim__floatFloor") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatFloor)
156157 (1, LFFloor) total,
157− Prim (UN "prim__floatCeil") (ty [FlType] FlType) 1 (p_floatCeil)
158+ Prim (UN "prim__floatCeil") (ty [(AType ATFloat)] (AType ATFloat)) 1 (p_floatCeil)
158159 (1, LFCeil) total,
159160
160161 Prim (UN "prim__strHead") (ty [StrType] ChType) 1 (p_strHead)
@@ -163,7 +164,7 @@ primitives =
163164 (1, LStrTail) partial,
164165 Prim (UN "prim__strCons") (ty [ChType, StrType] StrType) 2 (p_strCons)
165166 (2, LStrCons) total,
166− Prim (UN "prim__strIndex") (ty [StrType, IType] ChType) 2 (p_strIndex)
167+ Prim (UN "prim__strIndex") (ty [StrType, (AType (ATInt ITNative))] ChType) 2 (p_strIndex)
167168 (2, LStrIndex) partial,
168169 Prim (UN "prim__strRev") (ty [StrType] StrType) 1 (p_strRev)
169170 (1, LStrRev) total,
@@ -174,22 +175,23 @@ primitives =
174175 -- Streams
175176 Prim (UN "prim__stdin") (ty [] PtrType) 0 (p_cantreduce)
176177 (0, LStdIn) partial
177− ] ++ concatMap intOps [IT8, IT16, IT32, IT64, ITBig, ITNative]
178+ ] ++ concatMap intOps [ITFixed IT8, ITFixed IT16, ITFixed IT32, ITFixed IT64, ITBig, ITNative]
179+ ++ concatMap vecOps [ITVec IT8 16, ITVec IT16 8, ITVec IT32 4, ITVec IT64 2]
178180
179181intOps :: IntTy -> [Prim]
180182intOps ity =
181− [ iCmp ity "lt" (bCmp ity (<)) LLt total
182− , iCmp ity "lte" (bCmp ity (<=)) LLe total
183− , iCmp ity "eq" (bCmp ity (==)) LEq total
184− , iCmp ity "gte" (bCmp ity (>=)) LGe total
185− , iCmp ity "gt" (bCmp ity (>)) LGt total
186− , iBinOp ity "add" (bitBin ity (+)) LPlus total
187− , iBinOp ity "sub" (bitBin ity (-)) LMinus total
188− , iBinOp ity "mul" (bitBin ity (*)) LTimes total
183+ [ iCmp ity "lt" (bCmp ity (<)) (LLt . ATInt) total
184+ , iCmp ity "lte" (bCmp ity (<=)) (LLe . ATInt) total
185+ , iCmp ity "eq" (bCmp ity (==)) (LEq . ATInt) total
186+ , iCmp ity "gte" (bCmp ity (>=)) (LGe . ATInt) total
187+ , iCmp ity "gt" (bCmp ity (>)) (LGt . ATInt) total
188+ , iBinOp ity "add" (bitBin ity (+)) (LPlus . ATInt) total
189+ , iBinOp ity "sub" (bitBin ity (-)) (LMinus . ATInt) total
190+ , iBinOp ity "mul" (bitBin ity (*)) (LTimes . ATInt) total
189191 , iBinOp ity "udiv" (bitBin ity div) LUDiv partial
190− , iBinOp ity "sdiv" (bsdiv ity) LSDiv partial
192+ , iBinOp ity "sdiv" (bsdiv ity) (LSDiv . ATInt) partial
191193 , iBinOp ity "urem" (bitBin ity rem) LURem partial
192− , iBinOp ity "srem" (bsrem ity) LSRem partial
194+ , iBinOp ity "srem" (bsrem ity) (LSRem . ATInt) partial
193195 , iBinOp ity "shl" (bitBin ity (\x y -> shiftL x (fromIntegral y))) LSHL total
194196 , iBinOp ity "lshr" (bitBin ity (\x y -> shiftR x (fromIntegral y))) LLSHR total
195197 , iBinOp ity "ashr" (bashr ity) LASHR total
@@ -197,30 +199,57 @@ intOps ity =
197199 , iBinOp ity "or" (bitBin ity (.|.)) LOr total
198200 , iBinOp ity "xor" (bitBin ity (xor)) LXOr total
199201 , iUnOp ity "compl" (bUn ity complement) LCompl total
200− , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [intTyToConst ity] StrType) 1 intToStr
202+ , Prim (UN $ "prim__toStr" ++ intTyName ity) (ty [AType . ATInt $ ity] StrType) 1 intToStr
201203 (1, LIntStr ity) total
202− , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (intTyToConst ity)) 1 (strToInt ity)
204+ , Prim (UN $ "prim__fromStr" ++ intTyName ity) (ty [StrType] (AType . ATInt $ ity)) 1 (strToInt ity)
203205 (1, LStrInt ity) total
204− , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [intTyToConst ity] FlType) 1 intToFloat
206+ , Prim (UN $ "prim__toFloat" ++ intTyName ity) (ty [AType . ATInt $ ity] (AType ATFloat)) 1 intToFloat
205207 (1, LIntFloat ity) total
206− , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [FlType] (intTyToConst ity)) 1 (floatToInt ity)
208+ , Prim (UN $ "prim__fromFloat" ++ intTyName ity) (ty [AType ATFloat] (AType . ATInt $ ity)) 1 (floatToInt ity)
207209 (1, LFloatInt ity) total
208210 ]
209211
212+vecOps ity@(ITVec elem count) =
213+ [ Prim (UN $ "prim__mk" ++ intTyName ity)
214+ (ty (replicate count . AType . ATInt . ITFixed $ elem) (AType . ATInt $ ity))
215+ count (mkVecCon elem count) (count, LMkVec elem count) total
216+ ]
217+
218+mkVecCon ity count args = if length ints == count
219+ then Just (mkVec ity count ints)
220+ else error $ "Got: " ++ show args ++ " when expecting " ++ show count ++ " x " ++ show ity
221+ where
222+ ints = getInt args
223+ mkVec :: NativeTy -> Int -> [Integer] -> Const
224+ mkVec IT8 len values = B8V $ V.generate len (fromInteger . (values !!))
225+ mkVec IT16 len values = B16V $ V.generate len (fromInteger . (values !!))
226+ mkVec IT32 len values = B32V $ V.generate len (fromInteger . (values !!))
227+ mkVec IT64 len values = B64V $ V.generate len (fromInteger . (values !!))
228+
210229intTyName :: IntTy -> String
211230intTyName ITNative = "Int"
212231intTyName ITBig = "BigInt"
213−intTyName sized = "B" ++ show (intTyWidth sized)
232+intTyName (ITFixed sized) = "B" ++ show (nativeTyWidth sized)
233+intTyName (ITVec ity count) = "B" ++ show (nativeTyWidth ity) ++ "x" ++ show count
214234
215235iCmp, iBinOp, iUnOp :: IntTy -> String -> ([Const] -> Maybe Const) -> (IntTy -> PrimFn) -> Totality -> Prim
216−iCmp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) IType) 2 impl (2, irop ity) totality
217−iBinOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty (replicate 2 $ intTyToConst ity) (intTyToConst ity)) 2 impl (2, irop ity) totality
218−iUnOp ity op impl irop totality = Prim (UN $ "prim__" ++ op ++ intTyName ity) (ty [intTyToConst ity] (intTyToConst ity)) 1 impl (1, irop ity) totality
236+iCmp ity op impl irop totality
237+ = Prim (UN $ "prim__" ++ op ++ intTyName ity)
238+ (ty (replicate 2 . AType . ATInt $ ity) (AType (ATInt ITNative)))
239+ 2 impl (2, irop ity) totality
240+iBinOp ity op impl irop totality
241+ = Prim (UN $ "prim__" ++ op ++ intTyName ity)
242+ (ty (replicate 2 . AType . ATInt $ ity) (AType . ATInt $ ity))
243+ 2 impl (2, irop ity) totality
244+iUnOp ity op impl irop totality
245+ = Prim (UN $ "prim__" ++ op ++ intTyName ity)
246+ (ty [AType . ATInt $ ity] (AType . ATInt $ ity))
247+ 1 impl (1, irop ity) totality
219248
220249iCoerce :: IntTy -> IntTy -> String -> (IntTy -> IntTy -> [Const] -> Maybe Const) -> (IntTy -> IntTy -> PrimFn) -> Prim
221250iCoerce from to op impl irop =
222251 Prim (UN $ "prim__" ++ op ++ intTyName from ++ "_" ++ intTyName to)
223− (ty [intTyToConst from] (intTyToConst to)) 1 (impl from to) (1, irop from to) total
252+ (ty [AType . ATInt $ from] (AType . ATInt $ to)) 1 (impl from to) (1, irop from to) total
224253
225254iUn :: (Int -> Int) -> [Const] -> Maybe Const
226255iUn op [I x] = Just $ I (op x)
@@ -269,81 +298,81 @@ sBin op [Str x, Str y] = Just $ Str (op x y)
269298sBin _ _ = Nothing
270299
271300bsrem :: IntTy -> [Const] -> Maybe Const
272−bsrem IT8 [B8 x, B8 y]
301+bsrem (ITFixed IT8) [B8 x, B8 y]
273302 = Just $ B8 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int8))
274−bsrem IT16 [B16 x, B16 y]
303+bsrem (ITFixed IT16) [B16 x, B16 y]
275304 = Just $ B16 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int16))
276−bsrem IT32 [B32 x, B32 y]
305+bsrem (ITFixed IT32) [B32 x, B32 y]
277306 = Just $ B32 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int32))
278−bsrem IT64 [B64 x, B64 y]
307+bsrem (ITFixed IT64) [B64 x, B64 y]
279308 = Just $ B64 (fromIntegral (fromIntegral x `rem` fromIntegral y :: Int64))
280309bsrem ITNative [I x, I y] = Just $ I (x `rem` y)
281310bsrem _ _ = Nothing
282311
283312bsdiv :: IntTy -> [Const] -> Maybe Const
284−bsdiv IT8 [B8 x, B8 y]
313+bsdiv (ITFixed IT8) [B8 x, B8 y]
285314 = Just $ B8 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int8))
286−bsdiv IT16 [B16 x, B16 y]
315+bsdiv (ITFixed IT16) [B16 x, B16 y]
287316 = Just $ B16 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int16))
288−bsdiv IT32 [B32 x, B32 y]
317+bsdiv (ITFixed IT32) [B32 x, B32 y]
289318 = Just $ B32 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int32))
290−bsdiv IT64 [B64 x, B64 y]
319+bsdiv (ITFixed IT64) [B64 x, B64 y]
291320 = Just $ B64 (fromIntegral (fromIntegral x `div` fromIntegral y :: Int64))
292321bsdiv ITNative [I x, I y] = Just $ I (x `div` y)
293322bsdiv _ _ = Nothing
294323
295324bashr :: IntTy -> [Const] -> Maybe Const
296−bashr IT8 [B8 x, B8 y]
325+bashr (ITFixed IT8) [B8 x, B8 y]
297326 = Just $ B8 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int8))
298−bashr IT16 [B16 x, B16 y]
327+bashr (ITFixed IT16) [B16 x, B16 y]
299328 = Just $ B16 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int16))
300−bashr IT32 [B32 x, B32 y]
329+bashr (ITFixed IT32) [B32 x, B32 y]
301330 = Just $ B32 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int32))
302−bashr IT64 [B64 x, B64 y]
331+bashr (ITFixed IT64) [B64 x, B64 y]
303332 = Just $ B64 (fromIntegral (fromIntegral x `shiftR` fromIntegral y :: Int64))
304333bashr ITNative [I x, I y] = Just $ I (x `shiftR` y)
305334bashr _ _ = Nothing
306335
307336bUn :: IntTy -> (forall a. Bits a => a -> a) -> [Const] -> Maybe Const
308−bUn IT8 op [B8 x] = Just $ B8 (op x)
309−bUn IT16 op [B16 x] = Just $ B16 (op x)
310−bUn IT32 op [B32 x] = Just $ B32 (op x)
311−bUn IT64 op [B64 x] = Just $ B64 (op x)
337+bUn (ITFixed IT8) op [B8 x] = Just $ B8 (op x)
338+bUn (ITFixed IT16) op [B16 x] = Just $ B16 (op x)
339+bUn (ITFixed IT32) op [B32 x] = Just $ B32 (op x)
340+bUn (ITFixed IT64) op [B64 x] = Just $ B64 (op x)
312341bUn ITBig op [BI x] = Just $ BI (op x)
313342bUn ITNative op [I x] = Just $ I (op x)
314343bUn _ _ _ = Nothing
315344
316345bitBin :: IntTy -> (forall a. (Bits a, Integral a) => a -> a -> a) -> [Const] -> Maybe Const
317−bitBin IT8 op [B8 x, B8 y] = Just $ B8 (op x y)
318−bitBin IT16 op [B16 x, B16 y] = Just $ B16 (op x y)
319−bitBin IT32 op [B32 x, B32 y] = Just $ B32 (op x y)
320−bitBin IT64 op [B64 x, B64 y] = Just $ B64 (op x y)
346+bitBin (ITFixed IT8) op [B8 x, B8 y] = Just $ B8 (op x y)
347+bitBin (ITFixed IT16) op [B16 x, B16 y] = Just $ B16 (op x y)
348+bitBin (ITFixed IT32) op [B32 x, B32 y] = Just $ B32 (op x y)
349+bitBin (ITFixed IT64) op [B64 x, B64 y] = Just $ B64 (op x y)
321350bitBin ITBig op [BI x, BI y] = Just $ BI (op x y)
322351bitBin ITNative op [I x, I y] = Just $ I (op x y)
323352bitBin _ _ _ = Nothing
324353
325354bCmp :: IntTy -> (forall a. Ord a => a -> a -> Bool) -> [Const] -> Maybe Const
326−bCmp IT8 op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
327−bCmp IT16 op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
328−bCmp IT32 op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
329−bCmp IT64 op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
355+bCmp (ITFixed IT8) op [B8 x, B8 y] = Just $ I (if (op x y) then 1 else 0)
356+bCmp (ITFixed IT16) op [B16 x, B16 y] = Just $ I (if (op x y) then 1 else 0)
357+bCmp (ITFixed IT32) op [B32 x, B32 y] = Just $ I (if (op x y) then 1 else 0)
358+bCmp (ITFixed IT64) op [B64 x, B64 y] = Just $ I (if (op x y) then 1 else 0)
330359bCmp ITBig op [BI x, BI y] = Just $ I (if (op x y) then 1 else 0)
331360bCmp ITNative op [I x, I y] = Just $ I (if (op x y) then 1 else 0)
332361bCmp _ _ _ = Nothing
333362
334363toInt :: Integral a => IntTy -> a -> Const
335−toInt IT8 x = B8 (fromIntegral x)
336−toInt IT16 x = B16 (fromIntegral x)
337−toInt IT32 x = B32 (fromIntegral x)
338−toInt IT64 x = B64 (fromIntegral x)
364+toInt (ITFixed IT8) x = B8 (fromIntegral x)
365+toInt (ITFixed IT16) x = B16 (fromIntegral x)
366+toInt (ITFixed IT32) x = B32 (fromIntegral x)
367+toInt (ITFixed IT64) x = B64 (fromIntegral x)
339368toInt ITBig x = BI (fromIntegral x)
340369toInt ITNative x = I (fromIntegral x)
341370
342371intToInt :: IntTy -> IntTy -> [Const] -> Maybe Const
343−intToInt IT8 out [B8 x] = Just $ toInt out x
344−intToInt IT16 out [B16 x] = Just $ toInt out x
345−intToInt IT32 out [B32 x] = Just $ toInt out x
346−intToInt IT64 out [B64 x] = Just $ toInt out x
372+intToInt (ITFixed IT8) out [B8 x] = Just $ toInt out x
373+intToInt (ITFixed IT16) out [B16 x] = Just $ toInt out x
374+intToInt (ITFixed IT32) out [B32 x] = Just $ toInt out x
375+intToInt (ITFixed IT64) out [B64 x] = Just $ toInt out x
347376intToInt ITBig out [BI x] = Just $ toInt out x
348377intToInt ITNative out [I x] = Just $ toInt out x
349378intToInt _ _ _ = Nothing
@@ -356,10 +385,10 @@ zext from to val
356385zext _ _ _ = Nothing
357386
358387sext :: IntTy -> IntTy -> [Const] -> Maybe Const
359−sext IT8 out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
360−sext IT16 out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
361−sext IT32 out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
362−sext IT64 out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
388+sext (ITFixed IT8) out [B8 x] = Just $ toInt out (fromIntegral x :: Int8)
389+sext (ITFixed IT16) out [B16 x] = Just $ toInt out (fromIntegral x :: Int16)
390+sext (ITFixed IT32) out [B32 x] = Just $ toInt out (fromIntegral x :: Int32)
391+sext (ITFixed IT64) out [B64 x] = Just $ toInt out (fromIntegral x :: Int64)
363392sext ITBig _ _ = Nothing
364393sext from to val = intToInt from to val
365394
@@ -369,19 +398,19 @@ trunc _ ITBig _ = Nothing
369398trunc from to val | intTyWidth from > intTyWidth to = intToInt from to val
370399trunc _ _ _ = Nothing
371400
372−getInt :: [Const] -> Maybe Integer
373−getInt [B8 x] = Just . toInteger $ x
374−getInt [B16 x] = Just . toInteger $ x
375−getInt [B32 x] = Just . toInteger $ x
376−getInt [B64 x] = Just . toInteger $ x
377−getInt [I x] = Just . toInteger $ x
378−getInt [BI x] = Just x
379−getInt _ = Nothing
380−
381401intToStr :: [Const] -> Maybe Const
382−intToStr val | Just i <- getInt val = Just $ Str (show i)
402+intToStr val | [i] <- getInt val = Just $ Str (show i)
383403intToStr _ = Nothing
384404
405+getInt :: [Const] -> [Integer]
406+getInt (B8 x : xs) = toInteger x : getInt xs
407+getInt (B16 x : xs) = toInteger x : getInt xs
408+getInt (B32 x : xs) = toInteger x : getInt xs
409+getInt (B64 x : xs) = toInteger x : getInt xs
410+getInt (I x : xs) = toInteger x : getInt xs
411+getInt (BI x : xs) = x : getInt xs
412+getInt _ = []
413+
385414strToInt :: IntTy -> [Const] -> Maybe Const
386415strToInt ity [Str x] = case reads x of
387416 [(n,"")] -> Just $ toInt ity (n :: Integer)
@@ -389,7 +418,7 @@ strToInt ity [Str x] = case reads x of
389418strToInt _ _ = Nothing
390419
391420intToFloat :: [Const] -> Maybe Const
392−intToFloat val | Just i <- getInt val = Just $ Fl (fromIntegral i)
421+intToFloat val | [i] <- getInt val = Just $ Fl (fromIntegral i)
393422intToFloat _ = Nothing
394423
395424floatToInt :: IntTy -> [Const] -> Maybe Const