git.iko.soy/Idris-dev
on master help sign in
Direct object file output and accurate target selection
672f5a1Benjamin Saunders
src/IRTS/CodegenLLVM.hs+61−40
compare with master
unifiedsplit
@@ -13,6 +13,8 @@ import LLVM.General.Context
13import LLVM.General.Diagnostic
13import LLVM.General.Diagnostic
14import LLVM.General.AST
14import LLVM.General.AST
15import LLVM.General.AST.AddrSpace
15import LLVM.General.AST.AddrSpace
16+import LLVM.General.Target
17+import LLVM.General.AST.DataLayout
16import qualified LLVM.General.Module as M
18import qualified LLVM.General.Module as M
17import qualified LLVM.General.AST.IntegerPredicate as IPred
19import qualified LLVM.General.AST.IntegerPredicate as IPred
18import qualified LLVM.General.AST.Linkage as L
20import qualified LLVM.General.AST.Linkage as L
@@ -22,12 +24,16 @@ import qualified LLVM.General.AST.Attribute as A
22import qualified LLVM.General.AST.Global as G
24import qualified LLVM.General.AST.Global as G
23import qualified LLVM.General.AST.Constant as C
25import qualified LLVM.General.AST.Constant as C
24import qualified LLVM.General.AST.Float as F
26import 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
25
30
26import Data.List
31import Data.List
27import Data.Maybe
32import Data.Maybe
28import Data.Word
33import Data.Word
29import Data.Set (Set)
34import Data.Set (Set)
30import qualified Data.Set as S
35import qualified Data.Set as S
36+import qualified Data.Map as M
31import Control.Applicative
37import Control.Applicative
32import Control.Monad.RWS
38import Control.Monad.RWS
33import Control.Monad.Writer
39import Control.Monad.Writer
@@ -42,32 +48,39 @@ import System.Process (rawSystem)
42import System.Exit (ExitCode(..))
48import System.Exit (ExitCode(..))
43import Debug.Trace
49import Debug.Trace
44
50
45−data Target = Target { arch :: String, os :: String }
51+data Target = Target { triple :: String, dataLayout :: DataLayout }
46
52
47codegenLLVM :: [(TT.Name, SDecl)] ->
53codegenLLVM :: [(TT.Name, SDecl)] ->
48 FilePath -> -- output file name
54 FilePath -> -- output file name
49 OutputType ->
55 OutputType ->
50 IO ()
56 IO ()
51codegenLLVM defs file outty = withContext $ \context -> do
57codegenLLVM defs file outty = withContext $ \context -> do
52− let target = Target { arch = SI.arch, os = SI.os }
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
53− let ast = codegen target (map snd defs)
66+ let ast = codegen (Target triple layout) (map snd defs)
54− result <- runErrorT $ M.withModuleFromAST context ast (outputModule file outty)
67+ result <- runErrorT $ M.withModuleFromAST context ast (outputModule tm file outty)
55− case result of
68+ case result of
56− Right _ -> return ()
69+ Right _ -> return ()
57− Left msg -> ierror msg
70+ Left msg -> ierror msg
71+
72+failInIO :: ErrorT String IO a -> IO a
73+failInIO = either fail return <=< runErrorT
58
74
59itWidth :: IntTy -> Word32
75itWidth :: IntTy -> Word32
60itWidth ITNative = 32
76itWidth ITNative = 32
61itWidth x = fromIntegral $ intTyWidth x
77itWidth x = fromIntegral $ intTyWidth x
62
78
63−outputModule :: FilePath -> OutputType -> M.Module -> IO ()
79+outputModule :: TargetMachine -> FilePath -> OutputType -> M.Module -> IO ()
64−outputModule file Raw m = either fail return <=< runErrorT $ M.writeBitcodeToFile file m
80+outputModule _ file Raw m = failInIO $ M.writeBitcodeToFile file m
65−outputModule file Object m = withTmpFile $ \bc -> do
81+outputModule tm file Object m = failInIO $ M.writeObjectToFile tm file m
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
82+outputModule tm file Executable m = withTmpFile $ \obj -> do
70− outputModule obj Object m
83+ outputModule tm obj Object m
71 cc <- getCC
84 cc <- getCC
72 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
85 defs <- (</> "llvm" </> "libidris_rts.a") <$> getDataDir
73 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
86 exit <- rawSystem cc [obj, defs, "-lm", "-lgmp", "-lgc", "-o", file]
@@ -128,10 +141,10 @@ initDefs tgt =
128 }
141 }
129 , rtsFun "intStr" ptrI8 [IntegerType 64]
142 , rtsFun "intStr" ptrI8 [IntegerType 64]
130 [ BasicBlock (UnName 0)
143 [ 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)]
132 , UnName 2 := simpleCall "snprintf"
145 , UnName 2 := simpleCall "snprintf"
133 [ LocalReference (UnName 1)
146 [ LocalReference (UnName 1)
134− , ConstantOperand (C.Int (fromInteger $ tgtWordSize tgt) 21)
147+ , ConstantOperand (C.Int (tgtWordSize tgt) 21)
135 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
148 , ConstantOperand $ C.GetElementPtr True (C.GlobalReference . Name $ "__idris_intFmtStr") [C.Int 32 0, C.Int 32 0]
136 , LocalReference (UnName 0)
149 , LocalReference (UnName 0)
137 ]
150 ]
@@ -170,7 +183,7 @@ initDefs tgt =
170 , GlobalDefinition mainDef
183 , GlobalDefinition mainDef
171 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
184 ] ++ map mpzBinFun ["add", "sub", "mul", "fdiv_q", "fdiv_r", "and", "ior", "xor"]
172 where
185 where
173− intPtr = IntegerType (fromInteger $ tgtWordSize tgt)
186+ intPtr = IntegerType (tgtWordSize tgt)
174 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
187 ptrI8 = PointerType (IntegerType 8) (AddrSpace 0)
175 pmpz = PointerType mpzTy (AddrSpace 0)
188 pmpz = PointerType mpzTy (AddrSpace 0)
176
189
@@ -196,18 +209,24 @@ initDefs tgt =
196 exVar :: String -> Type -> Definition
209 exVar :: String -> Type -> Definition
197 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
210 exVar name ty = GlobalDefinition $ globalVariableDefaults { G.name = Name name, G.type' = ty }
198
211
199− stdinName :: Target -> String
212+isApple :: Target -> Bool
200− stdinName (Target { os = "darwin" }) = "__stdinp"
213+isApple (Target { triple = t }) = isJust . stripPrefix "-apple" $ dropWhile (/= '-') t
214+
215+stdinName, stdoutName, stderrName :: Target -> String
216+stdinName t | isApple t = "__stdinp"
201− stdinName _ = "stdin"
217+stdinName _ = "stdin"
202− stdoutName :: Target -> String
218+stdoutName t | isApple t = "__stdoutp"
203− stdoutName (Target { os = "darwin" }) = "__stdoutp"
204− stdoutName _ = "stdout"
219+stdoutName _ = "stdout"
205− stderrName :: Target -> String
220+stderrName t | isApple t = "__stderrp"
206− stderrName (Target { os = "darwin" }) = "__stderrp"
207− stderrName _ = "stderr"
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
208
227
209codegen :: Target -> [SDecl] -> Module
228codegen :: 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)
211 where
230 where
212 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
231 (gendefs, _, globals) = runRWS (mapM cgDef defs) tgt 0
213
232
@@ -366,13 +385,13 @@ alloc ty = do
366sizeOf :: Type -> Codegen Operand
385sizeOf :: Type -> Codegen Operand
367sizeOf ty = ConstantOperand . C.PtrToInt
386sizeOf ty = ConstantOperand . C.PtrToInt
368 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
387 (C.GetElementPtr True (C.Null (PointerType ty (AddrSpace 0))) [C.Int 32 1])
369− . IntegerType . fromIntegral <$> getWordSize
388+ . IntegerType <$> getWordSize
370
389
371−tgtWordSize :: Target -> Integer
390+tgtWordSize :: Target -> Word32
372−tgtWordSize (Target { arch = "i386" }) = 32
391+tgtWordSize (Target { dataLayout = DataLayout { pointerLayouts = l } }) =
373−tgtWordSize (Target { arch = "x86_64" }) = 64
392+ fst . fromJust $ M.lookup (AddrSpace 0) l
374
393
375−getWordSize :: Codegen Integer
394+getWordSize :: Codegen Word32
376getWordSize = tgtWordSize <$> asks target
395getWordSize = tgtWordSize <$> asks target
377
396
378cgExpr :: SExp -> Codegen (Maybe Operand)
397cgExpr :: SExp -> Codegen (Maybe Operand)
@@ -908,8 +927,8 @@ cgOp LStrLen [s] = do
908 ws <- getWordSize
927 ws <- getWordSize
909 len' <- case ws of
928 len' <- case ws of
910 32 -> return len
929 32 -> return len
911− x | x > 32 -> inst $ Trunc len (IntegerType $ fromInteger x) []
930+ x | x > 32 -> inst $ Trunc len (IntegerType 32) []
912− | x < 32 -> inst $ ZExt len (IntegerType $ fromInteger x) []
931+ | x < 32 -> inst $ ZExt len (IntegerType 32) []
913 box (FInt IT32) len'
932 box (FInt IT32) len'
914
933
915cgOp LReadStr [p] = do
934cgOp LReadStr [p] = do
@@ -918,16 +937,18 @@ cgOp LReadStr [p] = do
918 box FString s
937 box FString s
919
938
920cgOp LStdIn [] = do
939cgOp LStdIn [] = do
940+ stdin <- getStdIn
921− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdin") Nothing 0 []
941+ ptr <- inst $ Load False stdin Nothing 0 []
922 box FPtr ptr
942 box FPtr ptr
923cgOp LStdOut [] = do
943cgOp LStdOut [] = do
944+ stdout <- getStdOut
924− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stdout") Nothing 0 []
945+ ptr <- inst $ Load False stdout Nothing 0 []
925 box FPtr ptr
946 box FPtr ptr
926cgOp LStdErr [] = do
947cgOp LStdErr [] = do
948+ stdErr <- getStdErr
927− ptr <- inst $ Load False (ConstantOperand . C.GlobalReference . Name $ "stderr") Nothing 0 []
949+ ptr <- inst $ Load False stdErr Nothing 0 []
928 box FPtr ptr
950 box FPtr ptr
929
951
930−
931cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
952cgOp prim args = ierror $ "Unimplemented primitive: [" ++ show prim ++ "]("
932 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
953 ++ intersperse ',' (take (length args) ['a'..]) ++ ")"
933
954
@@ -944,7 +965,7 @@ cgStrCat x y = do
944 xlen <- inst $ simpleCall "strlen" [x']
965 xlen <- inst $ simpleCall "strlen" [x']
945 ylen <- inst $ simpleCall "strlen" [y']
966 ylen <- inst $ simpleCall "strlen" [y']
946 zlen <- inst $ Add False True xlen ylen []
967 zlen <- inst $ Add False True xlen ylen []
947− ws <- fromIntegral <$> getWordSize
968+ ws <- getWordSize
948 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
969 total <- inst $ Add False True zlen (ConstantOperand (C.Int ws 1)) []
949 mem <- allocAtomic total
970 mem <- allocAtomic total
950 inst $ simpleCall "memcpy" [mem, x', xlen]
971 inst $ simpleCall "memcpy" [mem, x', xlen]