@@ -13,6 +13,8 @@ import LLVM.General.Context
1313import LLVM.General.Diagnostic
1414import LLVM.General.AST
1515import LLVM.General.AST.AddrSpace
16+import LLVM.General.Target
17+import LLVM.General.AST.DataLayout
1618import qualified LLVM.General.Module as M
1719import qualified LLVM.General.AST.IntegerPredicate as IPred
1820import qualified LLVM.General.AST.Linkage as L
@@ -22,12 +24,16 @@ import qualified LLVM.General.AST.Attribute as A
2224import qualified LLVM.General.AST.Global as G
2325import qualified LLVM.General.AST.Constant as C
2426import qualified LLVM.General.AST.Float as F
27+import qualified LLVM.General.Relocation as R
28+import qualified LLVM.General.CodeModel as CM
29+import qualified LLVM.General.CodeGenOpt as CGO
2530
2631import Data.List
2732import Data.Maybe
2833import Data.Word
2934import Data.Set (Set)
3035import qualified Data.Set as S
36+import qualified Data.Map as M
3137import Control.Applicative
3238import Control.Monad.RWS
3339import Control.Monad.Writer
@@ -42,32 +48,39 @@ import System.Process (rawSystem)
4248import System.Exit (ExitCode(..))
4349import Debug.Trace
4450
45−data Target = Target { arch :: String, os :: String }
51+data Target = Target { triple :: String, dataLayout :: DataLayout }
4652
4753codegenLLVM :: [(TT.Name, SDecl)] ->
4854 FilePath -> -- output file name
4955 OutputType ->
5056 IO ()
5157codegenLLVM defs file outty = withContext $ \context -> do
52− let target = Target { arch = SI.arch, os = SI.os }
53− let ast = codegen target (map snd defs)
54− result <- runErrorT $ M.withModuleFromAST context ast (outputModule file outty)
55− case result of
56− Right _ -> return ()
57− Left msg -> ierror msg
58+ triple <- getDefaultTargetTriple
59+ cpu <- getHostCPUName
60+ features <- getHostCPUFeatures
61+ initializeAllTargets
62+ (target, _) <- failInIO $ lookupTarget Nothing triple
63+ withTargetOptions $ \options ->
64+ withTargetMachine target triple cpu features options R.Default CM.Default CGO.Default $ \tm ->
65+ do layout <- getTargetMachineDataLayout tm
66+ let ast = codegen (Target triple layout) (map snd defs)
67+ result <- runErrorT $ M.withModuleFromAST context ast (outputModule tm file outty)
68+ case result of
69+ Right _ -> return ()
70+ Left msg -> ierror msg
71+
72+failInIO :: ErrorT String IO a -> IO a
73+failInIO = either fail return <=< runErrorT
5874
5975itWidth :: IntTy -> Word32
6076itWidth ITNative = 32
6177itWidth x = fromIntegral $ intTyWidth x
6278
63−outputModule :: FilePath -> OutputType -> M.Module -> IO ()
64−outputModule file Raw m = either fail return <=< runErrorT $ M.writeBitcodeToFile file m
65−outputModule file Object m = withTmpFile $ \bc -> do
66− outputModule bc Raw m
67− exit <- rawSystem "llc" ["-filetype=obj", "--disable-fp-elim", "-o", file, bc]
68− when (exit /= ExitSuccess) $ ierror "FAILURE: Object generation"
69−outputModule file Executable m = withTmpFile $ \obj -> do
70− outputModule obj Object m
79+outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
80+outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
81+outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
82+outputModule tm file Executable m = withTmpFile $ \obj -> do
83+ outputModule tm obj Object m
7184 cc <- getCC
7285 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
7386 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
@@ -128,10 +141,10 @@ initDefs tgt =
128141 }
129142 , rtsFun "intStr" ptrI8 [IntegerType 64]
130143 [ BasicBlock (UnName 0)
131− [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)]
144+ [ UnName 1 := simpleCall "GC_malloc_atomic" [ConstantOperand (C.Int (tgtWordSize tgt) 21)]
132145 , UnName 2 := simpleCall "snprintf"
133146 [ LocalReference (UnName 1)
134− , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
147+ , ConstantOperand (C.Int (tgtWordSize tgt) 21)
135148 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
136149 , LocalReference (UnName 0)
137150 ]
@@ -170,7 +183,7 @@ initDefs tgt =
170183 , GlobalDefinition mainDef
171184 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
172185 where
173− intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
186+ intPtr = IntegerType (tgtWordSize tgt)
174187 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
175188 pmpz = PointerType mpzTy (AddrSpace 0)
176189
@@ -196,18 +209,24 @@ initDefs tgt =
196209 exVar :: String -> Type -> Definition
197210 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
198211
199− stdinName :: Target -> String
200− stdinName (Target { os = "darwin" }) = "__stdinp"
201− stdinName _ = "stdin"
202− stdoutName :: Target -> String
203− stdoutName (Target { os = "darwin" }) = "__stdoutp"
204− stdoutName _ = "stdout"
205− stderrName :: Target -> String
206− stderrName (Target { os = "darwin" }) = "__stderrp"
207− stderrName _ = "stderr"
212+isApple :: Target -> Bool
213+isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
214+
215+stdinName, stdoutName, stderrName :: Target -> String
216+stdinName t | isApple t = "__stdinp"
217+stdinName _ = "stdin"
218+stdoutName t | isApple t = "__stdoutp"
219+stdoutName _ = "stdout"
220+stderrName t | isApple t = "__stderrp"
221+stderrName _ = "stderr"
222+
223+getStdIn, getStdOut, getStdErr :: Codegen Operand
224+getStdIn = ConstantOperand . C.GlobalReference . Name . stdinName <$> asks target
225+getStdOut = ConstantOperand . C.GlobalReference . Name . stdoutName <$> asks target
226+getStdErr = ConstantOperand . C.GlobalReference . Name . stderrName <$> asks target
208227
209228codegen :: Target -> [SDecl] -> Module
210−codegen tgt defs = Module "idris" Nothing Nothing (initDefs tgt ++ globals ++ gendefs)
229+codegen tgt defs = Module "idris" (Just . dataLayout $ tgt) Nothing (initDefs tgt ++ globals ++ gendefs)
211230 where
212231 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
213232
@@ -366,13 +385,13 @@ alloc ty = do
366385sizeOf :: Type -> Codegen Operand
367386sizeOf ty = ConstantOperand . C.PtrToInt
368387 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
369− . IntegerType . fromIntegral <$> getWordSize
388+ . IntegerType <$> getWordSize
370389
371−tgtWordSize :: Target -> Integer
372−tgtWordSize (Target { arch = "i386" }) = 32
373−tgtWordSize (Target { arch = "x86_64" }) = 64
390+tgtWordSize :: Target -> Word32
391+tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
392+ fst . fromJust $ M.lookup (AddrSpace 0) l
374393
375−getWordSize :: Codegen Integer
394+getWordSize :: Codegen Word32
376395getWordSize = tgtWordSize <$> asks target
377396
378397cgExpr :: SExp -> Codegen (Maybe Operand)
@@ -908,8 +927,8 @@ cgOp LStrLen [s] = do
908927 ws <- getWordSize
909928 len' <- case ws of
910929 32 -> return len
911− x | x > 32 -> inst $ Trunc len (IntegerType $ fromInteger x) []
912− | x < 32 -> inst $ ZExt len (IntegerType $ fromInteger x) []
930+ x | x > 32 -> inst $ Trunc len (IntegerType 32) []
931+ | x < 32 -> inst $ ZExt len (IntegerType 32) []
913932 box (FInt IT32) len'
914933
915934cgOp LReadStr [p] = do
@@ -918,16 +937,18 @@ cgOp LReadStr [p] = do
918937 box FString s
919938
920939cgOp LStdIn [] = do
921− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []
940+ stdin <- getStdIn
941+ ptr <- inst $ Load False stdin Nothing 0 []
922942 box FPtr ptr
923943cgOp LStdOut [] = do
924− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []
944+ stdout <- getStdOut
945+ ptr <- inst $ Load False stdout Nothing 0 []
925946 box FPtr ptr
926947cgOp LStdErr [] = do
927− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []
948+ stdErr <- getStdErr
949+ ptr <- inst $ Load False stdErr Nothing 0 []
928950 box FPtr ptr
929951
930−
931952cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
932953 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
933954
@@ -944,7 +965,7 @@ cgStrCat x y = do
944965 xlen <- inst $ simpleCall "strlen" [x']
945966 ylen <- inst $ simpleCall "strlen" [y']
946967 zlen <- inst $ Add False True xlen ylen []
947− ws <- fromIntegral <$> getWordSize
968+ ws <- getWordSize
948969 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
949970 mem <- allocAtomic total
950971 inst $ simpleCall "memcpy" [mem, x', xlen]