@@ -47,55 +47,65 @@ codegenLLVM defs file outty = withContext $ \context -> do
4747ierror :: String -> a
4848ierror msg = error $ "INTERNAL ERROR: IRTS.CodegenLLVM: " ++ msg
4949
50−codegen :: String -> [SDecl] -> Module
51−codegen tgt defs =
52− Module "idris" Nothing Nothing
53− ([ TypeDefinition (Name "valTy") (
54− Just $ StructureType False
55− [ IntegerType 32
56− , ArrayType 0 (PointerType valueType (AddrSpace 0))
57− ])
58− , TypeDefinition (Name "mpz") (
59− Just $ StructureType False
60− [ IntegerType 32
61− , IntegerType 32
62− , PointerType intPtr (AddrSpace 0)
63− ])
64− , GlobalDefinition $ globalVariableDefaults
65− { G.name = Name "__idris_intFmtStr"
66− , G.linkage = L.Internal
67− , G.isConstant = True
68− , G.hasUnnamedAddr = True
69− , G.type' = ArrayType 5 (IntegerType 8)
70− , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
71− }
72− , rtsFun "intStr" ptrI8 [IntegerType 64]
73− [ BasicBlock (UnName 0)
74− [ UnName 1 := simpleCall "GC_malloc_atomic"
75− [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)]
76− , UnName 2 := simpleCall "snprintf"
77− [ LocalReference (UnName 1)
78− , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)
79− , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
80− , LocalReference (UnName 0)
81− ]
82− ]
83− (Do $ Ret (Just (LocalReference (UnName 1))) [])
84− ]
85− , exfun "llvm.trap" VoidType [] False
86− , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
87− , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
88− , exfun "strlen" intPtr [ptrI8] False
89− , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
90− , exfun "GC_malloc" ptrI8 [intPtr] False
91− , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
92− , exfun "__gmpz_init" VoidType [pmpz] False
93− ]
94− ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
95− ++ globals
96− ++ gendefs)
50+mainDef :: Global
51+mainDef =
52+ functionDefaults
53+ { G.returnType = IntegerType 32
54+ , G.parameters =
55+ ([ Parameter (IntegerType 32) (Name "argc") []
56+ , Parameter (PointerType (PointerType (IntegerType 8) (AddrSpace 0)) (AddrSpace 0)) (Name "argv") []
57+ ], False)
58+ , G.name = Name "main"
59+ , G.basicBlocks =
60+ [ BasicBlock (UnName 0)
61+ [ UnName 1 := idrCall "{runMain0}" [] ]
62+ (Do $ Ret (Just (ConstantOperand (C.Int 32 0))) [])
63+ ]}
64+
65+initDefs :: String -> [Definition]
66+initDefs tgt =
67+ [ TypeDefinition (Name "valTy")
68+ (Just $ StructureType False
69+ [ IntegerType 32
70+ , ArrayType 0 (PointerType valueType (AddrSpace 0))
71+ ])
72+ , TypeDefinition (Name "mpz")
73+ (Just $ StructureType False
74+ [ IntegerType 32
75+ , IntegerType 32
76+ , PointerType intPtr (AddrSpace 0)
77+ ])
78+ , GlobalDefinition $ globalVariableDefaults
79+ { G.name = Name "__idris_intFmtStr"
80+ , G.linkage = L.Internal
81+ , G.isConstant = True
82+ , G.hasUnnamedAddr = True
83+ , G.type' = ArrayType 5 (IntegerType 8)
84+ , G.initializer = Just $ C.Array (IntegerType 8) (map (C.Int 8 . fromIntegral . fromEnum) "%lld" ++ [C.Int 8 0])
85+ }
86+ , rtsFun "intStr" ptrI8 [IntegerType 64]
87+ [ BasicBlock (UnName 0)
88+ [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)]
89+ , UnName 2 := simpleCall "snprintf"
90+ [ LocalReference (UnName 1)
91+ , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 12)
92+ , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
93+ , LocalReference (UnName 0)
94+ ]
95+ ]
96+ (Do $ Ret (Just (LocalReference (UnName 1))) [])
97+ ]
98+ , exfun "llvm.trap" VoidType [] False
99+ , exfun "snprintf" (IntegerType 32) [ptrI8, intPtr, ptrI8] True
100+ , exfun "strcmp" (IntegerType 32) [ptrI8, ptrI8] False
101+ , exfun "strlen" intPtr [ptrI8] False
102+ , exfun "memcpy" ptrI8 [ptrI8, ptrI8, intPtr] False
103+ , exfun "GC_malloc" ptrI8 [intPtr] False
104+ , exfun "GC_malloc_atomic" ptrI8 [intPtr] False
105+ , exfun "__gmpz_init" VoidType [pmpz] False
106+ , GlobalDefinition mainDef
107+ ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
97108 where
98− ((gendefs, globals), _) = (runState . runWriterT) (mapM cgDef defs) 0
99109 intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
100110 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
101111 pmpz = PointerType mpzTy (AddrSpace 0)
@@ -120,6 +130,11 @@ codegen tgt defs =
120130 , G.parameters = (flip map argtys $ \ty -> Parameter ty (UnName 0) [], vari)
121131 }
122132
133+codegen :: String -> [SDecl] -> Module
134+codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
135+ where
136+ ((gendefs, globals), _) = (runState . runWriterT) (mapM cgDef defs) 0
137+
123138valueType :: Type
124139valueType = NamedTypeReference (Name "valTy")
125140
@@ -716,7 +731,7 @@ cgOp (LIntStr ity) [x] = do
716731 x'' <- if ity == ITNative || intTyWidth ity < 64
717732 then inst $ SExt x' (IntegerType 64) []
718733 else return x'
719− box FString =<< inst (rtsCall "intStr" [x''])
734+ box FString =<< inst (idrCall "__idris_intStr" [x''])
720735
721736cgOp LStrConcat [x,y] = cgStrCat x y
722737cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
@@ -771,12 +786,12 @@ simpleCall name args =
771786 , metadata = []
772787 }
773788
774−rtsCall :: String -> [Operand] -> Instruction
775−rtsCall name args =
789+idrCall :: String -> [Operand] -> Instruction
790+idrCall name args =
776791 Call { isTailCall = False
777792 , callingConvention = CC.Fast
778793 , returnAttributes = []
779− , function = Right . ConstantOperand . C.GlobalReference . Name $ "__idris_" ++ name
794+ , function = Right . ConstantOperand . C.GlobalReference . Name $ name
780795 , arguments = map (\x -> (x, [])) args
781796 , functionAttributes = []
782797 , metadata = []