diff options
53 files changed, 830 insertions, 275 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 0f3410a66e..ee87ef1b37 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -26,6 +26,7 @@ module CLabel ( mkApEntryLabel, mkApInfoTableLabel, mkClosureTableLabel, + mkBytesLabel, mkLocalClosureLabel, mkLocalInfoTableLabel, @@ -389,6 +390,9 @@ data IdLabelInfo | ClosureTable -- ^ Table of closures for Enum tycons + | Bytes -- ^ Content of a string literal. See + -- Note [Bytes label]. + deriving (Eq, Ord) @@ -474,6 +478,7 @@ mkClosureTableLabel :: Name -> CafInfo -> CLabel mkLocalConInfoTableLabel :: CafInfo -> Name -> CLabel mkLocalConEntryLabel :: CafInfo -> Name -> CLabel mkConInfoTableLabel :: Name -> CafInfo -> CLabel +mkBytesLabel :: Name -> CLabel mkClosureLabel name c = IdLabel name c Closure mkInfoTableLabel name c = IdLabel name c InfoTable mkEntryLabel name c = IdLabel name c Entry @@ -481,6 +486,7 @@ mkClosureTableLabel name c = IdLabel name c ClosureTable mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable mkLocalConEntryLabel c con = IdLabel con c ConEntry mkConInfoTableLabel name c = IdLabel name c ConInfoTable +mkBytesLabel name = IdLabel name NoCafRefs Bytes mkConEntryLabel :: Name -> CafInfo -> CLabel mkConEntryLabel name c = IdLabel name c ConEntry @@ -935,6 +941,7 @@ idInfoLabelType info = ConInfoTable -> DataLabel ClosureTable -> DataLabel RednCounts -> DataLabel + Bytes -> DataLabel _ -> CodeLabel @@ -1056,6 +1063,11 @@ export this because in other modules we either have * A saturated call 'Just x'; allocate using Just_con_info Not exporting these Just_info labels reduces the number of symbols somewhat. + +Note [Bytes label] +~~~~~~~~~~~~~~~~~~ +For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which +points to a static data block containing the content of the literal. -} instance Outputable CLabel where @@ -1234,6 +1246,7 @@ ppIdFlavor x = pp_cSEP <> ConEntry -> text "con_entry" ConInfoTable -> text "con_info" ClosureTable -> text "closure_tbl" + Bytes -> text "bytes" ) diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index b9981f247b..b5e800a977 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -400,7 +400,7 @@ mkProfLits _ (ProfilingInfo td cd) newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt) newStringLit bytes = do { uniq <- getUniqueM - ; return (mkByteStringCLit uniq bytes) } + ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) } -- Misc utils diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 3260cbab2f..1dab6eeff5 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -72,7 +72,6 @@ import Cmm import BlockId import CLabel import Outputable -import Unique import DynFlags import Util import CodeGen.Platform @@ -169,13 +168,13 @@ zeroExpr dflags = CmmLit (zeroCLit dflags) mkWordCLit :: DynFlags -> Integer -> CmmLit mkWordCLit dflags wd = CmmInt wd (wordWidth dflags) -mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) +mkByteStringCLit + :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt) -- We have to make a top-level decl for the string, -- and return a literal pointing to it -mkByteStringCLit uniq bytes - = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) +mkByteStringCLit lbl bytes + = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes]) where - lbl = mkStringLitLabel uniq -- This can not happen for String literals (as there \NUL is replaced by -- C0 80). However, it can happen with Addr# literals. sec = if 0 `elem` bytes then ReadOnlyData else CString diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index bb82da265e..a420677625 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -24,6 +24,7 @@ import StgCmmHpc import StgCmmTicky import Cmm +import CmmUtils import CLabel import StgSyn @@ -45,6 +46,7 @@ import BasicTypes import OrdList import MkGraph +import qualified Data.ByteString as BS import Data.IORef import Control.Monad (when,void) import Util @@ -53,7 +55,7 @@ codeGen :: DynFlags -> Module -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [StgBinding] -- Bindings to convert + -> [StgTopBinding] -- Bindings to convert -> HpcInfo -> Stream IO CmmGroup () -- Output as a stream, so codegen can -- be interleaved with output @@ -113,8 +115,8 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: DynFlags -> StgBinding -> FCode () -cgTopBinding dflags (StgNonRec id rhs) +cgTopBinding :: DynFlags -> StgTopBinding -> FCode () +cgTopBinding dflags (StgTopLifted (StgNonRec id rhs)) = do { id' <- maybeExternaliseId dflags id ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs ; fcode @@ -122,7 +124,7 @@ cgTopBinding dflags (StgNonRec id rhs) -- so we find it when we look up occurrences } -cgTopBinding dflags (StgRec pairs) +cgTopBinding dflags (StgTopLifted (StgRec pairs)) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss @@ -132,6 +134,13 @@ cgTopBinding dflags (StgRec pairs) ; sequence_ fcodes } +cgTopBinding dflags (StgTopStringLit id str) + = do { id' <- maybeExternaliseId dflags id + ; let label = mkBytesLabel (idName id') + ; let (lit, decl) = mkByteStringCLit label (BS.unpack str) + ; emitDecl decl + ; addBindC (litIdInfo dflags id' mkLFStringLit lit) + } cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 3cc0af0669..e799ea6639 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -26,6 +26,7 @@ module StgCmmClosure ( StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkLFStringLit, lfDynTag, maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable, @@ -332,6 +333,10 @@ mkLFImported id where arity = idFunRepArity id +------------- +mkLFStringLit :: LambdaFormInfo +mkLFStringLit = LFUnlifted + ----------------------------------------------------- -- Dynamic pointer tagging ----------------------------------------------------- diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index ba093fee88..3061fb351b 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -40,7 +40,10 @@ import MkGraph import Name import Outputable import StgSyn +import Type +import TysPrim import UniqFM +import Util import VarEnv ------------------------------------- @@ -125,8 +128,15 @@ getCgIdInfo id -- Should be imported; make up a CgIdInfo for it let name = idName id ; if isExternalName name then - let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id) - in return (litIdInfo dflags id (mkLFImported id) ext_lbl) + let ext_lbl + | isUnliftedType (idType id) = + -- An unlifted external Id must refer to a top-level + -- string literal. See Note [Bytes label] in CLabel. + ASSERT( idType id `eqType` addrPrimTy ) + mkBytesLabel name + | otherwise = mkClosureLabel name $ idCafInfo id + in return $ + litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug }}} diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 4a976e68af..295ac15a85 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -322,7 +322,7 @@ newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str) newByteStringCLit :: [Word8] -> FCode CmmLit newByteStringCLit bytes = do { uniq <- newUnique - ; let (lit, decl) = mkByteStringCLit uniq bytes + ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes ; emitDecl decl ; return lit } diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index f9e7f863c4..c09b4a0288 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -30,6 +30,7 @@ import Bag import Literal import DataCon import TysWiredIn +import TysPrim import TcType ( isFloatingTy ) import Var import VarEnv @@ -480,14 +481,25 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check the let/app invariant -- See Note [CoreSyn let/app invariant] in CoreSyn ; checkL (not (isUnliftedType binder_ty) - || (isNonRec rec_flag && exprOkForSpeculation rhs)) + || (isNonRec rec_flag && exprOkForSpeculation rhs) + || exprIsLiteralString rhs) (mkRhsPrimMsg binder rhs) - -- Check that if the binder is top-level or recursive, it's not demanded + -- Check that if the binder is top-level or recursive, it's not + -- demanded. Primitive string literals are exempt as there is no + -- computation to perform, see Note [CoreSyn top-level string literals]. ; checkL (not (isStrictId binder) - || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))) + || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)) + || exprIsLiteralString rhs) (mkStrictMsg binder) + -- Check that if the binder is at the top level and has type Addr#, + -- that it is a string literal, see + -- Note [CoreSyn top-level string literals]. + ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy) + || exprIsLiteralString rhs) + (mkTopNonLitStrMsg binder) + ; flags <- getLintFlags ; when (lf_check_inline_loop_breakers flags && isStrongLoopBreaker (idOccInfo binder) @@ -2033,6 +2045,10 @@ mkNonTopExternalNameMsg :: Id -> MsgDoc mkNonTopExternalNameMsg binder = hsep [text "Non-top-level binder has an external name:", ppr binder] +mkTopNonLitStrMsg :: Id -> MsgDoc +mkTopNonLitStrMsg binder + = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] + mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty = vcat [text "Kinds don't match in type application:", diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index c93a121c23..fb650f61be 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -1168,7 +1168,9 @@ deFloatTop (Floats _ floats) = foldrOL get [] floats where get (FloatLet b) bs = occurAnalyseRHSs b : bs - get b _ = pprPanic "corePrepPgm" (ppr b) + get (FloatCase var body _) bs = + occurAnalyseRHSs (NonRec var body) : bs + get b _ = pprPanic "corePrepPgm" (ppr b) -- See Note [Dead code in CorePrep] occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e) diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index d98536caec..758a17b34d 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -1339,7 +1339,7 @@ than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for --- Integer literals, which are vigorously hoisted to top level +-- Integer and string literals, which are vigorously hoisted to top level -- and not subsequently inlined exprIsLiteral_maybe env@(_, id_unf) e = case e of diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index fd0cf3ed26..4dfd9c3dae 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -191,7 +191,9 @@ These data types are the heart of the compiler -- -- The right hand sides of all top-level and recursive @let@s -- /must/ be of lifted type (see "Type#type_classification" for --- the meaning of /lifted/ vs. /unlifted/). +-- the meaning of /lifted/ vs. /unlifted/). There is one exception +-- to this rule, top-level @let@s are allowed to bind primitive +-- string literals, see Note [CoreSyn top-level string literals]. -- -- See Note [CoreSyn let/app invariant] -- See Note [Levity polymorphism invariants] @@ -361,6 +363,46 @@ Note [CoreSyn letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #letrec_invariant# +Note [CoreSyn top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an exception to the usual rule that top-level binders must be lifted, +we allow binding primitive string literals (of type Addr#) of type Addr# at the +top level. This allows us to share string literals earlier in the pipeline and +crucially allows other optimizations in the Core2Core pipeline to fire. +Consider, + + f n = let a::Addr# = "foo"# + in \x -> blah + +In order to be able to inline `f`, we would like to float `a` to the top. +Another option would be to inline `a`, but that would lead to duplicating string +literals, which we want to avoid. See Trac #8472. + +The solution is simply to allow top-level unlifted binders. We can't allow +arbitrary unlifted expression at the top-level though, unlifted binders cannot +be thunks, so we just allow string literals. + +Also see Note [Compilation plan for top-level string literals]. + +Note [Compilation plan for top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a summary on how top-level string literals are handled by various +parts of the compilation pipeline. + +* In the source language, there is no way to bind a primitive string literal + at the top leve. + +* In Core, we have a special rule that permits top-level Addr# bindings. See + Note [CoreSyn top-level string literals]. Core-to-core passes may introduce + new top-level string literals. + +* In STG, top-level string literals are explicitly represented in the syntax + tree. + +* A top-level string literal may end up exported from a module. In this case, + in the object file, the content of the exported literal is given a label with + the _bytes suffix. + Note [CoreSyn let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The let/app invariant diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 2505fcfff4..b5d248e579 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -29,6 +29,7 @@ module CoreUtils ( exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, + exprIsLiteralString, exprIsTopLevelBindable, -- * Equality cheapEqExpr, cheapEqExpr', eqExpr, @@ -1581,6 +1582,17 @@ tick is there to tell us that the expression was evaluated, so we don't want to discard a seq on it. -} +-- | Can we bind this 'CoreExpr' at the top level? +exprIsTopLevelBindable :: CoreExpr -> Bool +-- See Note [CoreSyn top-level string literals] +exprIsTopLevelBindable expr + = exprIsLiteralString expr + || not (isUnliftedType (exprType expr)) + +exprIsLiteralString :: CoreExpr -> Bool +exprIsLiteralString (Lit (MachStr _)) = True +exprIsLiteralString _ = False + {- ************************************************************************ * * diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs index 817e379003..9eb730ff1a 100644 --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -89,9 +89,10 @@ bcoFreeNames bco -- Top level assembler fn. assembleBCOs - :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> Maybe ModBreaks + :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] + -> Maybe ModBreaks -> IO CompiledByteCode -assembleBCOs hsc_env proto_bcos tycons modbreaks = do +assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do itblenv <- mkITbls hsc_env tycons bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos (bcos',ptrs) <- mallocStrings hsc_env bcos @@ -99,7 +100,7 @@ assembleBCOs hsc_env proto_bcos tycons modbreaks = do { bc_bcos = bcos' , bc_itbls = itblenv , bc_ffis = concat (map protoBCOFFIs proto_bcos) - , bc_strs = ptrs + , bc_strs = top_strs ++ ptrs , bc_breaks = modbreaks } diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index a4373b459f..f4b224d2a5 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, RecordWildCards #-} +{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-} {-# OPTIONS_GHC -fprof-auto-top #-} -- -- (c) The University of Glasgow 2002-2006 @@ -48,6 +48,7 @@ import SMRep import Bitmap import OrdList import Maybes +import VarEnv import Data.List import Foreign @@ -60,6 +61,7 @@ import Control.Arrow ( second ) import Control.Exception import Data.Array +import Data.ByteString (ByteString) import Data.Map (Map) import Data.IntMap (IntMap) import qualified Data.Map as Map @@ -85,12 +87,18 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks = withTiming (pure dflags) (text "ByteCodeGen"<+>brackets (ppr this_mod)) (const ()) $ do - let flatBinds = [ (bndr, simpleFreeVars rhs) - | (bndr, rhs) <- flattenBinds binds] + -- Split top-level binds into strings and others. + -- See Note [generating code for top-level string literal bindings]. + let (strings, flatBinds) = splitEithers $ do + (bndr, rhs) <- flattenBinds binds + return $ case rhs of + Lit (MachStr str) -> Left (bndr, str) + _ -> Right (bndr, simpleFreeVars rhs) + stringPtrs <- allocateTopStrings hsc_env strings us <- mkSplitUniqSupply 'y' (BcM_State{..}, proto_bcos) <- - runBc hsc_env us this_mod mb_modBreaks $ + runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ mapM schemeTopBind flatBinds when (notNull ffis) @@ -99,7 +107,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - cbc <- assembleBCOs hsc_env proto_bcos tycs + cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs) (case modBreaks of Nothing -> Nothing Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }) @@ -116,6 +124,29 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks where dflags = hsc_dflags hsc_env +allocateTopStrings + :: HscEnv + -> [(Id, ByteString)] + -> IO [(Var, RemotePtr ())] +allocateTopStrings hsc_env topStrings = do + let !(bndrs, strings) = unzip topStrings + ptrs <- iservCmd hsc_env $ MallocStrings strings + return $ zip bndrs ptrs + +{- +Note [generating code for top-level string literal bindings] + +Here is a summary on how the byte code generator deals with top-level string +literals: + +1. Top-level string literal bindings are spearted from the rest of the module. + +2. The strings are allocated via iservCmd, in allocateTopStrings + +3. The mapping from binders to allocated strings (topStrings) are maintained in + BcM and used when generating code for variable references. +-} + -- ----------------------------------------------------------------------------- -- Generating byte code for an expression @@ -136,8 +167,8 @@ coreExprToBCOs hsc_env this_mod expr -- the uniques are needed to generate fresh variables when we introduce new -- let bindings for ticked expressions us <- mkSplitUniqSupply 'y' - (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ , proto_bco) - <- runBc hsc_env us this_mod Nothing $ + (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco) + <- runBc hsc_env us this_mod Nothing emptyVarEnv $ schemeTopBind (invented_id, simpleFreeVars expr) when (notNull mallocd) @@ -1356,11 +1387,16 @@ pushAtom d p (AnnVar v) -- slots on to the top of the stack. | otherwise -- v must be a global variable - = do dflags <- getDynFlags - let sz :: Word16 - sz = fromIntegral (idSizeW dflags v) - MASSERT(sz == 1) - return (unitOL (PUSH_G (getName v)), sz) + = do topStrings <- getTopStrings + case lookupVarEnv topStrings v of + Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $ + ptrToWordPtr $ fromRemotePtr ptr + Nothing -> do + dflags <- getDynFlags + let sz :: Word16 + sz = fromIntegral (idSizeW dflags v) + MASSERT(sz == 1) + return (unitOL (PUSH_G (getName v)), sz) pushAtom _ _ (AnnLit lit) = do @@ -1659,6 +1695,8 @@ data BcM_State -- Should be free()d when it is GCd , modBreaks :: Maybe ModBreaks -- info about breakpoints , breakInfo :: IntMap CgBreakInfo + , topStrings :: IdEnv (RemotePtr ()) -- top-level string literals + -- See Note [generating code for top-level string literal bindings]. } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) @@ -1668,10 +1706,12 @@ ioToBc io = BcM $ \st -> do x <- io return (st, x) -runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r +runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks + -> IdEnv (RemotePtr ()) + -> BcM r -> IO (BcM_State, r) -runBc hsc_env us this_mod modBreaks (BcM m) - = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty) +runBc hsc_env us this_mod modBreaks topStrings (BcM m) + = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings) thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do @@ -1746,6 +1786,9 @@ newUnique = BcM $ getCurrentModule :: BcM Module getCurrentModule = BcM $ \st -> return (st, thisModule st) +getTopStrings :: BcM (IdEnv (RemotePtr ())) +getTopStrings = BcM $ \st -> return (st, topStrings st) + newId :: Type -> BcM Id newId ty = do uniq <- newUnique diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index b163cbbe21..092f04c1aa 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1363,7 +1363,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do doCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs - -> [StgBinding] + -> [StgTopBinding] -> HpcInfo -> IO (Stream IO CmmGroup ()) -- Note we produce a 'Stream' of CmmGroups, so that the @@ -1429,7 +1429,7 @@ doCodeGen hsc_env this_mod data_tycons myCoreToStg :: DynFlags -> Module -> CoreProgram - -> IO ( [StgBinding] -- output program + -> IO ( [StgTopBinding] -- output program , CollectedCCs) -- cost centre info (declared and used) myCoreToStg dflags this_mod prepd_binds = do let stg_binds diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs index e98fd9f6a3..c2938c7dfd 100644 --- a/compiler/prelude/PrelRules.hs +++ b/compiler/prelude/PrelRules.hs @@ -987,9 +987,9 @@ builtinRules :: [CoreRule] builtinRules = [BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit }, + ru_nargs = 4, ru_try = match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags }, + ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, @@ -1133,37 +1133,42 @@ builtinIntegerRules = -- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) -- = unpackFoldrCString# "foobaz" c n -match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_append_lit [Type ty1, - Lit (MachStr s1), - c1, - Var unpk `App` Type ty2 - `App` Lit (MachStr s2) - `App` c2 - `App` n - ] +match_append_lit :: RuleFun +match_append_lit _ id_unf _ + [ Type ty1 + , lit1 + , c1 + , Var unpk `App` Type ty2 + `App` lit2 + `App` c2 + `App` n + ] | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 + , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2 = ASSERT( ty1 `eqType` ty2 ) Just (Var unpk `App` Type ty1 `App` Lit (MachStr (s1 `BS.append` s2)) `App` c1 `App` n) -match_append_lit _ = Nothing +match_append_lit _ _ _ _ = Nothing --------------------------------------------------- -- The rule is this: -- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 -match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) -match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] - | unpk1 `hasKey` unpackCStringIdKey, - unpk2 `hasKey` unpackCStringIdKey +match_eq_string :: RuleFun +match_eq_string _ id_unf _ + [Var unpk1 `App` lit1, Var unpk2 `App` lit2] + | unpk1 `hasKey` unpackCStringIdKey + , unpk2 `hasKey` unpackCStringIdKey + , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2 = Just (if s1 == s2 then trueValBool else falseValBool) -match_eq_string _ _ = Nothing +match_eq_string _ _ _ _ = Nothing --------------------------------------------------- diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs index ee37ab14b6..9704e0b132 100644 --- a/compiler/profiling/SCCfinal.hs +++ b/compiler/profiling/SCCfinal.hs @@ -42,8 +42,8 @@ stgMassageForProfiling :: DynFlags -> Module -- module name -> UniqSupply -- unique supply - -> [StgBinding] -- input - -> (CollectedCCs, [StgBinding]) + -> [StgTopBinding] -- input + -> (CollectedCCs, [StgTopBinding]) stgMassageForProfiling dflags mod_name _us stg_binds = let @@ -69,24 +69,28 @@ stgMassageForProfiling dflags mod_name _us stg_binds all_cafs_ccs = mkSingletonCCS all_cafs_cc ---------- - do_top_bindings :: [StgBinding] -> MassageM [StgBinding] + do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding] do_top_bindings [] = return [] - do_top_bindings (StgNonRec b rhs : bs) = do + do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do rhs' <- do_top_rhs b rhs bs' <- do_top_bindings bs - return (StgNonRec b rhs' : bs') + return (StgTopLifted (StgNonRec b rhs') : bs') - do_top_bindings (StgRec pairs : bs) = do + do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do pairs2 <- mapM do_pair pairs bs' <- do_top_bindings bs - return (StgRec pairs2 : bs') + return (StgTopLifted (StgRec pairs2) : bs') where do_pair (b, rhs) = do rhs2 <- do_top_rhs b rhs return (b, rhs2) + do_top_bindings (b@StgTopStringLit{} : bs) = do + bs' <- do_top_bindings bs + return (b : bs') + ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs index 54fbc5008c..e364c31cdc 100644 --- a/compiler/simplCore/CSE.hs +++ b/compiler/simplCore/CSE.hs @@ -15,6 +15,7 @@ import Var ( Var ) import Id ( Id, idType, idUnfolding, idInlineActivation , zapIdOccInfo, zapIdUsageInfo ) import CoreUtils ( mkAltExpr + , exprIsLiteralString , stripTicksE, stripTicksT, mkTicks ) import Literal ( litIsTrivial ) import Type ( tyConAppArgs ) @@ -253,22 +254,22 @@ had -} cseProgram :: CoreProgram -> CoreProgram -cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds) +cseProgram binds = snd (mapAccumL (cseBind True) emptyCSEnv binds) -cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) +cseBind :: Bool -> CSEnv -> CoreBind -> (CSEnv, CoreBind) +cseBind toplevel env (NonRec b e) = (env2, NonRec b2 e1) where - e1 = tryForCSE env e + e1 = tryForCSE toplevel env e (env1, b1) = addBinder env b (env2, b2) = addBinding env1 b b1 e1 -cseBind env (Rec pairs) +cseBind toplevel env (Rec pairs) = (env2, Rec pairs') where (bndrs, rhss) = unzip pairs (env1, bndrs1) = addRecBinders env bndrs - rhss1 = map (tryForCSE env1) rhss + rhss1 = map (tryForCSE toplevel env1) rhss -- Process rhss in extended env1 (env2, pairs') = foldl do_one (env1, []) (zip3 bndrs bndrs1 rhss1) do_one (env, pairs) (b, b1, e1) @@ -311,8 +312,38 @@ addBinding env in_id out_id rhs' Lit l -> litIsTrivial l _ -> False -tryForCSE :: CSEnv -> InExpr -> OutExpr -tryForCSE env expr +{- +Note [Take care with literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider this example: + + x = "foo"# + y = "foo"# + ...x...y...x...y.... + +We would normally turn this into: + + x = "foo"# + y = x + ...x...x...x...x.... + +But this breaks an invariant of Core, namely that the RHS of a top-level binding +of type Addr# must be a string literal, not another variable. See Note +[CoreSyn top-level string literals] in CoreSyn. + +For this reason, we special case top-level bindings to literal strings and leave +the original RHS unmodified. This produces: + + x = "foo"# + y = "foo"# + ...x...x...x...x.... +-} + +tryForCSE :: Bool -> CSEnv -> InExpr -> OutExpr +tryForCSE toplevel env expr + | toplevel && exprIsLiteralString expr = expr + -- See Note [Take care with literal strings] | Just e <- lookupCSEnv env expr'' = mkTicks ticks e | otherwise = expr' -- The varToCoreExpr is needed if we have @@ -333,12 +364,12 @@ cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = lookupSubst env v -cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) +cseExpr env (App f a) = App (cseExpr env f) (tryForCSE False env a) cseExpr env (Tick t e) = Tick t (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) cseExpr env (Lam b e) = let (env', b') = addBinder env b in Lam b' (cseExpr env' e) -cseExpr env (Let bind e) = let (env', bind') = cseBind env bind +cseExpr env (Let bind e) = let (env', bind') = cseBind False env bind in Let bind' (cseExpr env' e) cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts @@ -346,7 +377,7 @@ cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr cseCase env scrut bndr ty alts = Case scrut1 bndr3 ty (map cse_alt alts) where - scrut1 = tryForCSE env scrut + scrut1 = tryForCSE False env scrut bndr1 = zapIdOccInfo bndr -- Zapping the OccInfo is needed because the extendCSEnv @@ -369,14 +400,14 @@ cseCase env scrut bndr ty alts -- case x of { True -> ....True.... } -- Don't replace True by x! -- Hence the 'null args', which also deal with literals and DEFAULT - = (DataAlt con, args', tryForCSE new_env rhs) + = (DataAlt con, args', tryForCSE False new_env rhs) where (env', args') = addBinders alt_env args new_env = extendCSEnv env' con_expr con_target con_expr = mkAltExpr (DataAlt con) args' arg_tys cse_alt (con, args, rhs) - = (con, args', tryForCSE env' rhs) + = (con, args', tryForCSE False env' rhs) where (env', args') = addBinders alt_env args diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 0b81f29a7d..955d3ba89d 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -67,6 +67,7 @@ import CoreMonad ( FloatOutSwitches(..) ) import CoreUtils ( exprType , isExprLevPoly , exprOkForSpeculation + , exprIsTopLevelBindable , collectMakeStaticArgs ) import CoreArity ( exprBotStrictness_maybe ) @@ -494,7 +495,7 @@ lvlMFE strict_ctxt env ann_expr lvlExpr env ann_expr | Just (wrap_float, wrap_use) - <- canFloat_maybe rhs_env strict_ctxt float_is_lam expr_ty + <- canFloat_maybe rhs_env strict_ctxt float_is_lam expr = do { expr1 <- lvlExpr rhs_env ann_expr ; let abs_expr = mkLams abs_vars_w_lvls (wrap_float expr1) ; var <- newLvlVar abs_expr @@ -507,7 +508,6 @@ lvlMFE strict_ctxt env ann_expr where expr = deAnnotate ann_expr - expr_ty = exprType expr fvs = freeVarsOf ann_expr is_bot = isJust mb_bot_str mb_bot_str = exprBotStrictness_maybe expr @@ -544,12 +544,12 @@ lvlMFE strict_ctxt env ann_expr canFloat_maybe :: LevelEnv -> Bool -- Strict context -> Bool -- The float has a value lambda - -> Type + -> CoreExpr -> Maybe ( LevelledExpr -> LevelledExpr -- Wrep the flaot , LevelledExpr -> LevelledExpr) -- Wrap the use -- See Note [Floating MFEs of unlifted type] -canFloat_maybe env strict_ctxt float_is_lam expr_ty - | float_is_lam || not (isUnliftedType expr_ty) +canFloat_maybe env strict_ctxt float_is_lam expr + | float_is_lam || exprIsTopLevelBindable expr = Just (id, id) -- No wrapping needed if the type is lifted, or -- if we are wrapping it in one or more value lambdas @@ -568,6 +568,7 @@ canFloat_maybe env strict_ctxt float_is_lam expr_ty | otherwise -- e.g. do not float unboxed tuples = Nothing + where expr_ty = exprType expr {- Note [Floating MFEs of unlifted type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs index 8a26220029..99d8291491 100644 --- a/compiler/simplCore/SimplEnv.hs +++ b/compiler/simplCore/SimplEnv.hs @@ -332,7 +332,8 @@ data Floats = Floats (OrdList OutBind) FloatFlag -- See Note [Simplifier floats] data FloatFlag - = FltLifted -- All bindings are lifted and lazy + = FltLifted -- All bindings are lifted and lazy *or* + -- consist of a single primitive string literal -- Hence ok to float to top level, or recursive | FltOkSpec -- All bindings are FltLifted *or* @@ -395,6 +396,9 @@ unitFloat bind = Floats (unitOL bind) (flag bind) flag (Rec {}) = FltLifted flag (NonRec bndr rhs) | not (isStrictId bndr) = FltLifted + | exprIsLiteralString rhs = FltLifted + -- String literals can be floated freely. + -- See Note [CoreSyn top-level string ltierals] in CoreSyn. | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) | otherwise = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr ) FltCareful diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 2c8ff5e941..9e5c00d284 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -581,7 +581,7 @@ makeTrivialWithInfo :: TopLevelFlag -> SimplEnv -- Returned SimplEnv has same substitution as incoming one makeTrivialWithInfo top_lvl env context info expr | exprIsTrivial expr -- Already trivial - || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise + || not (bindingOk top_lvl expr) -- Cannot trivialise -- See Note [Cannot trivialise] = return (env, expr) | otherwise -- See Note [Take care] below @@ -603,11 +603,11 @@ makeTrivialWithInfo top_lvl env context info expr where expr_ty = exprType expr -bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool +bindingOk :: TopLevelFlag -> CoreExpr -> Bool -- True iff we can have a binding of this expression at this level -- Precondition: the type is the type of the expression -bindingOk top_lvl _ expr_ty - | isTopLevel top_lvl = not (isUnliftedType expr_ty) +bindingOk top_lvl expr + | isTopLevel top_lvl = exprIsTopLevelBindable expr | otherwise = True {- @@ -626,12 +626,16 @@ so we don't want to turn it into because we'll just end up inlining x back, and that makes the simplifier loop. Better not to ANF-ise it at all. -A case in point is literal strings (a MachStr is not regarded as -trivial): +Literal strings are an exception. foo = Ptr "blob"# -We don't want to ANF-ise this. +We want to turn this into: + + foo1 = "blob"# + foo = Ptr foo1 + +See Note [CoreSyn top-level string literals] in CoreSyn. ************************************************************************ * * diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs index 406e415287..08f9d79782 100644 --- a/compiler/simplStg/SimplStg.hs +++ b/compiler/simplStg/SimplStg.hs @@ -14,7 +14,7 @@ import StgSyn import CostCentre ( CollectedCCs ) import SCCfinal ( stgMassageForProfiling ) -import StgLint ( lintStgBindings ) +import StgLint ( lintStgTopBindings ) import StgStats ( showStgStats ) import UnariseStg ( unarise ) import StgCse ( stgCse ) @@ -29,8 +29,8 @@ import Control.Monad stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module name (profiling only) - -> [StgBinding] -- input... - -> IO ( [StgBinding] -- output program... + -> [StgTopBinding] -- input... + -> IO ( [StgTopBinding] -- output program... , CollectedCCs) -- cost centre information (declared and used) stg2stg dflags module_name binds @@ -48,19 +48,19 @@ stg2stg dflags module_name binds <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags) ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:" - (pprStgBindings processed_binds) + (pprStgTopBindings processed_binds) ; let un_binds = unarise us1 processed_binds ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" - (pprStgBindings un_binds) + (pprStgTopBindings un_binds) ; return (un_binds, cost_centres) } where stg_linter = if gopt Opt_DoStgLinting dflags - then lintStgBindings + then lintStgTopBindings else ( \ _whodunnit binds -> binds ) ------------------------------------------- diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs index 7454d24a2c..3e141439ed 100644 --- a/compiler/simplStg/StgCse.hs +++ b/compiler/simplStg/StgCse.hs @@ -240,7 +240,7 @@ substPairs env bndrs = mapAccumL go env bndrs -- Main entry point -stgCse :: [InStgBinding] -> [OutStgBinding] +stgCse :: [InStgTopBinding] -> [OutStgTopBinding] stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds -- Top level bindings. @@ -250,15 +250,16 @@ stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds -- But we still have to collect the set of in-scope variables, otherwise -- uniqAway might shadow a top-level closure. -stgCseTopLvl :: InScopeSet -> InStgBinding -> (InScopeSet, OutStgBinding) -stgCseTopLvl in_scope (StgNonRec bndr rhs) +stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding) +stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t) +stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs)) = (in_scope' - , StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)) + , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs))) where in_scope' = in_scope `extendInScopeSet` bndr -stgCseTopLvl in_scope (StgRec eqs) +stgCseTopLvl in_scope (StgTopLifted (StgRec eqs)) = ( in_scope' - , StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]) + , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ])) where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs index 38544822d2..3f75ae23fa 100644 --- a/compiler/simplStg/StgStats.hs +++ b/compiler/simplStg/StgStats.hs @@ -75,7 +75,7 @@ countN = Map.singleton ************************************************************************ -} -showStgStats :: [StgBinding] -> String +showStgStats :: [StgTopBinding] -> String showStgStats prog = "STG Statistics:\n\n" @@ -99,10 +99,8 @@ showStgStats prog s (SingleEntryBinds _) = "SingleEntryBinds_Nested " s (UpdatableBinds _) = "UpdatableBinds_Nested " -gatherStgStats :: [StgBinding] -> StatEnv - -gatherStgStats binds - = combineSEs (map (statBinding True{-top-level-}) binds) +gatherStgStats :: [StgTopBinding] -> StatEnv +gatherStgStats binds = combineSEs (map statTopBinding binds) {- ************************************************************************ @@ -112,6 +110,10 @@ gatherStgStats binds ************************************************************************ -} +statTopBinding :: StgTopBinding -> StatEnv +statTopBinding (StgTopStringLit _ _) = countOne Literals +statTopBinding (StgTopLifted bind) = statBinding True bind + statBinding :: Bool -- True <=> top-level; False <=> nested -> StgBinding -> StatEnv diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index aa42586cd1..3f67bc278f 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -264,8 +264,13 @@ extendRho rho x (UnaryVal val) -------------------------------------------------------------------------------- -unarise :: UniqSupply -> [StgBinding] -> [StgBinding] -unarise us binds = initUs_ us (mapM (unariseBinding emptyVarEnv) binds) +unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] +unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) + +unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding +unariseTopBinding rho (StgTopLifted bind) + = StgTopLifted <$> unariseBinding rho bind +unariseTopBinding _ bind@StgTopStringLit{} = return bind unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding unariseBinding rho (StgNonRec x rhs) diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index dcb923afea..37df9e2146 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -196,7 +196,7 @@ import Control.Monad (liftM, ap) -- Setting variable info: top-level, binds, RHSs -- -------------------------------------------------------------- -coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding] +coreToStg :: DynFlags -> Module -> CoreProgram -> [StgTopBinding] coreToStg dflags this_mod pgm = pgm' where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm @@ -211,7 +211,7 @@ coreTopBindsToStg -> Module -> IdEnv HowBound -- environment for the bindings -> CoreProgram - -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) + -> (IdEnv HowBound, FreeVarsInfo, [StgTopBinding]) coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, []) coreTopBindsToStg dflags this_mod env (b:bs) @@ -229,7 +229,14 @@ coreTopBindToStg -> IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind - -> (IdEnv HowBound, FreeVarsInfo, StgBinding) + -> (IdEnv HowBound, FreeVarsInfo, StgTopBinding) + +coreTopBindToStg _ _ env body_fvs (NonRec id (Lit (MachStr str))) + -- top-level string literal + = let + env' = extendVarEnv env id how_bound + how_bound = LetBound TopLet 0 + in (env', body_fvs, StgTopStringLit id str) coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs) = let @@ -241,7 +248,7 @@ coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs) (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs) return (stg_rhs, fvs') - bind = StgNonRec id stg_rhs + bind = StgTopLifted $ StgNonRec id stg_rhs in ASSERT2(consistentCafInfo id bind, ppr id ) -- NB: previously the assertion printed 'rhs' and 'bind' @@ -265,7 +272,7 @@ coreTopBindToStg dflags this_mod env body_fvs (Rec pairs) let fvs' = unionFVInfos fvss' return (stg_rhss, fvs') - bind = StgRec (zip binders stg_rhss) + bind = StgTopLifted $ StgRec (zip binders stg_rhss) in ASSERT2(consistentCafInfo (head binders) bind, ppr binders) (env', fvs' `unionFVInfo` body_fvs, bind) @@ -275,7 +282,7 @@ coreTopBindToStg dflags this_mod env body_fvs (Rec pairs) -- what CoreToStg has figured out about the binding's SRT. The -- CafInfo will be exact in all cases except when CorePrep has -- floated out a binding, in which case it will be approximate. -consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool +consistentCafInfo :: Id -> GenStgTopBinding Var Id -> Bool consistentCafInfo id bind = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) safe diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index e31e7ae015..02d989cec0 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} -module StgLint ( lintStgBindings ) where +module StgLint ( lintStgTopBindings ) where import StgSyn @@ -54,12 +54,12 @@ generation. Solution: don't use it! (KSW 2000-05). * * ************************************************************************ -@lintStgBindings@ is the top-level interface function. +@lintStgTopBindings@ is the top-level interface function. -} -lintStgBindings :: String -> [StgBinding] -> [StgBinding] +lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding] -lintStgBindings whodunnit binds +lintStgTopBindings whodunnit binds = {-# SCC "StgLint" #-} case (initL (lint_binds binds)) of Nothing -> binds @@ -68,17 +68,20 @@ lintStgBindings whodunnit binds text whodunnit <+> text "***", msg, text "*** Offending Program ***", - pprStgBindings binds, + pprStgTopBindings binds, text "*** End of Offense ***"]) where - lint_binds :: [StgBinding] -> LintM () + lint_binds :: [StgTopBinding] -> LintM () lint_binds [] = return () lint_binds (bind:binds) = do - binders <- lintStgBinds bind + binders <- lint_bind bind addInScopeVars binders $ lint_binds binds + lint_bind (StgTopLifted bind) = lintStgBinds bind + lint_bind (StgTopStringLit v _) = return [v] + lintStgArg :: StgArg -> LintM (Maybe Type) lintStgArg (StgLitArg lit) = return (Just (literalType lit)) lintStgArg (StgVarArg v) = lintStgVar v diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 48e836cc56..56978f868c 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -14,7 +14,7 @@ generation. module StgSyn ( GenStgArg(..), - GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgAlt, AltType(..), UpdateFlag(..), isUpdatable, @@ -24,11 +24,12 @@ module StgSyn ( combineStgBinderInfo, -- a set of synonyms for the most common (only :-) parameterisation - StgArg, StgBinding, StgExpr, StgRhs, StgAlt, + StgArg, + StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, -- a set of synonyms to distinguish in- and out variants - InStgArg, InStgBinding, InStgExpr, InStgRhs, InStgAlt, - OutStgArg, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, + InStgArg, InStgTopBinding, InStgBinding, InStgExpr, InStgRhs, InStgAlt, + OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt, -- StgOp StgOp(..), @@ -39,13 +40,14 @@ module StgSyn ( stgArgType, stripStgTicksTop, - pprStgBinding, pprStgBindings + pprStgBinding, pprStgTopBindings ) where #include "HsVersions.h" import CoreSyn ( AltCon, Tickish ) import CostCentre ( CostCentreStack ) +import Data.ByteString ( ByteString ) import Data.List ( intersperse ) import DataCon import DynFlags @@ -79,6 +81,12 @@ with respect to binder and occurrence information (just as in @CoreSyn@): -} +-- | A top-level binding. +data GenStgTopBinding bndr occ +-- See Note [CoreSyn top-level string literals] + = StgTopLifted (GenStgBinding bndr occ) + | StgTopStringLit bndr ByteString + data GenStgBinding bndr occ = StgNonRec bndr (GenStgRhs bndr occ) | StgRec [(bndr, GenStgRhs bndr occ)] @@ -421,11 +429,13 @@ stgRhsArity (StgRhsCon _ _ _) = 0 -- is that `TidyPgm` computed the CAF info on the `Id` but some transformations -- have taken place since then. -topStgBindHasCafRefs :: GenStgBinding bndr Id -> Bool -topStgBindHasCafRefs (StgNonRec _ rhs) +topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool +topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs)) = topRhsHasCafRefs rhs -topStgBindHasCafRefs (StgRec binds) +topStgBindHasCafRefs (StgTopLifted (StgRec binds)) = any topRhsHasCafRefs (map snd binds) +topStgBindHasCafRefs StgTopStringLit{} + = False topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body) @@ -550,6 +560,7 @@ data AltType This happens to be the only one we use at the moment. -} +type StgTopBinding = GenStgTopBinding Id Id type StgBinding = GenStgBinding Id Id type StgArg = GenStgArg Id type StgExpr = GenStgExpr Id Id @@ -561,16 +572,18 @@ type StgAlt = GenStgAlt Id Id See CoreSyn for precedence in Core land -} -type InStgBinding = StgBinding -type InStgArg = StgArg -type InStgExpr = StgExpr -type InStgRhs = StgRhs -type InStgAlt = StgAlt -type OutStgBinding = StgBinding -type OutStgArg = StgArg -type OutStgExpr = StgExpr -type OutStgRhs = StgRhs -type OutStgAlt = StgAlt +type InStgTopBinding = StgTopBinding +type InStgBinding = StgBinding +type InStgArg = StgArg +type InStgExpr = StgExpr +type InStgRhs = StgRhs +type InStgAlt = StgAlt +type OutStgTopBinding = StgTopBinding +type OutStgBinding = StgBinding +type OutStgArg = StgArg +type OutStgExpr = StgExpr +type OutStgRhs = StgRhs +type OutStgAlt = StgAlt {- @@ -635,6 +648,15 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. -} +pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) + => GenStgTopBinding bndr bdee -> SDoc + +pprGenStgTopBinding (StgTopStringLit bndr str) + = hang (hsep [pprBndr LetBind bndr, equals]) + 4 (pprHsBytes str <> semi) +pprGenStgTopBinding (StgTopLifted bind) + = pprGenStgBinding bind + pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee) => GenStgBinding bndr bdee -> SDoc @@ -653,13 +675,18 @@ pprGenStgBinding (StgRec pairs) pprStgBinding :: StgBinding -> SDoc pprStgBinding bind = pprGenStgBinding bind -pprStgBindings :: [StgBinding] -> SDoc -pprStgBindings binds = vcat $ intersperse blankLine (map pprGenStgBinding binds) +pprStgTopBindings :: [StgTopBinding] -> SDoc +pprStgTopBindings binds + = vcat $ intersperse blankLine (map pprGenStgTopBinding binds) instance (Outputable bdee) => Outputable (GenStgArg bdee) where ppr = pprStgArg instance (OutputableBndr bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgTopBinding bndr bdee) where + ppr = pprGenStgTopBinding + +instance (OutputableBndr bndr, Outputable bdee, Ord bdee) => Outputable (GenStgBinding bndr bdee) where ppr = pprGenStgBinding diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng index f9db420857..623ba0e596 100644 --- a/docs/core-spec/core-spec.mng +++ b/docs/core-spec/core-spec.mng @@ -100,7 +100,9 @@ The datatype that represents expressions: There are a few key invariants about expressions: \begin{itemize} \item The right-hand sides of all top-level and recursive $[[let]]$s -must be of lifted type. +must be of lifted type, with one exception: the right-hand side of a top-level +$[[let]]$ may be of type \texttt{Addr#} if it's a primitive string literal. +See \verb|#top_level_invariant#| in \ghcfile{coreSyn/CoreSyn.hs}. \item The right-hand side of a non-recursive $[[let]]$ and the argument of an application may be of unlifted type, but only if the expression is ok-for-speculation. See \verb|#let_app_invariant#| in \ghcfile{coreSyn/CoreSyn.lhs}. diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 797c6c7776..a8da44b73f 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 36, types: 30, coercions: 1} +Result size of Tidy Core = {terms: 44, types: 34, coercions: 1} -- RHS size: {terms: 2, types: 4, coercions: 1} T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a @@ -21,25 +21,40 @@ absurd :: forall a. (Int :~: Bool) -> a [GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x] absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { } --- RHS size: {terms: 2, types: 0, coercions: 0} -$trModule1 :: GHC.Types.TrName +-- RHS size: {terms: 1, types: 0, coercions: 0} +$trModule1 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs] -$trModule1 = GHC.Types.TrNameS "main"# +$trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} $trModule2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$trModule2 = GHC.Types.TrNameS "T2431"# +$trModule2 = GHC.Types.TrNameS $trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$trModule3 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$trModule3 = "T2431"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule4 :: GHC.Types.TrName +[GblId, Caf=NoCafRefs] +$trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0} T2431.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs] -T2431.$trModule = GHC.Types.Module $trModule1 $trModule2 +T2431.$trModule = GHC.Types.Module $trModule2 $trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$tc'Refl1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tc'Refl1 = "'Refl"# -- RHS size: {terms: 2, types: 0, coercions: 0} -$tc'Refl1 :: GHC.Types.TrName +$tc'Refl2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tc'Refl1 = GHC.Types.TrNameS "'Refl"# +$tc'Refl2 = GHC.Types.TrNameS $tc'Refl1 -- RHS size: {terms: 5, types: 0, coercions: 0} T2431.$tc'Refl :: GHC.Types.TyCon @@ -49,12 +64,17 @@ T2431.$tc'Refl = 15026191172322750497## 3898273167927206410## T2431.$trModule - $tc'Refl1 + $tc'Refl2 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$tc:~:1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tc:~:1 = ":~:"# -- RHS size: {terms: 2, types: 0, coercions: 0} -$tc:~:1 :: GHC.Types.TrName +$tc:~:2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tc:~:1 = GHC.Types.TrNameS ":~:"# +$tc:~:2 = GHC.Types.TrNameS $tc:~:1 -- RHS size: {terms: 5, types: 0, coercions: 0} T2431.$tc:~: :: GHC.Types.TyCon @@ -64,7 +84,7 @@ T2431.$tc:~: = 9759653149176674453## 12942818337407067047## T2431.$trModule - $tc:~:1 + $tc:~:2 diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 9f7837bdc7..7fe4d93d87 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -1,15 +1,31 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 46, types: 23, coercions: 0} +Result size of Tidy Core = {terms: 50, types: 25, coercions: 0} + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7116.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T7116.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T7116.$trModule2 :: GHC.Types.TrName +T7116.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T7116.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7116.$trModule3 = GHC.Types.TrNameS T7116.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7116.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T7116.$trModule2 = "T7116"# -- RHS size: {terms: 2, types: 0, coercions: 0} T7116.$trModule1 :: GHC.Types.TrName @@ -17,8 +33,8 @@ T7116.$trModule1 :: GHC.Types.TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T7116.$trModule1 = GHC.Types.TrNameS "T7116"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7116.$trModule1 = GHC.Types.TrNameS T7116.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} T7116.$trModule :: GHC.Types.Module @@ -28,7 +44,7 @@ T7116.$trModule :: GHC.Types.Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T7116.$trModule = - GHC.Types.Module T7116.$trModule2 T7116.$trModule1 + GHC.Types.Module T7116.$trModule3 T7116.$trModule1 -- RHS size: {terms: 8, types: 3, coercions: 0} dr :: Double -> Double diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 499650bd69..797cbd9d94 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -39,7 +39,7 @@ test('T1969', # 2013-11-13 17 (x86/Windows, 64bit machine) # 2015-07-11 21 (x86/Linux, 64bit machine) use +RTS -G1 # 2016-04-06 30 (x86/Linux, 64bit machine) - (wordsize(64), 55, 20)]), + (wordsize(64), 68, 20)]), # 28 (amd64/Linux) # 34 (amd64/Linux) # 2012-09-20 23 (amd64/Linux) @@ -51,6 +51,8 @@ test('T1969', # 2013-09-11 30, 15 (adapt to Phab CI) # 2015-06-03 41, (amd64/Linux) use +RTS -G1 # 2015-10-28 55, (amd64/Linux) emit Typeable at definition site + # 2016-10-20 68, (amd64/Linux) allow top-level string literals + # See the comment 16 on #8472. compiler_stats_num_field('max_bytes_used', [(platform('i386-unknown-mingw32'), 5719436, 20), # 2010-05-17 5717704 (x86/Windows) @@ -827,7 +829,7 @@ test('T9233', test('T10370', [ only_ways(['optasm']), compiler_stats_num_field('max_bytes_used', # Note [residency] - [(wordsize(64), 33049168, 15), + [(wordsize(64), 38221184, 15), # 2015-10-22 19548720 # 2016-02-24 22823976 Changing Levity to RuntimeRep; not sure why this regresses though, even after some analysis # 2016-04-14 28256896 final demand analyzer run @@ -838,14 +840,17 @@ test('T10370', # affected stats on bootstrapped GHC. However, # when I set -i0.01 with profiling, the heap profiles # were identical, so I think it's just GC noise. + # 2016-10-20 38221184 Allow top-level string literals. + # See the comment 16 on #8472. (wordsize(32), 11371496, 15), # 2015-10-22 11371496 ]), compiler_stats_num_field('peak_megabytes_allocated', # Note [residency] - [(wordsize(64), 121, 15), + [(wordsize(64), 146, 15), # 2015-10-22 76 # 2016-04-14 101 final demand analyzer run # 2016-08-08 121 see above + # 2017-01-18 146 Allow top-level string literals in Core (wordsize(32), 39, 15), # 2015-10-22 39 ]), @@ -883,8 +888,9 @@ test('T12227', test('T12425', [ only_ways(['optasm']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 125831400, 5), + [(wordsize(64), 133380960, 5), # initial: 125831400 + # 2017-01-18: 133380960 Allow top-level string literals in Core ]), ], compile, @@ -906,8 +912,9 @@ test('T12234', test('T13035', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 90595208, 5), + [(wordsize(64), 95269000, 5), # 2017-01-05 90595208 initial + # 2017-01-19 95269000 Allow top-level string literals in Core ]), ], compile, diff --git a/testsuite/tests/perf/should_run/T8472.hs b/testsuite/tests/perf/should_run/T8472.hs new file mode 100644 index 0000000000..24f0ec7811 --- /dev/null +++ b/testsuite/tests/perf/should_run/T8472.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE MagicHash #-} + +module Main (f, main) where + +import GHC.Exts(Ptr(..)) +import Foreign.Ptr + +-- We should be able to inline this function. +f :: Ptr Int -> Int -> Int +f = + let x = "foo"# + in \p n -> n + (Ptr x `minusPtr` p) + +main :: IO () +main = print $ x `mod` 2 == (x + 4) `mod` 2 + where + x = go (10000::Int) 4 + go 0 a = a + go n a = go (n-1) (f nullPtr a) diff --git a/testsuite/tests/perf/should_run/T8472.stdout b/testsuite/tests/perf/should_run/T8472.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/perf/should_run/T8472.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 333970ca57..1560e7ea2e 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -446,6 +446,14 @@ test('T9339', compile_and_run, ['-O2']) +test('T8472', + [stats_num_field('bytes allocated', + [ (wordsize(32), 50000, 80) + , (wordsize(64), 51424, 80) ]), + only_ways(['normal'])], + compile_and_run, + ['-O2']) + test('T12996', [stats_num_field('bytes allocated', [ (wordsize(64), 76776, 5) ]), diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T index 9acd157543..56a58cb586 100644 --- a/testsuite/tests/perf/space_leaks/all.T +++ b/testsuite/tests/perf/space_leaks/all.T @@ -64,7 +64,7 @@ test('T4029', # 2016-07-13: 92 (amd64/Linux) Changes to tidyType # 2016-09-01: 71 (amd64/Linux) Restore w/w limit (#11565) stats_num_field('max_bytes_used', - [(wordsize(64), 21387048 , 5)]), + [(wordsize(64), 21670448 , 5)]), # 2016-02-26: 24071720 (amd64/Linux) INITIAL # 2016-04-21: 25542832 (amd64/Linux) # 2016-05-23: 25247216 (amd64/Linux) Use -G1 @@ -73,6 +73,7 @@ test('T4029', # 2016-09-01: 21648488 (amd64/Linux) Restore w/w limit (#11565) # 2016-10-13: 20325248 (amd64/Linux) Creep (downwards, yay!) # 2016-11-14: 21387048 (amd64/Linux) Creep back upwards :( + # 2017-01-18: 21670448 (amd64/Linux) Float string literals to toplevel extra_hc_opts('+RTS -G1 -RTS' ), ], ghci_script, diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index f74c3abbb9..20206e28df 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 51, types: 20, coercions: 5} +Result size of Tidy Core = {terms: 63, types: 26, coercions: 5} -- RHS size: {terms: 2, types: 2, coercions: 0} convert1 :: Wrap Age -> Wrap Age @@ -15,25 +15,40 @@ convert = `cast` (<Wrap Age>_R -> Roles13.N:Wrap[0] Roles13.N:Age[0] :: ((Wrap Age -> Wrap Age) :: *) ~R# ((Wrap Age -> Int) :: *)) --- RHS size: {terms: 2, types: 0, coercions: 0} -$trModule1 :: GHC.Types.TrName +-- RHS size: {terms: 1, types: 0, coercions: 0} +$trModule1 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs] -$trModule1 = GHC.Types.TrNameS "main"# +$trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} $trModule2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$trModule2 = GHC.Types.TrNameS "Roles13"# +$trModule2 = GHC.Types.TrNameS $trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$trModule3 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$trModule3 = "Roles13"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule4 :: GHC.Types.TrName +[GblId, Caf=NoCafRefs] +$trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0} Roles13.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs] -Roles13.$trModule = GHC.Types.Module $trModule1 $trModule2 +Roles13.$trModule = GHC.Types.Module $trModule2 $trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$tc'MkAge1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tc'MkAge1 = "'MkAge"# -- RHS size: {terms: 2, types: 0, coercions: 0} -$tc'MkAge1 :: GHC.Types.TrName +$tc'MkAge2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tc'MkAge1 = GHC.Types.TrNameS "'MkAge"# +$tc'MkAge2 = GHC.Types.TrNameS $tc'MkAge1 -- RHS size: {terms: 5, types: 0, coercions: 0} Roles13.$tc'MkAge :: GHC.Types.TyCon @@ -43,12 +58,17 @@ Roles13.$tc'MkAge = 1226019810264079099## 12180888342844277416## Roles13.$trModule - $tc'MkAge1 + $tc'MkAge2 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$tcAge1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tcAge1 = "Age"# -- RHS size: {terms: 2, types: 0, coercions: 0} -$tcAge1 :: GHC.Types.TrName +$tcAge2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tcAge1 = GHC.Types.TrNameS "Age"# +$tcAge2 = GHC.Types.TrNameS $tcAge1 -- RHS size: {terms: 5, types: 0, coercions: 0} Roles13.$tcAge :: GHC.Types.TyCon @@ -58,12 +78,17 @@ Roles13.$tcAge = 18304088376370610314## 1954648846714895105## Roles13.$trModule - $tcAge1 + $tcAge2 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$tc'MkWrap1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tc'MkWrap1 = "'MkWrap"# -- RHS size: {terms: 2, types: 0, coercions: 0} -$tc'MkWrap1 :: GHC.Types.TrName +$tc'MkWrap2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tc'MkWrap1 = GHC.Types.TrNameS "'MkWrap"# +$tc'MkWrap2 = GHC.Types.TrNameS $tc'MkWrap1 -- RHS size: {terms: 5, types: 0, coercions: 0} Roles13.$tc'MkWrap :: GHC.Types.TyCon @@ -73,12 +98,17 @@ Roles13.$tc'MkWrap = 12402878715225676312## 13345418993613492500## Roles13.$trModule - $tc'MkWrap1 + $tc'MkWrap2 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$tcWrap1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tcWrap1 = "Wrap"# -- RHS size: {terms: 2, types: 0, coercions: 0} -$tcWrap1 :: GHC.Types.TrName +$tcWrap2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tcWrap1 = GHC.Types.TrNameS "Wrap"# +$tcWrap2 = GHC.Types.TrNameS $tcWrap1 -- RHS size: {terms: 5, types: 0, coercions: 0} Roles13.$tcWrap :: GHC.Types.TyCon @@ -88,7 +118,7 @@ Roles13.$tcWrap = 5278920226786541118## 14554440859491798587## Roles13.$trModule - $tcWrap1 + $tcWrap2 diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index 224e84c825..5a465d9818 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -185,3 +185,8 @@ T13025: '$(TEST_HC)' $(TEST_HC_OPTS) -c -O T13025a.hs -'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T13025.hs -ddump-simpl | grep -c HEq_sc # No lines should match 'HEq_sc' so wc should output zeros + +.PHONY: str-rules +str-rules: + $(RM) -f str-rules.hi str-rules.o + '$(TEST_HC)' $(TEST_HC_OPTS) -c -O str-rules.hs -ddump-simpl | grep -o '"@@@[^"].*"#' | sort diff --git a/testsuite/tests/simplCore/should_compile/T3234.stderr b/testsuite/tests/simplCore/should_compile/T3234.stderr index da96b43d9d..9d87b3ecc1 100644 --- a/testsuite/tests/simplCore/should_compile/T3234.stderr +++ b/testsuite/tests/simplCore/should_compile/T3234.stderr @@ -1,6 +1,6 @@ ==================== FloatOut stats: ==================== -1 Lets floated to top level; 0 Lets floated elsewhere; from 1 Lambda groups +2 Lets floated to top level; 0 Lets floated elsewhere; from 1 Lambda groups @@ -10,9 +10,9 @@ ==================== Grand total simplifier statistics ==================== -Total ticks: 51 +Total ticks: 54 -14 PreInlineUnconditionally +15 PreInlineUnconditionally 1 n 1 g 1 a @@ -27,6 +27,7 @@ Total ticks: 51 1 a 1 lvl 1 lvl + 1 lvl 4 PostInlineUnconditionally 1 c 1 n @@ -39,7 +40,7 @@ Total ticks: 51 1 fold/build 1 unpack 1 unpack-list -2 LetFloatFromLet 2 +4 LetFloatFromLet 4 25 BetaReduction 1 a 1 c diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index a7c1e55c52..f9adeb28da 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -1,15 +1,31 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 32, types: 13, coercions: 0} +Result size of Tidy Core = {terms: 36, types: 15, coercions: 0} + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T3717.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T3717.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T3717.$trModule2 :: GHC.Types.TrName +T3717.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T3717.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T3717.$trModule3 = GHC.Types.TrNameS T3717.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T3717.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T3717.$trModule2 = "T3717"# -- RHS size: {terms: 2, types: 0, coercions: 0} T3717.$trModule1 :: GHC.Types.TrName @@ -17,8 +33,8 @@ T3717.$trModule1 :: GHC.Types.TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T3717.$trModule1 = GHC.Types.TrNameS "T3717"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T3717.$trModule1 = GHC.Types.TrNameS T3717.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} T3717.$trModule :: GHC.Types.Module @@ -28,7 +44,7 @@ T3717.$trModule :: GHC.Types.Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T3717.$trModule = - GHC.Types.Module T3717.$trModule2 T3717.$trModule1 + GHC.Types.Module T3717.$trModule3 T3717.$trModule1 Rec { -- RHS size: {terms: 10, types: 2, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index d70c0eee55..76936e336f 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 36, types: 14, coercions: 0} +Result size of Tidy Core = {terms: 40, types: 16, coercions: 0} Rec { -- RHS size: {terms: 10, types: 2, coercions: 0} @@ -26,23 +26,39 @@ foo = } } +-- RHS size: {terms: 1, types: 0, coercions: 0} +T3772.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T3772.$trModule2 = "T3772"# + -- RHS size: {terms: 2, types: 0, coercions: 0} T3772.$trModule1 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T3772.$trModule1 = GHC.Types.TrNameS "T3772"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T3772.$trModule1 = GHC.Types.TrNameS T3772.$trModule2 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T3772.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T3772.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T3772.$trModule2 :: GHC.Types.TrName +T3772.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T3772.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T3772.$trModule3 = GHC.Types.TrNameS T3772.$trModule4 -- RHS size: {terms: 3, types: 0, coercions: 0} T3772.$trModule :: GHC.Types.Module @@ -52,7 +68,7 @@ T3772.$trModule :: GHC.Types.Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T3772.$trModule = - GHC.Types.Module T3772.$trModule2 T3772.$trModule1 + GHC.Types.Module T3772.$trModule3 T3772.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 7136bd1f51..e9957bf9de 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -1,15 +1,31 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 64, types: 41, coercions: 0} +Result size of Tidy Core = {terms: 68, types: 43, coercions: 0} + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T4908.$trModule4 :: Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T4908.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T4908.$trModule2 :: TrName +T4908.$trModule3 :: TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T4908.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T4908.$trModule3 = GHC.Types.TrNameS T4908.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T4908.$trModule2 :: Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T4908.$trModule2 = "T4908"# -- RHS size: {terms: 2, types: 0, coercions: 0} T4908.$trModule1 :: TrName @@ -17,8 +33,8 @@ T4908.$trModule1 :: TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T4908.$trModule1 = GHC.Types.TrNameS "T4908"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T4908.$trModule1 = GHC.Types.TrNameS T4908.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} T4908.$trModule :: Module @@ -28,7 +44,7 @@ T4908.$trModule :: Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T4908.$trModule = - GHC.Types.Module T4908.$trModule2 T4908.$trModule1 + GHC.Types.Module T4908.$trModule3 T4908.$trModule1 Rec { -- RHS size: {terms: 19, types: 5, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 7e51aa68be..365584d3d0 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -1,15 +1,31 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 45, types: 17, coercions: 0} +Result size of Tidy Core = {terms: 49, types: 19, coercions: 0} + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T4930.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T4930.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T4930.$trModule2 :: GHC.Types.TrName +T4930.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T4930.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T4930.$trModule3 = GHC.Types.TrNameS T4930.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T4930.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T4930.$trModule2 = "T4930"# -- RHS size: {terms: 2, types: 0, coercions: 0} T4930.$trModule1 :: GHC.Types.TrName @@ -17,8 +33,8 @@ T4930.$trModule1 :: GHC.Types.TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T4930.$trModule1 = GHC.Types.TrNameS "T4930"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T4930.$trModule1 = GHC.Types.TrNameS T4930.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} T4930.$trModule :: GHC.Types.Module @@ -28,7 +44,7 @@ T4930.$trModule :: GHC.Types.Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T4930.$trModule = - GHC.Types.Module T4930.$trModule2 T4930.$trModule1 + GHC.Types.Module T4930.$trModule3 T4930.$trModule1 Rec { -- RHS size: {terms: 23, types: 6, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 2b0984c8d5..2e387b27bc 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 82, types: 42, coercions: 0} +Result size of Tidy Core = {terms: 94, types: 48, coercions: 0} -- RHS size: {terms: 6, types: 3, coercions: 0} T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo @@ -66,14 +66,30 @@ fun2 = } }) +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7360.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T7360.$trModule4 = "main"# + -- RHS size: {terms: 2, types: 0, coercions: 0} -T7360.$trModule2 :: GHC.Types.TrName +T7360.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T7360.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7360.$trModule3 = GHC.Types.TrNameS T7360.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7360.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T7360.$trModule2 = "T7360"# -- RHS size: {terms: 2, types: 0, coercions: 0} T7360.$trModule1 :: GHC.Types.TrName @@ -81,8 +97,8 @@ T7360.$trModule1 :: GHC.Types.TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T7360.$trModule1 = GHC.Types.TrNameS "T7360"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} T7360.$trModule :: GHC.Types.Module @@ -92,16 +108,24 @@ T7360.$trModule :: GHC.Types.Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] T7360.$trModule = - GHC.Types.Module T7360.$trModule2 T7360.$trModule1 + GHC.Types.Module T7360.$trModule3 T7360.$trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7360.$tc'Foo9 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T7360.$tc'Foo9 = "'Foo3"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T7360.$tc'Foo6 :: GHC.Types.TrName +T7360.$tc'Foo8 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T7360.$tc'Foo6 = GHC.Types.TrNameS "'Foo3"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7360.$tc'Foo8 = GHC.Types.TrNameS T7360.$tc'Foo9 -- RHS size: {terms: 5, types: 0, coercions: 0} T7360.$tc'Foo3 :: GHC.Types.TyCon @@ -115,16 +139,24 @@ T7360.$tc'Foo3 = 10507205234936349519## 8302184214013227554## T7360.$trModule - T7360.$tc'Foo6 + T7360.$tc'Foo8 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7360.$tc'Foo7 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T7360.$tc'Foo7 = "'Foo2"# -- RHS size: {terms: 2, types: 0, coercions: 0} -T7360.$tc'Foo5 :: GHC.Types.TrName +T7360.$tc'Foo6 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T7360.$tc'Foo5 = GHC.Types.TrNameS "'Foo2"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7360.$tc'Foo6 = GHC.Types.TrNameS T7360.$tc'Foo7 -- RHS size: {terms: 5, types: 0, coercions: 0} T7360.$tc'Foo2 :: GHC.Types.TyCon @@ -138,7 +170,15 @@ T7360.$tc'Foo2 = 9825259700232563546## 11056638024476048052## T7360.$trModule - T7360.$tc'Foo5 + T7360.$tc'Foo6 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7360.$tc'Foo5 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T7360.$tc'Foo5 = "'Foo1"# -- RHS size: {terms: 2, types: 0, coercions: 0} T7360.$tc'Foo4 :: GHC.Types.TrName @@ -146,8 +186,8 @@ T7360.$tc'Foo4 :: GHC.Types.TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -T7360.$tc'Foo4 = GHC.Types.TrNameS "'Foo1"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7360.$tc'Foo4 = GHC.Types.TrNameS T7360.$tc'Foo5 -- RHS size: {terms: 5, types: 0, coercions: 0} T7360.$tc'Foo1 :: GHC.Types.TyCon @@ -163,14 +203,22 @@ T7360.$tc'Foo1 = T7360.$trModule T7360.$tc'Foo4 +-- RHS size: {terms: 1, types: 0, coercions: 0} +T7360.$tcFoo2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T7360.$tcFoo2 = "Foo"# + -- RHS size: {terms: 2, types: 0, coercions: 0} T7360.$tcFoo1 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -T7360.$tcFoo1 = GHC.Types.TrNameS "Foo"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2 -- RHS size: {terms: 5, types: 0, coercions: 0} T7360.$tcFoo :: GHC.Types.TyCon diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout index 43830c7135..df8253f510 100644 --- a/testsuite/tests/simplCore/should_compile/T8274.stdout +++ b/testsuite/tests/simplCore/should_compile/T8274.stdout @@ -1,12 +1,18 @@ p = T8274.Positives 42# 4.23# 4.23## '4'# 4## n = T8274.Negatives -4# -4.0# -4.0## -T8274.$trModule2 = GHC.Types.TrNameS "main"# -T8274.$trModule1 = GHC.Types.TrNameS "T8274"# -T8274.$tc'Positives1 = GHC.Types.TrNameS "'Positives"# +T8274.$trModule4 :: Addr# +T8274.$trModule4 = "main"# +T8274.$trModule2 :: Addr# +T8274.$trModule2 = "T8274"# +T8274.$tc'Positives2 :: Addr# +T8274.$tc'Positives2 = "'Positives"# T8274.$tc'Positives = GHC.Types.TyCon 14732531009298850569## 4925356269917933860## T8274.$trModule T8274.$tc'Positives1 -T8274.$tcP1 = GHC.Types.TrNameS "P"# +T8274.$tcP2 :: Addr# +T8274.$tcP2 = "P"# T8274.$tcP = GHC.Types.TyCon 11095028091707994303## 9476557054198009608## T8274.$trModule T8274.$tcP1 -T8274.$tc'Negatives1 = GHC.Types.TrNameS "'Negatives"# +T8274.$tc'Negatives2 :: Addr# +T8274.$tc'Negatives2 = "'Negatives"# T8274.$tc'Negatives = GHC.Types.TyCon 15950179315687996644## 11481167534507418130## T8274.$trModule T8274.$tc'Negatives1 -T8274.$tcN1 = GHC.Types.TrNameS "N"# +T8274.$tcN2 :: Addr# +T8274.$tcN2 = "N"# T8274.$tcN = GHC.Types.TyCon 7479687563082171902## 17616649989360543185## T8274.$trModule T8274.$tcN1 diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index bab1751a86..92979b36b1 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -1,21 +1,31 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 33, types: 20, coercions: 0} +Result size of Tidy Core = {terms: 37, types: 22, coercions: 0} --- RHS size: {terms: 2, types: 0, coercions: 0} -$trModule1 :: TrName +-- RHS size: {terms: 1, types: 0, coercions: 0} +$trModule1 :: Addr# [GblId, Caf=NoCafRefs] -$trModule1 = GHC.Types.TrNameS "main"# +$trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} $trModule2 :: TrName [GblId, Caf=NoCafRefs] -$trModule2 = GHC.Types.TrNameS "T9400"# +$trModule2 = GHC.Types.TrNameS $trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +$trModule3 :: Addr# +[GblId, Caf=NoCafRefs] +$trModule3 = "T9400"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule4 :: TrName +[GblId, Caf=NoCafRefs] +$trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0} T9400.$trModule :: Module [GblId, Caf=NoCafRefs] -T9400.$trModule = GHC.Types.Module $trModule1 $trModule2 +T9400.$trModule = GHC.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 22, types: 15, coercions: 0} main :: IO () diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 19e9f1d3a4..2ede2468ee 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -263,3 +263,7 @@ test('T13025', ['$MAKE -s --no-print-directory T13025']) test('T13156', normal, run_command, ['$MAKE -s --no-print-directory T13156']) test('T11444', normal, compile, ['']) +test('str-rules', + normal, + run_command, + ['$MAKE -s --no-print-directory str-rules']) diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr index b100172381..1bb98e57b4 100644 --- a/testsuite/tests/simplCore/should_compile/noinline01.stderr +++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr @@ -9,17 +9,25 @@ Noinline01.g :: GHC.Types.Bool [GblId] = \u [] Noinline01.f GHC.Types.False; -Noinline01.$trModule2 :: GHC.Types.TrName +Noinline01.$trModule4 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs, Unf=OtherCon []] = + "main"#; + +Noinline01.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] = - NO_CCS GHC.Types.TrNameS! ["main"#]; + NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule4]; + +Noinline01.$trModule2 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs, Unf=OtherCon []] = + "Noinline01"#; Noinline01.$trModule1 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] = - NO_CCS GHC.Types.TrNameS! ["Noinline01"#]; + NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule2]; Noinline01.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] = - NO_CCS GHC.Types.Module! [Noinline01.$trModule2 + NO_CCS GHC.Types.Module! [Noinline01.$trModule3 Noinline01.$trModule1]; @@ -34,17 +42,25 @@ Noinline01.g :: GHC.Types.Bool [GblId] = \u [] Noinline01.f GHC.Types.False; -Noinline01.$trModule2 :: GHC.Types.TrName +Noinline01.$trModule4 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs, Unf=OtherCon []] = + "main"#; + +Noinline01.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] = - NO_CCS GHC.Types.TrNameS! ["main"#]; + NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule4]; + +Noinline01.$trModule2 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs, Unf=OtherCon []] = + "Noinline01"#; Noinline01.$trModule1 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] = - NO_CCS GHC.Types.TrNameS! ["Noinline01"#]; + NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule2]; Noinline01.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] = - NO_CCS GHC.Types.Module! [Noinline01.$trModule2 + NO_CCS GHC.Types.Module! [Noinline01.$trModule3 Noinline01.$trModule1]; diff --git a/testsuite/tests/simplCore/should_compile/par01.stderr b/testsuite/tests/simplCore/should_compile/par01.stderr index 90d467f71c..4ccb9d892b 100644 --- a/testsuite/tests/simplCore/should_compile/par01.stderr +++ b/testsuite/tests/simplCore/should_compile/par01.stderr @@ -1,6 +1,6 @@ ==================== CorePrep ==================== -Result size of CorePrep = {terms: 18, types: 8, coercions: 0} +Result size of CorePrep = {terms: 22, types: 10, coercions: 0} Rec { -- RHS size: {terms: 7, types: 3, coercions: 0} @@ -13,21 +13,31 @@ Par01.depth = } end Rec } +-- RHS size: {terms: 1, types: 0, coercions: 0} +Par01.$trModule4 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs, Unf=OtherCon []] +Par01.$trModule4 = "main"# + -- RHS size: {terms: 2, types: 0, coercions: 0} -Par01.$trModule2 :: GHC.Types.TrName +Par01.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] -Par01.$trModule2 = GHC.Types.TrNameS "main"# +Par01.$trModule3 = GHC.Types.TrNameS Par01.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +Par01.$trModule2 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs, Unf=OtherCon []] +Par01.$trModule2 = "Par01"# -- RHS size: {terms: 2, types: 0, coercions: 0} Par01.$trModule1 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] -Par01.$trModule1 = GHC.Types.TrNameS "Par01"# +Par01.$trModule1 = GHC.Types.TrNameS Par01.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} Par01.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] Par01.$trModule = - GHC.Types.Module Par01.$trModule2 Par01.$trModule1 + GHC.Types.Module Par01.$trModule3 Par01.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr index 844afc63d6..572fac36a8 100644 --- a/testsuite/tests/simplCore/should_compile/rule2.stderr +++ b/testsuite/tests/simplCore/should_compile/rule2.stderr @@ -10,14 +10,14 @@ ==================== Grand total simplifier statistics ==================== -Total ticks: 13 +Total ticks: 15 2 PreInlineUnconditionally 1 f 1 lvl 1 UnfoldingDone 1 Roman.bar 1 RuleFired 1 foo/bar -1 LetFloatFromLet 1 +3 LetFloatFromLet 3 1 EtaReduction 1 ds 7 BetaReduction 1 f diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index e7fc531a43..0de46d181d 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -1,15 +1,31 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 172, types: 65, coercions: 0} +Result size of Tidy Core = {terms: 178, types: 68, coercions: 0} + +-- RHS size: {terms: 1, types: 0, coercions: 0} +Roman.$trModule4 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +Roman.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0} -Roman.$trModule2 :: GHC.Types.TrName +Roman.$trModule3 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] -Roman.$trModule2 = GHC.Types.TrNameS "main"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +Roman.$trModule3 = GHC.Types.TrNameS Roman.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +Roman.$trModule2 :: GHC.Prim.Addr# +[GblId, + Caf=NoCafRefs, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +Roman.$trModule2 = "Roman"# -- RHS size: {terms: 2, types: 0, coercions: 0} Roman.$trModule1 :: GHC.Types.TrName @@ -17,8 +33,8 @@ Roman.$trModule1 :: GHC.Types.TrName Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] -Roman.$trModule1 = GHC.Types.TrNameS "Roman"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +Roman.$trModule1 = GHC.Types.TrNameS Roman.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0} Roman.$trModule :: GHC.Types.Module @@ -28,16 +44,18 @@ Roman.$trModule :: GHC.Types.Module Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] Roman.$trModule = - GHC.Types.Module Roman.$trModule2 Roman.$trModule1 + GHC.Types.Module Roman.$trModule3 Roman.$trModule1 + +-- RHS size: {terms: 1, types: 0, coercions: 0} +lvl :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +lvl = "spec-inline.hs:(19,5)-(29,25)|function go"# -- RHS size: {terms: 2, types: 2, coercions: 0} Roman.foo3 :: Int [GblId, Str=x] Roman.foo3 = - Control.Exception.Base.patError - @ 'GHC.Types.LiftedRep - @ Int - "spec-inline.hs:(19,5)-(29,25)|function go"# + Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl Rec { -- RHS size: {terms: 55, types: 9, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/str-rules.hs b/testsuite/tests/simplCore/should_compile/str-rules.hs new file mode 100644 index 0000000000..a94df9958c --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/str-rules.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE MagicHash #-} +import GHC.CString (unpackFoldrCString#, unpackCString#) +import GHC.Base (eqString) +main :: IO () +main = do + let mix c n = fromEnum c + n + n <- readLn + + print $ + -- We expect the two literals to be concatenated, resulting in "@@@ ab" + unpackFoldrCString# "@@@ a"# mix + (unpackFoldrCString# "b"# mix n) + + if eqString (unpackCString# "x"#) (unpackCString# "y"#) + then putStrLn $ unpackCString# "@@@ c"# -- this should be optimized out + else putStrLn $ unpackCString# "@@@ d"# + + if eqString (unpackCString# "foo"#) (unpackCString# "foo"#) + then putStrLn $ unpackCString# "@@@ e"# + else putStrLn $ unpackCString# "@@@ f"# -- this should be optimized out diff --git a/testsuite/tests/simplCore/should_compile/str-rules.stdout b/testsuite/tests/simplCore/should_compile/str-rules.stdout new file mode 100644 index 0000000000..a3f3ae899d --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/str-rules.stdout @@ -0,0 +1,3 @@ +"@@@ ab"# +"@@@ d"# +"@@@ e"# |