[Git][ghc/ghc][wip/ghc-fat-interface] Fixes
Matthew Pickering (@mpickering)
gitlab at gitlab.haskell.org
Thu Aug 11 15:51:55 UTC 2022
Matthew Pickering pushed to branch wip/ghc-fat-interface at Glasgow Haskell Compiler / GHC
Commits:
8b0d0501 by Matthew Pickering at 2022-08-11T16:50:10+01:00
Fixes
- - - - -
18 changed files:
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Linker/Types.hs
- compiler/GHC/Unit/Module/FatIface.hs
- compiler/GHC/Unit/Module/Location.hs
- testsuite/tests/driver/fat-iface/Makefile
- testsuite/tests/driver/fat-iface/all.T
- testsuite/tests/driver/fat-iface/fat001.stdout
- testsuite/tests/driver/fat-iface/fat006.stdout
- + testsuite/tests/driver/fat-iface/fat006a.stderr
Changes:
=====================================
compiler/GHC/Driver/Backend.hs
=====================================
@@ -663,7 +663,7 @@ backendForcesOptimization0 (Named NCG) = False
backendForcesOptimization0 (Named LLVM) = False
backendForcesOptimization0 (Named ViaC) = False
backendForcesOptimization0 (Named Interpreter) = True
-backendForcesOptimization0 (Named NoBackend) = False
+backendForcesOptimization0 (Named NoBackend) = True
-- | I don't understand exactly how this works. But if
-- this flag is set *and* another condition is met, then
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -278,8 +278,8 @@ import System.IO
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time
-import GHC.Utils.Trace
-import System.IO.Unsafe
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import GHC.Iface.Env ( trace_if )
@@ -687,7 +687,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
Nothing -> hscParse' mod_summary
tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
if hsc_src == HsigFile
- then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary
+ then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary
ioMsgMaybe $ hoistTcRnMessage $
tcRnMergeSignatures hsc_env hpm tc_result0 iface
else return tc_result0
@@ -752,7 +752,7 @@ hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar hsc_env mod_summary tc_result =
runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
-hscDesugar' :: HasCallStack => ModLocation -> TcGblEnv -> Hsc ModGuts
+hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' mod_location tc_result = do
hsc_env <- getHscEnv
ioMsgMaybe $ hoistDsMessage $
@@ -850,10 +850,11 @@ hscRecompStatus
else
-- Do need linkable
do
- -- 1. Just check whether we have ByteCode/object linkables and then
+ -- 1. Just check whether we have bytecode/object linkables and then
-- we will decide if we need them or not.
bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)
obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary
+ trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])
let just_bc = justBytecode <$> bc_linkable
just_o = justObjects <$> obj_linkable
@@ -949,7 +950,7 @@ checkByteCode iface mod_sum mb_old_linkable =
loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode iface mod_sum = do
let
- this_mod = ms_mod mod_sum
+ this_mod = ms_mod mod_sum
if_date = fromJust $ ms_iface_date mod_sum
case mi_extra_decls iface of
Just extra_decls -> do
@@ -963,8 +964,8 @@ loadByteCode iface mod_sum = do
-- Knot tying! See Note [Knot-tying typecheckIface]
-- See Note [ModDetails and --make mode]
-initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
-initModDetails hsc_env _mod_summary iface =
+initModDetails :: HscEnv -> ModIface -> IO ModDetails
+initModDetails hsc_env iface =
fixIO $ \details' -> do
let act hpt = addToHpt hpt (moduleName $ mi_module iface)
(HomeModInfo iface details' emptyHomeModInfoLinkable)
@@ -982,14 +983,18 @@ initFatIface hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time
go (FI fi) = do
let act hpt = addToHpt hpt (moduleName $ mi_module mod_iface)
(HomeModInfo mod_iface details emptyHomeModInfoLinkable)
- types_var <- newIORef (md_types details) -- (extendTypeEnvList emptyTypeEnv ((map ATyCon tycons) ++ concatMap (implicitTyThings . ATyCon) tycons))
+ types_var <- newIORef (md_types details)
let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckFatIface types_var fi
-- MP: TODO: NoStubs defo wrong
let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
+ -- The bytecode generation itself is lazy because otherwise even when doing
+ -- recompilation checking the bytecode will be generated (which slows things down a lot)
+ -- the laziness is OK because generateByteCode just depends on things already loaded
+ -- in the interface file.
LoadedBCOs <$> (unsafeInterleaveIO $ do
- pprTraceM "forcing" (ppr this_mod)
+ trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
generateByteCode hsc_env cgi_guts (fi_mod_location fi))
go ul = return ul
@@ -1047,7 +1052,7 @@ See !5492 and #13586
-- HscRecomp in turn will carry the information required to compute a interface
-- when passed the result of the code generator. So all this can and is done at
-- the call site of the backend code gen if it is run.
-hscDesugarAndSimplify :: HasCallStack => ModSummary
+hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
@@ -1099,18 +1104,34 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h
hscs_old_iface_hash = mb_old_hash
}
- -- We are not generating code, so we can skip simplification
+ Just desugared_guts | gopt Opt_WriteFatInterface dflags -> do
+ -- If -fno-code is enabled (hence we fall through to this case) then
+ -- -O0 is implied, so this simplifier pass will be quite gentle. Running
+ -- the simplifier once is necessary before doing byte code generation
+ -- in order to inline data con wrappers.
+ plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
+ simplified_guts <- hscSimplify' plugins desugared_guts
+ (cg_guts, _) <-
+ liftIO $ hscTidy hsc_env simplified_guts
+
+ (iface, _details) <- liftIO $
+ hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary
+
+ liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)
+
+ return $ HscUpdate iface
+
+
+ -- We are not generating code or writing a fat interface so we can skip simplification
-- and generate a simple interface.
_ -> do
- --MP: TODO, we should be able to write a fat interface even when NoBackend is on
(iface, _details) <- liftIO $
- hscSimpleIface hsc_env tc_result summary
+ hscSimpleIface hsc_env Nothing tc_result summary
liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)
return $ HscUpdate iface
-
{-
Note [Writing interface files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1716,16 +1737,18 @@ hscSimplify' plugins ds_result = do
-- | Generate a striped down interface file, e.g. for boot files or when ghci
-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]
hscSimpleIface :: HscEnv
+ -> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
-hscSimpleIface hsc_env tc_result summary
- = runHsc hsc_env $ hscSimpleIface' tc_result summary
+hscSimpleIface hsc_env mb_core_program tc_result summary
+ = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary
-hscSimpleIface' :: TcGblEnv
+hscSimpleIface' :: Maybe CoreProgram
+ -> TcGblEnv
-> ModSummary
-> Hsc (ModIface, ModDetails)
-hscSimpleIface' tc_result summary = do
+hscSimpleIface' mb_core_program tc_result summary = do
hsc_env <- getHscEnv
logger <- getLogger
details <- liftIO $ mkBootModDetailsTc logger tc_result
@@ -1733,7 +1756,7 @@ hscSimpleIface' tc_result summary = do
new_iface
<- {-# SCC "MkFinalIface" #-}
liftIO $
- mkIfaceTc hsc_env safe_mode details summary tc_result
+ mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result
-- And the answer is ...
liftIO $ dumpIfaceStats hsc_env
return (new_iface, details)
@@ -1906,10 +1929,7 @@ generateFreshByteCode :: HscEnv
-> ModLocation
-> IO Linkable
generateFreshByteCode hsc_env mod_name cgguts mod_location = do
- -- MP: Not sure this is great to have this unsafeInterlaveIO here, it's definitely necessary
- -- in the case of generating byte code from an interface but potentially leaky in general because
- -- `cgguts` may not be so clean in memory as that which has just been loaded from an interface.
- ul <- unsafeInterleaveIO $ generateByteCode hsc_env cgguts mod_location
+ ul <- generateByteCode hsc_env cgguts mod_location
unlinked_time <- getCurrentTime
let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul
return linkable
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -244,7 +244,7 @@ compileOne' mHscMessage
let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
(iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline
-- See Note [ModDetails and --make mode]
- details <- initModDetails plugin_hsc_env upd_summary iface
+ details <- initModDetails plugin_hsc_env iface
linkable' <- traverse (initFatIface plugin_hsc_env iface details) (homeMod_bytecode linkable)
return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
@@ -765,7 +765,7 @@ hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
unlinked_time <- liftIO (liftIO getCurrentTime)
final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
- -- If the backend step produced a bytecode linkable then use that rather than the object file linkable.
+ -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
return (mlinkable { homeMod_object = Just linkable })
return (miface, final_linkable)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2250,7 +2250,6 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "dynamic-too"
(NoArg (setGeneralFlag Opt_BuildDynamicToo))
-
------- Keeping temporary files -------------------------------------
-- These can be singular (think ghc -c) or plural (think ghc --make)
, make_ord_flag defGhcFlag "keep-hc-file"
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -148,7 +148,6 @@ readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
, mi_src_hash = src_hash
}
-
-- | This performs a get action after reading the dictionary and symbol
-- table. It is necessary to run this before trying to deserialise any
-- Names or FastStrings.
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -1129,8 +1129,7 @@ pprModIface unit_state iface at ModIface{ mi_final_exts = exts }
, case mi_extra_decls iface of
Nothing -> empty
Just eds -> text "extra-decls"
- -- TODO: MP print better with structure
- $$ vcat ([ppr bs | bs <- eds])
+ $$ nest 2 (vcat ([ppr bs | bs <- eds]))
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -186,9 +186,10 @@ mkIfaceTc :: HscEnv
-> SafeHaskellMode -- The safe haskell mode
-> ModDetails -- gotten from mkBootModDetails, probably
-> ModSummary
+ -> Maybe CoreProgram
-> TcGblEnv -- Usages, deprecations, etc
-> IO ModIface
-mkIfaceTc hsc_env safe_mode mod_details mod_summary
+mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
tc_result at TcGblEnv{ tcg_mod = this_mod,
tcg_src = hsc_src,
tcg_imports = imports,
@@ -229,7 +230,7 @@ mkIfaceTc hsc_env safe_mode mod_details mod_summary
docs <- extractDocs (ms_hspp_opts mod_summary) tc_result
let partial_iface = mkIface_ hsc_env
- this_mod [] hsc_src
+ this_mod (fromMaybe [] mb_program) hsc_src
used_th deps rdr_env
fix_env warns hpc_info
(imp_trust_own_pkg imports) safe_mode usages
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -70,7 +70,7 @@ import GHC.Unit.Module.Warnings
import GHC.Unit.Module.Deps
import Control.Monad
-import Data.List (sortBy, sort)
+import Data.List (sortBy, sort, sortOn)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Word (Word64)
@@ -1201,9 +1201,14 @@ addFingerprints hsc_env iface0
sorted_decls = Map.elems $ Map.fromList $
[(getOccName d, e) | e@(_, d) <- decls_w_hashes]
- -- TODO: MP implement sorting here
+ getOcc (IfGblTopBndr b) = getOccName b
+ getOcc (IfLclTopBndr fs _ _ _) = mkVarOccFS fs
+
+ binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()
+ binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)
+
sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
- sorted_extra_decls = mi_extra_decls iface0
+ sorted_extra_decls = sortOn binding_key <$> mi_extra_decls iface0
-- the flag hash depends on:
-- - (some of) dflags
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -586,21 +586,15 @@ type IfaceBinding b = IfaceBindingX IfaceExpr b
data IfaceBindingX r b
= IfaceNonRec b r
| IfaceRec [(b, r)]
- deriving (Functor, Foldable, Traversable)
+ deriving (Functor, Foldable, Traversable, Ord, Eq)
-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
-- See Note [IdInfo on nested let-bindings]
data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo
-data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails | IfGblTopBndr IfaceTopBndr
-
- {-
- IfTopBndr { top_bndr_name :: Either IfLclName IfaceTopBndr
- , top_bndr_type :: IfaceType
- , top_bndr_id_info :: IfaceIdInfo
- , top_bndr_iface_details :: IfaceIdDetails
- ]-}
+data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails
+ | IfGblTopBndr IfaceTopBndr
data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -237,7 +237,7 @@ typecheckIface iface
}
}
-typecheckFatIface :: IORef TypeEnv -> FatIface -> IfG [CoreBind]
+typecheckFatIface :: IORef TypeEnv -> FatIface -> IfG [CoreBind]
typecheckFatIface type_var (FatIface prepd_binding this_mod _) =
initIfaceLcl this_mod (text "typecheckFatIface") NotBoot $ do
tcTopIfaceBindings type_var prepd_binding
=====================================
compiler/GHC/Linker/Types.hs
=====================================
@@ -157,7 +157,7 @@ data Unlinked
= DotO ObjFile -- ^ An object file (.o)
| DotA FilePath -- ^ Static archive file (.a)
| DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib)
- | FI FatIface -- ^ Serialised core which we can turn into BCOs (or object files)
+ | FI FatIface -- ^ Serialised core which we can turn into BCOs (or object files), or used by some other backend
| LoadedBCOs [Unlinked] -- ^ A list of BCOs, but hidden behind extra indirection to avoid
-- being too strict.
| BCOs CompiledByteCode
=====================================
compiler/GHC/Unit/Module/FatIface.hs
=====================================
@@ -1,17 +1,10 @@
module GHC.Unit.Module.FatIface where
-import GHC.Prelude
import GHC.Unit.Types (Module)
import GHC.Unit.Module.Location
import GHC.Iface.Syntax
-import GHC.Utils.Binary
data FatIface = FatIface { fi_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
, fi_module :: Module
, fi_mod_location :: ModLocation
}
-
-
-instance Binary FatIface where
- put_ bh (FatIface a b c) = put_ bh a >> put_ bh b >> put_ bh c
- get bh = FatIface <$> get bh <*> get bh <*> get bh
=====================================
compiler/GHC/Unit/Module/Location.hs
=====================================
@@ -13,7 +13,6 @@ where
import GHC.Prelude
import GHC.Unit.Types
import GHC.Utils.Outputable
-import GHC.Utils.Binary
-- | Module Location
--
@@ -69,21 +68,6 @@ data ModLocation
} deriving Show
-instance Binary ModLocation where
- put_ bh (ModLocation a b c d e f) = do
- put_ bh a
- put_ bh b
- put_ bh c
- put_ bh d
- put_ bh e
- put_ bh f
- get bh = ModLocation <$> get bh
- <*> get bh
- <*> get bh
- <*> get bh
- <*> get bh
- <*> get bh
-
instance Outputable ModLocation where
ppr = text . show
=====================================
testsuite/tests/driver/fat-iface/Makefile
=====================================
@@ -8,7 +8,7 @@ clean:
rm -f *.hi *.hi-fat *.o
fat001: clean
- "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -fwrite-fat-interface
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -fwrite-fat-interface -dno-typeable-binds
test -f Fat.hi
"$(TEST_HC)" $(TEST_HC_OPTS) --show-iface Fat.hi | grep -A3 extra-decls
@@ -22,15 +22,15 @@ fat007: clean
"$(TEST_HC)" $(TEST_HC_OPTS) -v0 -ddump-bcos Fat.hs
-# -fno-code -fwrite-fat-interface should not generate object files but should generate .hi-fat
-# -fwrite-fat-interface also implies -fwrite-interface (you need both)
-
fat006: clean
- "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -fno-code -fwrite-fat-interface
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -dno-typeable-binds -fno-code -fwrite-fat-interface
test -f Fat.hi
"$(TEST_HC)" $(TEST_HC_OPTS) --show-iface Fat.hi | grep -A3 extra-decls
test ! -f Fat.o
+fat006a: clean
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c Fat.hs -dno-typeable-binds -fno-code -fwrite-fat-interface -O2
+
fat008: clean
"$(TEST_HC)" $(TEST_HC_OPTS) FatTH.hs -fwrite-fat-interface -fprefer-byte-code
echo >> "FatTH.hs"
=====================================
testsuite/tests/driver/fat-iface/all.T
=====================================
@@ -1,7 +1,8 @@
test('fat001', [extra_files(['Fat.hs'])], makefile_test, ['fat001'])
test('fat005', [extra_files(['Fat.hs']), filter_stdout_lines(r'= Proto-BCOs')], makefile_test, ['fat005'])
-test('fat007', [extra_files(['Fat.hs'])], makefile_test, ['fat007'])
test('fat006', [extra_files(['Fat.hs'])], makefile_test, ['fat006'])
+test('fat006a', [extra_files(['Fat.hs'])], makefile_test, ['fat006a'])
+test('fat007', [extra_files(['Fat.hs'])], makefile_test, ['fat007'])
test('fat008', [unless(ghc_dynamic(), skip), extra_files(['FatTH.hs', 'FatQuote.hs']), copy_files], makefile_test, ['fat008'])
test('fat009', [extra_files(['FatTH.hs', 'FatQuote.hs']), copy_files], makefile_test, ['fat009'])
test('fat010', [extra_files(['THA.hs', 'THB.hs', 'THC.hs']), copy_files], makefile_test, ['fat010'])
=====================================
testsuite/tests/driver/fat-iface/fat001.stdout
=====================================
@@ -1,4 +1,4 @@
extra-decls
-f = GHC.Types.C# 'f'#
-a = GHC.Types.C# 'a'#
-t = GHC.Types.C# 't'#
+ a = GHC.Types.C# 'a'#
+ f = GHC.Types.C# 'f'#
+ t = GHC.Types.C# 't'#
=====================================
testsuite/tests/driver/fat-iface/fat006.stdout
=====================================
@@ -1,4 +1,4 @@
extra-decls
-trusted: none
-require own pkg trusted: False
-docs:
+ a = GHC.Types.C# 'a'#
+ f = GHC.Types.C# 'f'#
+ t = GHC.Types.C# 't'#
=====================================
testsuite/tests/driver/fat-iface/fat006a.stderr
=====================================
@@ -0,0 +1,3 @@
+
+when making flags consistent: warning:
+ Optimization flags are incompatible with the no code generated; optimization flags ignored.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b0d05010591a0e5e01d4cffc2630768938ca753
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b0d05010591a0e5e01d4cffc2630768938ca753
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220811/b988cdde/attachment-0001.html>
More information about the ghc-commits
mailing list