@@ -20,7 +20,7 @@ import LLVM.General.Target ( TargetMachine
2020 )
2121import LLVM.General.AST.DataLayout
2222import qualified LLVM.General.PassManager as PM
23−import qualified LLVM.General.Module as M
23+import qualified LLVM.General.Module as MO
2424import qualified LLVM.General.AST.IntegerPredicate as IPred
2525import qualified LLVM.General.AST.Linkage as L
2626import qualified LLVM.General.AST.Visibility as V
@@ -36,9 +36,9 @@ import qualified LLVM.General.CodeGenOpt as CGO
3636import Data.List
3737import Data.Maybe
3838import Data.Word
39−import Data.Set (Set)
40−import qualified Data.Set as S
39+import Data.Map (Map)
4140import qualified Data.Map as M
41+import qualified Data.Set as S
4242import qualified Data.Vector.Unboxed as V
4343import Control.Applicative
4444import Control.Monad.RWS
@@ -70,7 +70,7 @@ codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
7070 withTargetMachine target triple cpu S.empty options R.Default CM.Default CGO.Default $ \tm ->
7171 do layout <- getTargetMachineDataLayout tm
7272 let ast = codegen (Target triple layout) (map snd defs)
73− result <- runErrorT . M.withModuleFromAST context ast $ \m ->
73+ result <- runErrorT . MO.withModuleFromAST context ast $ \m ->
7474 do let opts = PM.defaultCuratedPassSetSpec
7575 { PM.optLevel = Just optimize
7676 , PM.simplifyLibCalls = Just True
@@ -85,9 +85,9 @@ codegenLLVM defs triple cpu optimize file outty = withContext $ \context -> do
8585failInIO :: ErrorT String IO a -> IO a
8686failInIO = either fail return <=< runErrorT
8787
88−outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
89−outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
90−outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
88+outputModule :: TargetMachine -> FilePath -> OutputType -> MO.Module -> IO ()
89+outputModule _ file Raw m = failInIO $ MO.writeBitcodeToFile file m
90+outputModule tm file Object m = failInIO $ MO.writeObjectToFile tm file m
9191outputModule tm file Executable m = withTmpFile $ \obj -> do
9292 outputModule tm obj Object m
9393 cc <- getCC
@@ -193,6 +193,7 @@ initDefs tgt =
193193 , exfun "__idris_gmpFree" VoidType [ptrI8, intPtr] False
194194 , exfun "__idris_strRev" ptrI8 [ptrI8] False
195195 , exfun "strtoll" (IntegerType 64) [ptrI8, PointerType ptrI8 (AddrSpace 0), IntegerType 32] False
196+ , exfun "putErr" VoidType [ptrI8] False
196197 , exVar (stdinName tgt) ptrI8
197198 , exVar (stdoutName tgt) ptrI8
198199 , exVar (stderrName tgt) ptrI8
@@ -244,7 +245,7 @@ getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks tar
244245codegen :: Target -> [SDecl] -> Module
245246codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) (Just . triple $ tgt) (initDefs tgt ++ globals ++ gendefs)
246247 where
247− (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
248+ (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt initialMGS
248249
249250valueType :: Type
250251valueType = NamedTypeReference (Name "valTy")
@@ -264,24 +265,34 @@ conType nargs = StructureType False
264265 , ArrayType nargs (PointerType valueType (AddrSpace 0))
265266 ]
266267
267−type Modgen = RWS Target [Definition] Word
268+data MGS = MGS { mgsNextGlobalName :: Word
269+ , mgsForeignSyms :: Map String (FType, [FType])
270+ }
271+
272+type Modgen = RWS Target [Definition] MGS
273+
274+initialMGS :: MGS
275+initialMGS = MGS { mgsNextGlobalName = 0
276+ , mgsForeignSyms = M.empty
277+ }
268278
269279cgDef :: SDecl -> Modgen Definition
270280cgDef (SFun name argNames _ expr) = do
271− nextGlobal <- get
281+ nextGlobal <- gets mgsNextGlobalName
282+ existingForeignSyms <- gets mgsForeignSyms
272283 tgt <- ask
273− let (_, CGS { nextGlobalName = nextGlobal' }, (allocas, bbs, globals)) =
284+ let (_, CGS { nextGlobalName = nextGlobal', foreignSyms = foreignSyms' }, (allocas, bbs, globals)) =
274285 runRWS (do r <- cgExpr expr
275286 case r of
276287 Nothing -> terminate $ Unreachable []
277288 Just r' -> terminate $ Ret (Just r') [])
278289 (CGR tgt (show name))
279− (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) S.empty)
290+ (CGS 0 nextGlobal (Name "begin") [] (map (Just . LocalReference . Name . show) argNames) existingForeignSyms)
280291 entryTerm = case bbs of
281292 [] -> Do $ Ret Nothing []
282293 BasicBlock n _ _:_ -> Do $ Br n []
283294 tell globals
284− put nextGlobal'
295+ put (MGS { mgsNextGlobalName = nextGlobal', mgsForeignSyms = foreignSyms' })
285296 return . GlobalDefinition $ functionDefaults
286297 { G.linkage = L.Internal
287298 , G.callingConvention = CC.Fast
@@ -306,7 +317,7 @@ data CGS = CGS { nextName :: Word
306317 , currentBlockName :: Name
307318 , instAccum :: [Named Instruction]
308319 , lexenv :: Env
309− , foreignSyms :: Set String
320+ , foreignSyms :: Map String (FType, [FType])
310321 }
311322
312323data CGR = CGR { target :: Target
@@ -524,10 +535,10 @@ cgExpr (SOp fn args) = do
524535 Just ops -> Just <$> cgOp fn ops
525536 Nothing -> return Nothing
526537cgExpr SNothing = return . Just . ConstantOperand $ nullValue
527−cgExpr (SError msg) = do -- TODO: Print message
538+cgExpr (SError msg) = do
528539 str <- addGlobal' (ArrayType (2 + fromIntegral (length msg)) (IntegerType 8))
529540 (cgConst' (TT.Str (msg ++ "\n")))
530− inst' $ simpleCall "putStr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
541+ inst' $ simpleCall "putErr" [ConstantOperand $ C.GetElementPtr True str [ C.Int 32 0
531542 , C.Int 32 0]]
532543 inst' Call { isTailCall = True
533544 , callingConvention = CC.C
@@ -799,9 +810,11 @@ addGlobal' ty val = do
799810ensureCDecl :: String -> FType -> [FType] -> Codegen Operand
800811ensureCDecl name rty argtys = do
801812 syms <- gets foreignSyms
802− unless (S.member name syms) $
803− do addGlobal (ffunDecl name rty argtys)
804− modify $ \s -> s { foreignSyms = S.insert name (foreignSyms s) }
813+ case M.lookup name syms of
814+ Nothing -> do addGlobal (ffunDecl name rty argtys)
815+ modify $ \s -> s { foreignSyms = M.insert name (rty, argtys) (foreignSyms s) }
816+ Just (rty', argtys') -> unless (rty == rty' && argtys == argtys') . fail $
817+ "Mismatched type declarations for foreign symbol \"" ++ name ++ "\": " ++ show (rty, argtys) ++ " vs " ++ show (rty', argtys')
805818 return $ ConstantOperand (C.GlobalReference (Name name))
806819
807820ffunDecl :: String -> FType -> [FType] -> Global