git.iko.soy/Idris-dev
on master help sign in
Fix comparison return values and implement Integer truncation
25d1e1fBenjamin Saunders
llvm/defs.c+25
compare with master
unifiedsplit
@@ -1,5 +1,30 @@
1#include <stdio.h>
1#include <stdio.h>
2+#include <gmp.h>
2
3
3void putStr(const char *str) {
4void putStr(const char *str) {
4 fputs(str, stdout);
5 fputs(str, stdout);
5}
6}
7+
8+void mpz_set_ull(mpz_t n, unsigned long long ull)
9+{
10+ mpz_set_ui(n, (unsigned int)(ull >> 32)); /* n = (unsigned int)(ull >> 32) */
11+ mpz_mul_2exp(n, n, 32); /* n <<= 32 */
12+ mpz_add_ui(n, n, (unsigned int)ull); /* n += (unsigned int)ull */
13+}
14+
15+unsigned long long mpz_get_ull(mpz_t n)
16+{
17+ unsigned int lo, hi;
18+ mpz_t tmp;
19+
20+ mpz_init( tmp );
21+ mpz_mod_2exp( tmp, n, 64 ); /* tmp = (lower 64 bits of n) */
22+
23+ lo = mpz_get_ui( tmp ); /* lo = tmp & 0xffffffff */
24+ mpz_div_2exp( tmp, tmp, 32 ); /* tmp >>= 32 */
25+ hi = mpz_get_ui( tmp ); /* hi = tmp & 0xffffffff */
26+
27+ mpz_clear( tmp );
28+
29+ return (((unsigned long long)hi) << 32) + lo;
30+}
src/IRTS/CodegenLLVM.hs+21−8
@@ -52,6 +52,10 @@ codegenLLVM defs file outty = withContext $ \context -> do
52 Right _ -> return ()
52 Right _ -> return ()
53 Left msg -> ierror msg
53 Left msg -> ierror msg
54
54
55+itWidth :: IntTy -> Word32
56+itWidth ITNative = 32
57+itWidth x = fromIntegral $ intTyWidth x
58+
55outputModule :: FilePath -> OutputType -> M.Module -> IO ()
59outputModule :: FilePath -> OutputType -> M.Module -> IO ()
56outputModule file Raw m = M.writeBitcodeToFile file m
60outputModule file Raw m = M.writeBitcodeToFile file m
57outputModule file Object m = withTmpFile $ \bc -> do
61outputModule file Object m = withTmpFile $ \bc -> do
@@ -135,6 +139,7 @@ initDefs tgt =
135 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
139 , exfun "__gmpz_init_set_str" (IntegerType 32) [pmpz, ptrI8, IntegerType 32] False
136 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
140 , exfun "__gmpz_get_str" ptrI8 [ptrI8, IntegerType 32, pmpz] False
137 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
141 , exfun "__gmpz_cmp" (IntegerType 32) [pmpz, pmpz] False
142+ , exfun "mpz_get_ull" (IntegerType 64) [pmpz] False
138 , GlobalDefinition mainDef
143 , GlobalDefinition mainDef
139 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
144 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
140 where
145 where
@@ -318,15 +323,15 @@ alloc ty = do
318sizeOf :: Type -> Codegen Operand
323sizeOf :: Type -> Codegen Operand
319sizeOf ty = ConstantOperand . C.PtrToInt
324sizeOf ty = ConstantOperand . C.PtrToInt
320 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
325 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
321− . IntegerType . fromIntegral <$> wordSize
326+ . IntegerType . fromIntegral <$> getWordSize
322
327
323tgtWordSize :: String -> Integer
328tgtWordSize :: String -> Integer
324tgtWordSize tgt = case tgt of
329tgtWordSize tgt = case tgt of
325 "x86_64" -> 64
330 "x86_64" -> 64
326 "i386" -> 32
331 "i386" -> 32
327
332
328−wordSize :: Codegen Integer
333+getWordSize :: Codegen Integer
329−wordSize = tgtWordSize <$> asks target
334+getWordSize = tgtWordSize <$> asks target
330
335
331cgExpr :: SExp -> Codegen (Maybe Operand)
336cgExpr :: SExp -> Codegen (Maybe Operand)
332cgExpr (SV v) = var v
337cgExpr (SV v) = var v
@@ -706,7 +711,7 @@ ffunDecl name rty argtys =
706ftyToTy :: FType -> Type
711ftyToTy :: FType -> Type
707ftyToTy (FInt ITNative) = IntegerType 32
712ftyToTy (FInt ITNative) = IntegerType 32
708ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
713ftyToTy (FInt ITBig) = PointerType mpzTy (AddrSpace 0)
709−ftyToTy (FInt ty) = IntegerType (fromIntegral (intTyWidth ty))
714+ftyToTy (FInt ty) = IntegerType (fromIntegral (itWidth ty))
710ftyToTy FChar = IntegerType 32
715ftyToTy FChar = IntegerType 32
711ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
716ftyToTy FString = PointerType (IntegerType 8) (AddrSpace 0)
712ftyToTy FUnit = VoidType
717ftyToTy FUnit = VoidType
@@ -715,6 +720,14 @@ ftyToTy FDouble = FloatingPointType 64 IEEE
715ftyToTy FAny = valueType
720ftyToTy FAny = valueType
716
721
717cgOp :: PrimFn -> [Operand] -> Codegen Operand
722cgOp :: PrimFn -> [Operand] -> Codegen Operand
723+cgOp (LTrunc ITBig ity) [x] = do
724+ nx <- unbox (FInt ITBig) x
725+ val <- inst $ simpleCall "mpz_get_ull" [nx]
726+ v <- case ity of
727+ IT64 -> return val
728+ _ -> inst $ Trunc val (IntegerType . fromIntegral $ itWidth ity) []
729+ box (FInt ity) v
730+
718cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
731cgOp (LLt ITBig) [x,y] = mpzCmp IPred.SLT x y
719cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
732cgOp (LLe ITBig) [x,y] = mpzCmp IPred.SLE x y
720cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
733cgOp (LEq ITBig) [x,y] = mpzCmp IPred.EQ x y
@@ -763,7 +776,7 @@ cgOp (LIntStr ITBig) [x] = do
763 box FString ustr
776 box FString ustr
764cgOp (LIntStr ity) [x] = do
777cgOp (LIntStr ity) [x] = do
765 x' <- unbox (FInt ity) x
778 x' <- unbox (FInt ity) x
766− x'' <- if ity == ITNative || intTyWidth ity < 64
779+ x'' <- if itWidth ity < 64
767 then inst $ SExt x' (IntegerType 64) []
780 then inst $ SExt x' (IntegerType 64) []
768 else return x'
781 else return x'
769 box FString =<< inst (idrCall "__idris_intStr" [x''])
782 box FString =<< inst (idrCall "__idris_intStr" [x''])
@@ -779,7 +792,7 @@ cgStrCat x y = do
779 xlen <- inst $ simpleCall "strlen" [x']
792 xlen <- inst $ simpleCall "strlen" [x']
780 ylen <- inst $ simpleCall "strlen" [y']
793 ylen <- inst $ simpleCall "strlen" [y']
781 zlen <- inst $ Add False True xlen ylen []
794 zlen <- inst $ Add False True xlen ylen []
782− ws <- fromIntegral <$> wordSize
795+ ws <- fromIntegral <$> getWordSize
783 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
796 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
784 mem <- allocAtomic total
797 mem <- allocAtomic total
785 inst $ simpleCall "memcpy" [mem, x', xlen]
798 inst $ simpleCall "memcpy" [mem, x', xlen]
@@ -806,8 +819,8 @@ iCmp ity pred x y = do
806 nx <- unbox (FInt ity) x
819 nx <- unbox (FInt ity) x
807 ny <- unbox (FInt ity) y
820 ny <- unbox (FInt ity) y
808 nr <- inst $ ICmp pred nx ny []
821 nr <- inst $ ICmp pred nx ny []
809− nr' <- inst $ ZExt nr (IntegerType . fromIntegral $ intTyWidth ity) []
822+ nr' <- inst $ ZExt nr (IntegerType 32) []
810− box (FInt ity) nr'
823+ box (FInt IT32) nr'
811
824
812mpzBin :: String -> Operand -> Operand -> Codegen Operand
825mpzBin :: String -> Operand -> Operand -> Codegen Operand
813mpzBin name x y = do
826mpzBin name x y = do