diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 7 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 24 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsListComp.hs | 2 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 22 | ||||
| -rw-r--r-- | compiler/deSugar/DsUtils.hs | 39 | ||||
| -rw-r--r-- | compiler/deSugar/MatchLit.hs | 6 | ||||
| -rw-r--r-- | compiler/simplCore/CSE.hs | 9 | ||||
| -rw-r--r-- | compiler/simplCore/SimplUtils.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 44 |
10 files changed, 134 insertions, 29 deletions
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index d5931d16e5..a02b1625a9 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -127,6 +127,7 @@ deSugar hsc_env ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env complete_matches $ + withTopBinds $ do { ds_ev_binds <- dsEvBinds ev_binds ; core_prs <- dsTopLHsBinds binds_cvr ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs @@ -143,15 +144,15 @@ deSugar hsc_env ; case mb_res of { Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> + Just ((ds_ev_binds, all_prs, all_rules, vects0, ds_fords), ds_top_binds) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules final_prs = addExportFlagsAndRules target export_set keep_alive rules_for_locals (fromOL all_prs) - - final_pgm = combineEvBinds ds_ev_binds final_prs + final_binds = ds_ev_binds ++ ds_top_binds + final_pgm = combineEvBinds final_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds -- When compiling PrelFloat, which defines data Float = F# Float# -- we want F# to be in scope in the foreign marshalling code! diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 0b115cb902..3414d55b63 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -41,6 +41,7 @@ import PrelNames import TyCon import TcEvidence import TcType +import TcRnMonad import Type import Coercion import TysWiredIn ( typeNatKind, typeSymbolKind ) @@ -61,7 +62,6 @@ import BasicTypes import DynFlags import FastString import Util -import MonadUtils import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -1151,7 +1151,7 @@ dsEvTerm (EvId v) = return (Var v) dsEvTerm (EvCallStack cs) = dsEvCallStack cs dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev dsEvTerm (EvLit (EvNum n)) = mkNaturalExpr n -dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s +dsEvTerm (EvLit (EvStr s)) = mkStringExprFSAtTopLevel s dsEvTerm (EvCast tm co) = do { tm' <- dsEvTerm tm @@ -1174,14 +1174,15 @@ dsEvTerm (EvSelector sel_id tys tms) = do { tms' <- mapM dsEvTerm tms ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' } -dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg +dsEvTerm (EvDelayedError ty msg) = dsEvDelayedError ty msg -dsEvDelayedError :: Type -> FastString -> CoreExpr +dsEvDelayedError :: Type -> FastString -> DsM CoreExpr dsEvDelayedError ty msg - = Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg] + = do { litMsg <- bindExprAtTopLevel (Lit (MachStr (fastStringToByteString msg))) + ; return $ Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] + `mkApps` [litMsg] } where errorId = tYPE_ERROR_ID - litMsg = Lit (MachStr (fastStringToByteString msg)) {-********************************************************************** * * @@ -1321,11 +1322,11 @@ dsEvCallStack cs = do df <- getDynFlags m <- getModule srcLocDataCon <- dsLookupDataCon srcLocDataConName - let mkSrcLoc l = + let mkSrcLoc l = bindExprAtTopLevel =<< liftM (mkCoreConApps srcLocDataCon) - (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) - , mkStringExprFS (moduleNameFS $ moduleName m) - , mkStringExprFS (srcSpanFile l) + (sequence [ mkStringExprFSAtTopLevel (unitIdFS $ moduleUnitId m) + , mkStringExprFSAtTopLevel (moduleNameFS $ moduleName m) + , mkStringExprFSAtTopLevel (srcSpanFile l) , return $ mkIntExprInt df (srcSpanStartLine l) , return $ mkIntExprInt df (srcSpanStartCol l) , return $ mkIntExprInt df (srcSpanEndLine l) @@ -1339,7 +1340,7 @@ dsEvCallStack cs = do mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest] let mkPush name loc tm = do - nameExpr <- mkStringExprFS name + nameExpr <- mkStringExprFSAtTopLevel name locExpr <- mkSrcLoc loc case tm of EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS) @@ -1350,6 +1351,7 @@ dsEvCallStack cs = do -- See Note [Overview of implicit CallStacks] let ip_co = unwrapIP (exprType tmExpr) return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co)) + case cs of EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm EvCsEmpty -> return emptyCS diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 28254c93b4..6502c781f5 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -979,7 +979,7 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr handle_failure pat match fail_op | matchCanFail match = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + ; fail_msg <- mkStringExprAtTopLevel (mk_fail_msg dflags pat) ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] ; extractMatchResult match fail_expr } | otherwise diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs index 2bb303ec98..ba8085c6a2 100644 --- a/compiler/deSugar/DsListComp.hs +++ b/compiler/deSugar/DsListComp.hs @@ -824,7 +824,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts handle_failure pat match fail_op | matchCanFail match = do { dflags <- getDynFlags - ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat) + ; fail_msg <- mkStringExprAtTopLevel (mk_fail_msg dflags pat) ; fail_expr <- dsSyntaxExpr fail_op [fail_msg] ; extractMatchResult match fail_expr } | otherwise diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 4f68100111..7242937ee6 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -6,7 +6,7 @@ @DsMonad@: monadery used in desugaring -} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan module DsMonad ( @@ -24,6 +24,7 @@ module DsMonad ( UniqSupply, newUniqueSupply, getGhcModeDs, dsGetFamInstEnvs, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, + withTopBinds, PArrBuiltin(..), dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe, @@ -161,7 +162,7 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env fam_inst_env complete_matches thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) ; let all_matches = (hptCompleteSigs hsc_env) ++ complete_matches - ; pm_iter_var <- newIORef 0 + ; pm_iter_var <- newIORef 0 ; let dflags = hsc_dflags hsc_env (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var @@ -291,6 +292,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar complete_matches , ds_dph_env = emptyGlobalRdrEnv , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" , ds_complete_matches = completeMatchMap + , ds_top_binds = Nothing } lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span @@ -318,6 +320,22 @@ loadModule doc mod is_dloc = wiredInSrcSpan, is_as = name } name = moduleName mod +-- | Run the provided action and gather any additional top-level +-- binders generated by it. +withTopBinds :: DsM a -> DsM (a, [CoreBind]) +-- see Note [Adding Top-Level Binders in the Desugarer] +withTopBinds thing_inside = do + dflags <- getDynFlags + if optLevel dflags < 1 + -- don't actually bind things at the top at -O0. + -- See Note [Adding Top-Level Bindings in the Desugarer] + then (,[]) <$> thing_inside + else do + ref <- liftIO (newIORef []) + a <- updGblEnv (\env -> env { ds_top_binds = Just ref }) thing_inside + top_binds <- liftIO (readIORef ref) + return (a, top_binds) + {- ************************************************************************ * * diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 165130aa94..331b42d922 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -25,6 +25,8 @@ module DsUtils ( wrapBind, wrapBinds, mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs, + mkStringExprAtTopLevel, mkStringExprFSAtTopLevel, + bindExprAtTopLevel, seqVar, @@ -73,6 +75,8 @@ import SrcLoc import Util import DynFlags import FastString +import Data.IORef +import TcRnMonad import qualified GHC.LanguageExtensions as LangExt import TcEvidence @@ -466,10 +470,9 @@ mkErrorAppDs :: Id -- The error function mkErrorAppDs err_id ty msg = do src_loc <- getSrcSpanDs dflags <- getDynFlags - let - full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) - core_msg = Lit (mkMachString full_msg) - -- mkMachString returns a result of type String# + let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg]) + -- mkMachString returns a result of type String# + core_msg <- bindExprAtTopLevel (Lit (mkMachString full_msg)) return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg]) {- @@ -567,6 +570,34 @@ mkCastDs :: CoreExpr -> Coercion -> CoreExpr mkCastDs e co | isReflCo co = e | otherwise = Cast e co +-- | Like 'mkStringExpr' except it makes the string a new top-level binder. +mkStringExprAtTopLevel :: String -> DsM CoreExpr +mkStringExprAtTopLevel = mkStringExprFSAtTopLevel . fsLit + +-- | Like 'mkStringExprFS' except it makes the string a new top-level binder. +mkStringExprFSAtTopLevel :: FastString -> DsM CoreExpr +mkStringExprFSAtTopLevel str = do + str_expr <- mkStringExprFS str + bindExprAtTopLevel str_expr + +-- | Attempt to bind an expression at the top level. +-- +-- @bindExprAtTopLevel e@ returns a @Var v@ where @v@ is bound to @e@ +-- if we are compiling a whole module. +-- If we are compiling an individual expression, e.g. in GHCi, +-- it returns @e@ unmodified. +bindExprAtTopLevel :: CoreExpr -> DsM CoreExpr +-- see Note [Adding Top-Level Binders in the Desguarer] +bindExprAtTopLevel expr = do + top_binds_var_maybe <- ds_top_binds <$> getGblEnv + case top_binds_var_maybe of + Nothing -> return expr + Just var -> do + id <- newSysLocalDs (exprType expr) + liftIO $ modifyIORef var ((NonRec id expr) :) + return (Var id) + + {- ************************************************************************ * * diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index 2e9a5235bf..e955a4f556 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -73,7 +73,7 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc. -} dsLit :: HsLit -> DsM CoreExpr -dsLit (HsStringPrim _ s) = return (Lit (MachStr s)) +dsLit (HsStringPrim _ s) = bindExprAtTopLevel (Lit (MachStr s)) dsLit (HsCharPrim _ c) = return (Lit (MachChar c)) dsLit (HsIntPrim _ i) = return (Lit (MachInt i)) dsLit (HsWordPrim _ w) = return (Lit (MachWord w)) @@ -83,7 +83,7 @@ dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar _ c) = return (mkCharExpr c) -dsLit (HsString _ str) = mkStringExprFS str +dsLit (HsString _ str) = mkStringExprFSAtTopLevel str dsLit (HsInteger _ i _) = mkIntegerExpr i dsLit (HsInt _ i) = do dflags <- getDynFlags return (mkIntExpr dflags i) @@ -366,7 +366,7 @@ matchLiterals (var:vars) ty sub_groups = do { -- We now have to convert back to FastString. Perhaps there -- should be separate MachBytes and MachStr constructors? let s' = mkFastStringByteString s - ; lit <- mkStringExprFS s' + ; lit <- mkStringExprFSAtTopLevel s' ; let pred = mkApps (Var eq_str) [Var var, lit] ; return (mkGuardedMatchResult pred mr) } wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l) diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index b8e26b593e..6603abf14a 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -294,11 +294,14 @@ cseProgram binds = snd (mapAccumL (cseBind True) emptyCSEnv binds) cseBind :: Bool -> CSEnv -> CoreBind -> (CSEnv, CoreBind) cseBind toplevel env (NonRec b e) - = (env2, NonRec b2 e1) + = (env2, NonRec b2 e2) where e1 = tryForCSE toplevel env e (env1, b1) = addBinder env b (env2, b2) = addBinding env1 b b1 e1 + e2 -- See Note [Take care with literal strings] + | toplevel && exprIsLiteralString e = e + | otherwise = e1 cseBind _ env (Rec [(in_id, rhs)]) | noCSE in_id @@ -402,9 +405,7 @@ the original RHS unmodified. This produces: -} tryForCSE :: Bool -> CSEnv -> InExpr -> OutExpr -tryForCSE toplevel env expr - | toplevel && exprIsLiteralString expr = expr - -- See Note [Take care with literal strings] +tryForCSE _toplevel env expr | Just e <- lookupCSEnv env expr'' = mkTicks ticks e | otherwise = expr' -- The varToCoreExpr is needed if we have diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 0fe262b2c7..6941f16e15 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -1030,6 +1030,12 @@ Note [Do not inline CoVars unconditionally] Coercion variables appear inside coercions, and the RHS of a let-binding is a term (not a coercion) so we can't necessarily inline the latter in the former. + +Note [Do not inline string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We float out string literals and then common them up. So we must ensure +that preInlineUnconditionally doesn't undo the work of FloatOut by inlining +them right back. -} preInlineUnconditionally :: DynFlags -> SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool @@ -1055,6 +1061,8 @@ preInlineUnconditionally dflags env top_lvl bndr rhs -- See Note [pre/postInlineUnconditionally in gentle mode] act = idInlineActivation bndr try_once in_lam int_cxt -- There's one textual occurrence + -- See Note [Do not inline string literals] + | exprIsLiteralString rhs = False | not in_lam = isNotTopLevel top_lvl || early_phase | otherwise = int_cxt && canInlineInLam rhs diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 67eb982b91..a7c9f57a32 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -381,6 +381,9 @@ data DsGblEnv , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' , ds_complete_matches :: CompleteMatchMap -- Additional complete pattern matches + , ds_top_binds :: Maybe (IORef [CoreBind]) + -- extra top-level bindings added by the desugarer, e.g. string literals and callstacks + -- see Note [Adding Top-Level Bindings in the Desugarer] } type CompleteMatchMap = UniqFM [CompleteMatch] @@ -391,6 +394,47 @@ mkCompleteMatchMap cms = foldl' insertMatch emptyUFM cms insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] +-- Note [Adding Top-Level Bindings in the Desugarer] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Inlining can cause wasteful duplication of constant values like +-- String literals or CallStacks. For example, if we have a function +-- that adds a common prefix to an error message +-- +-- myError msg = error ("some header: " ++ msg) +-- +-- each time GHC inlines myError we will get a duplicate copy of the +-- "some header: " literal, which can lead to a sizeable increase in +-- binary size. +-- +-- But why is this not already solved by FloatOut (which does indeed +-- float such constants to the top)? The issue is that by the time +-- FloatOut runs, myError has already been assigned a StableUnfolding +-- that captures the string. FloatOut won't rewrite the unfolding +-- because GHC promises to inline exactly the code the user wrote. Thus, +-- even though we *have* floated the constant out, we are still forced +-- to duplicate it when myError is inlined into another module, ugh! +-- +-- Rather than changing FloatOut, we give the desugarer the ability to +-- add new top-level bindings (stored in the new ds_top_binds field of +-- the DsGblEnv), and pre-emptively float string literals before the +-- unfoldings are produced. +-- +-- We call the desugarer in two contexts: compiling an entire module, and +-- compiling and individual expression (e.g. for ghci). In the context of +-- an individual expression it makes no sense to add top-level bindings, +-- so the ds_top_binds field is a Maybe. +-- +-- The function DsUtils.bindExprAtTopLevel takes care of determining +-- whether we can actually create a new binding, and returns a Var if +-- able, and the original Expr otherwise. +-- +-- The function DsMonad.withTopBinds initializes the ds_top_binds field +-- to a fresh IORef for the duration of the wrapped action, and returns +-- a pair of the action's result and any added top-level binders. But it +-- only does so if we're compiling with optimizations, otherwise we don't +-- gain anything by pre-emptively floating things and just slow down GHC. +-- (see T1969 for an extreme example) + instance ContainsModule DsGblEnv where extractModule = ds_mod |