diff options
Diffstat (limited to 'compiler/main/DriverPipeline.hs')
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 106 |
1 files changed, 61 insertions, 45 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index df6e7fd163..47706798f7 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -326,8 +326,7 @@ link' dflags batch_attempt_linking hpt return Succeeded else do - compilationProgressMsg dflags $ showSDoc $ - (ptext (sLit "Linking") <+> text exe_file <+> text "...") + compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -774,7 +773,7 @@ runPhase (Cpp sf) input_fn dflags0 (dflags1, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags1 unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. @@ -791,7 +790,7 @@ runPhase (Cpp sf) input_fn dflags0 src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags0 src_opts - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags2 unhandled_flags unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings @@ -826,7 +825,7 @@ runPhase (HsPp sf) input_fn dflags (dflags1, unhandled_flags, warns) <- io $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 - io $ checkProcessArgsResult unhandled_flags + io $ checkProcessArgsResult dflags1 unhandled_flags io $ handleFlagWarnings dflags1 warns return (Hsc sf, output_fn) @@ -1176,14 +1175,17 @@ runPhase As input_fn dflags = do llvmVer <- io $ figureLlvmVersion dflags return $ case llvmVer of - Just n | n >= 30 -> SysTools.runClang - _ -> SysTools.runAs + -- using cGccLinkerOpts here but not clear if + -- opt_c isn't a better choice + Just n | n >= 30 -> + (SysTools.runClang, cGccLinkerOpts) + + _ -> (SysTools.runAs, getOpts dflags opt_a) | otherwise - = return SysTools.runAs + = return (SysTools.runAs, getOpts dflags opt_a) - as_prog <- whichAsProg - let as_opts = getOpts dflags opt_a + (as_prog, as_opts) <- whichAsProg let cmdline_include_paths = includePaths dflags next_phase <- maybeMergeStub @@ -1191,7 +1193,7 @@ runPhase As input_fn dflags -- we create directories for the object file, because it -- might be a hierarchical module. - io $ createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryIfMissing True (takeDirectory output_fn) io $ as_prog dflags (map SysTools.Option as_opts @@ -1230,7 +1232,7 @@ runPhase SplitAs _input_fn dflags osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - io $ createDirectoryHierarchy split_odir + io $ createDirectoryIfMissing True split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. @@ -1369,7 +1371,8 @@ runPhase LlvmLlc input_fn dflags SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts ++ [SysTools.Option tbaa] - ++ map SysTools.Option fpOpts) + ++ map SysTools.Option fpOpts + ++ map SysTools.Option abiOpts) return (next_phase, output_fn) where @@ -1381,12 +1384,19 @@ runPhase LlvmLlc input_fn dflags -- while compiling GHC source code. It's probably due to fact that it -- does not enable VFP by default. Let's do this manually here fpOpts = case platformArch (targetPlatform dflags) of - ArchARM ARMv7 ext -> if (elem VFPv3 ext) + ArchARM ARMv7 ext _ -> if (elem VFPv3 ext) then ["-mattr=+v7,+vfp3"] else if (elem VFPv3D16 ext) then ["-mattr=+v7,+vfp3,+d16"] else [] _ -> [] + -- On Ubuntu/Debian with ARM hard float ABI, LLVM's llc still + -- compiles into soft-float ABI. We need to explicitly set abi + -- to hard + abiOpts = case platformArch (targetPlatform dflags) of + ArchARM ARMv7 _ HARD -> ["-float-abi=hard"] + ArchARM ARMv7 _ _ -> [] + _ -> [] ----------------------------------------------------------------------------- -- LlvmMangle phase @@ -1453,9 +1463,9 @@ runPhase_MoveBinary dflags input_fn return True | otherwise = return True -mkExtraCObj :: DynFlags -> String -> IO FilePath -mkExtraCObj dflags xs - = do cFile <- newTempName dflags "c" +mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath +mkExtraObj dflags extn xs + = do cFile <- newTempName dflags extn oFile <- newTempName dflags "o" writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId @@ -1474,23 +1484,19 @@ mkExtraCObj dflags xs -- so now we generate and compile a main() stub as part of every -- binary and pass the -rtsopts setting directly to the RTS (#5373) -- -mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath -mkExtraObjToLinkIntoBinary dflags dep_packages = do - link_info <- getLinkInfo dflags dep_packages - +mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath +mkExtraObjToLinkIntoBinary dflags = do let have_rts_opts_flags = isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of RtsOptsSafeOnly -> False _ -> True when (dopt Opt_NoHsMain dflags && have_rts_opts_flags) $ do - hPutStrLn stderr $ "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main.\n" ++ - " Call hs_init_ghc() from your main() function to set these options." + log_action dflags dflags SevInfo noSrcSpan defaultUserStyle + (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ + text " Call hs_init_ghc() from your main() function to set these options.") - mkExtraCObj dflags (showSDoc (vcat [main, - link_opts link_info] - <> char '\n')) -- final newline, to - -- keep gcc happy + mkExtraObj dflags "c" (showSDoc dflags main) where main @@ -1508,31 +1514,40 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do Just opts -> ptext (sLit " __conf.rts_opts= ") <> text (show opts) <> semi, ptext (sLit " return hs_main(argc, argv, &ZCMain_main_closure,__conf);"), - char '}' + char '}', + char '\n' -- final newline, to keep gcc happy ] - link_opts info - | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) - = empty - | otherwise = hcat [ - text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, - text ",\\\"\\\",", - text elfSectionNote, - text "\\n", +-- Write out the link info section into a new assembly file. Previously +-- this was included as inline assembly in the main.c file but this +-- is pretty fragile. gas gets upset trying to calculate relative offsets +-- that span the .note section (notably .text) when debug info is present +mkNoteObjsToLinkIntoBinary :: DynFlags -> [PackageId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + + if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags))) + then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info)) + else return [] + + where + link_opts info = hcat [ + text "\t.section ", text ghcLinkInfoSectionName, + text ",\"\",", + text elfSectionNote, + text "\n", - text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + text "\t.ascii \"", info', text "\"\n" ] where - -- we need to escape twice: once because we're inside a C string, - -- and again because we're inside an asm string. - info' = text $ (escape.escape) info + info' = text $ escape info escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) elfSectionNote :: String elfSectionNote = case platformArch (targetPlatform dflags) of - ArchARM _ _ -> "%note" - _ -> "@note" + ArchARM _ _ _ -> "%note" + _ -> "@note" -- The "link info" is a string representing the parameters of the -- link. We save this information in the binary, and the next time we @@ -1661,7 +1676,8 @@ linkBinary dflags o_files dep_packages = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags + noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1778,7 +1794,7 @@ linkBinary dflags o_files dep_packages = do ++ framework_path_opts ++ framework_opts ++ pkg_lib_path_opts - ++ [extraLinkObj] + ++ extraLinkObj:noteLinkObjs ++ pkg_link_opts ++ pkg_framework_path_opts ++ pkg_framework_opts @@ -2132,6 +2148,6 @@ hscPostBackendPhase dflags _ hsc_lang = touchObjectFile :: DynFlags -> FilePath -> IO () touchObjectFile dflags path = do - createDirectoryHierarchy $ takeDirectory path + createDirectoryIfMissing True $ takeDirectory path SysTools.touch dflags "Touching object file" path |