diff --git a/README.md b/README.md index 55587fd..13b6fc5 100644 --- a/README.md +++ b/README.md @@ -147,7 +147,7 @@ The whole system reduces to four simple rules: (forbidden). * A type explicitly listed in a `Permit...` annotation is **always allowed** (permitted), never reported. -* The `forbid-fused` plugin option **adds all `Fuse` annotated types to the +* The `inspect-fused` plugin option **adds all `Fuse` annotated types to the forbidden set**. * By default unboxed types are implicitly in the permitted list. The `inspect-unboxed` plugin option means **unboxed types are no longer @@ -164,12 +164,12 @@ annotation of each type to the binding. function2 :: ... ``` -Additionally pass the `forbid-fused` plugin option to forbid all `Fuse` +Additionally pass the `inspect-fused` plugin option to forbid all `Fuse` annotated types too, using them as a baseline; the types named in the annotation are then forbidden on top of them. With this option `ForbidConstructions []` forbids exactly the `Fuse` annotated types. ``` -ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused +ghc-options: -fplugin-opt=Fusion.Plugin:inspect-fused ``` Report the listed types only where they are constructed: diff --git a/src/Fusion/Plugin.hs b/src/Fusion/Plugin.hs index 6f6e06d..a9b9856 100644 --- a/src/Fusion/Plugin.hs +++ b/src/Fusion/Plugin.hs @@ -148,11 +148,11 @@ import Fusion.Plugin.Inspect -- This does not affect the @Permit...@ annotations: -- -- @ --- ghc-options: -fplugin-opt=Fusion.Plugin:forbid-fused +-- ghc-options: -fplugin-opt=Fusion.Plugin:inspect-fused -- @ -- -- By default unboxed types (e.g. @Int#@, unboxed tuples and sums) are --- implicitly in the permitted list. When `inspect-fused` plugin option is +-- implicitly in the permitted list. When `inspect-unboxed` plugin option is -- enabled they are no longer implicitly permitted, they will now have to be -- explictly mentioned in the permitted list to allow them. -- @@ -160,6 +160,28 @@ import Fusion.Plugin.Inspect -- ghc-options: -fplugin-opt=Fusion.Plugin:inspect-unboxed -- @ -- +-- By default the plugin excludes unavoidable function /boundary/ crossings +-- from the reports, pattern matches on the function's arguments are not +-- reported as violations, similarly construction of the return values of a +-- function are not reported. The @inspect-boundaries@ option includes the +-- boundary matches and constructions as well: +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:inspect-boundaries +-- @ +-- +-- To neutralize the 'Fusion.Plugin.Types.Fuse' annotation, making it a no-op, +-- pass the @fuse-ignore@ option: +-- +-- @ +-- ghc-options: -fplugin-opt=Fusion.Plugin:fuse-ignore +-- @ +-- +-- With this option the plugin does not force-inline anything, so the generated +-- code is left unchanged (as if the plugin were not enabled). The fusion +-- violation reports are still produced, which makes this useful for auditing +-- fusion using standard GHC compilation. +-- -- To dump the core after each core to core transformation, pass the -- following to your ghc-options: -- @@ -250,8 +272,10 @@ defaultOptions = Options , optionsVerbosityLevel = ReportSilent , optionsWError = False , optionsCsvAppend = False - , optionsForbidFused = False + , optionsInspectFused = False , optionsInspectUnboxed = False + , optionsInspectBoundaries = False + , optionsFuseIgnore = False } setDumpCore :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () @@ -286,10 +310,10 @@ setCsvAppend val = do (args, opts) <- get put (args, opts { optionsCsvAppend = val }) -setForbidFused :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () -setForbidFused val = do +setInspectFused :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () +setInspectFused val = do (args, opts) <- get - put (args, opts { optionsForbidFused = val }) + put (args, opts { optionsInspectFused = val }) setInspectUnboxed :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () @@ -297,6 +321,18 @@ setInspectUnboxed val = do (args, opts) <- get put (args, opts { optionsInspectUnboxed = val }) +setInspectBoundaries + :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () +setInspectBoundaries val = do + (args, opts) <- get + put (args, opts { optionsInspectBoundaries = val }) + +setFuseIgnore + :: Monad m => Bool -> StateT ([CommandLineOption], Options) m () +setFuseIgnore val = do + (args, opts) <- get + put (args, opts { optionsFuseIgnore = val }) + setVerbosityLevel :: Monad m => ReportMode -> StateT ([CommandLineOption], Options) m () setVerbosityLevel val = do @@ -328,8 +364,10 @@ parseOptions args = "dump-core-if-violated" -> setDumpCoreIfViolated True "werror" -> setWError True "csv-append" -> setCsvAppend True - "forbid-fused" -> setForbidFused True + "inspect-fused" -> setInspectFused True "inspect-unboxed" -> setInspectUnboxed True + "inspect-boundaries" -> setInspectBoundaries True + "fuse-ignore" -> setFuseIgnore True "verbose=1" -> setVerbosityLevel ReportWarn "verbose=2" -> setVerbosityLevel ReportVerbose "verbose=3" -> setVerbosityLevel ReportVerbose1 @@ -528,25 +566,34 @@ install args todos -- expression directly. -- -- TODO do not run simplify if we did not do anything in markInline phase. + -- + -- When @fuse-ignore@ is set we neutralize the 'Fuse' annotation: the + -- force-inlining (markInline) and the follow-up gentle simplify passes + -- are skipped so codegen is left unchanged. Only the reporting pass + -- runs, so violations are still reported, but against GHC's ordinary + -- (un-force-inlined) baseline rather than the force-inlined one. + let markPasses + | optionsFuseIgnore options = [] + | otherwise = + [ fusionMarkInline 1 ReportSilent True + , simplify + , fusionMarkInline 2 ReportSilent True + , simplify + , fusionMarkInline 3 ReportSilent True + , simplify + -- This lets us know what was left unfused after all the + -- inlining and case-of-case transformations. + , let mesg = "Check unfused (post inlining)" + in CoreDoPluginPass mesg + (fusionReport mesg ReportSilent False options) + ] return $ insertDumpPasses (optionsVerbosityLevel options /= ReportSilent) (optionsDumpCore options) dumpPassesRef $ insertAfterSimplPhase0 todos - [ fusionPluginMarker - , fusionMarkInline 1 ReportSilent True - , simplify - , fusionMarkInline 2 ReportSilent True - , simplify - , fusionMarkInline 3 ReportSilent True - , simplify - -- This lets us know what was left unfused after all the - -- inlining and case-of-case transformations. - , let mesg = "Check unfused (post inlining)" - in CoreDoPluginPass mesg - (fusionReport mesg ReportSilent False options) - ] + (fusionPluginMarker : markPasses) (let mesg = "Check unfused (final)" report = fusionReport diff --git a/src/Fusion/Plugin/Common.hs b/src/Fusion/Plugin/Common.hs index b2ff122..53e7488 100644 --- a/src/Fusion/Plugin/Common.hs +++ b/src/Fusion/Plugin/Common.hs @@ -21,6 +21,7 @@ module Fusion.Plugin.Common , lookupBinderAnn , subsumedBySameName , binderClosure + , exprVarOccs -- * Context / annotation traversal , altsContainsAnn @@ -182,8 +183,10 @@ data Options = Options , optionsVerbosityLevel :: ReportMode , optionsWError :: Bool , optionsCsvAppend :: Bool - , optionsForbidFused :: Bool + , optionsInspectFused :: Bool , optionsInspectUnboxed :: Bool + , optionsInspectBoundaries :: Bool + , optionsFuseIgnore :: Bool } deriving Show -- Checks whether a case alternative contains a type for which the given diff --git a/src/Fusion/Plugin/Inspect.hs b/src/Fusion/Plugin/Inspect.hs index fbc73b6..00c5298 100644 --- a/src/Fusion/Plugin/Inspect.hs +++ b/src/Fusion/Plugin/Inspect.hs @@ -48,6 +48,7 @@ import Fusion.Plugin.Common , binderDisplayName , constrTyCon , dumpBindCore + , exprVarOccs , getAnnotationsByStableName , getNonRecBinder , listPath @@ -85,49 +86,181 @@ import Fusion.Plugin.Common -- (or literal) @case@ that merely forces a value, e.g. @case s of _ -> ...@ -- where @s :: SPEC@ -- whose type comes from the case binder; -- 3. 'Constr' is a construction or bare boxed use. -data Context = CaseAlt (Alt CoreBndr) | CaseScrut CoreBndr | Constr Id +-- +-- The 'Bool' each constructor carries is the /boundary/ flag -- 'True' for an +-- unavoidable crossing of the binding's boundary, not a fusion failure. The two +-- sides are dual: +-- +-- * Pattern match ('CaseAlt', 'CaseScrut') -- the /input/ boundary: 'True' when +-- the scrutinized value is one of an eligible binding's own top-level +-- parameters (the leading lambda binders of its RHS), input handed in from +-- outside, so an unavoidable unpack. +-- +-- * Construction ('Constr') -- the /output/ boundary: 'True' when the +-- construction sits in the binding's return\/tail position, output handed back +-- to the caller, so an unavoidable repack. +-- +-- Excluded on the input side (flag 'False', so reported): lambdas nested below +-- the top-level parameters (stepper functions, join points, continuations), +-- and the parameters of any binding that is not the annotated function itself +-- or that takes part in a recursion cycle (see 'boundaryEligibleBinder'); the +-- annotated function's direct @$w@ worker /is/ included. Excluded on the +-- output side: any construction not in the direct tail spine -- one fed into a +-- call\/jump, let-bound, or built inside a nested lambda -- since it is +-- consumed within the binding. Anything excluded is a real fusion hit. +data Context + = CaseAlt Bool (Alt CoreBndr) + | CaseScrut Bool CoreBndr + | Constr Bool Id -- Inspection detects everything detectable: it looks for interesting types -- everywhere in a binding, in every subexpression including case scrutinees. -- (Force-inlining is deliberately narrower; those choices are documented in -- Fusion.Plugin.Fuse) -- +-- | Whether the leading parameters of a binding in the annotated function's +-- closure are a genuine argument /boundary/ (see 'Context'). Two conditions +-- must both hold: +-- +-- 1. The binding /is/ the annotated function: its display name (which strips a +-- @$w@ worker prefix, see 'binderDisplayName') equals the annotated binder's. +-- This admits the user function and its direct @$w@ worker -- whose leading +-- lambdas carry the user's actual arguments (e.g. @$wfinallyIO size start@) +-- -- while rejecting internal helpers and specializations that the optimizer +-- named differently (e.g. a SpecConstr @$s$wgo@), whose parameters are loop +-- state, not arguments. +-- +-- 2. The binding takes part in no recursion cycle -- direct /or/ mutual (see +-- 'participatesInCycle'). A binding in a cycle is a loop, and a parameter it +-- threads back around the cycle is loop state, not a once-per-entry argument +-- unpack. +-- +-- Any binding failing either test contributes no boundaries, so all its matches +-- are reported. +boundaryEligibleBinder + :: [(CoreBndr, CoreExpr)] -> CoreBndr -> CoreBndr -> CoreExpr -> Bool +boundaryEligibleBinder allBinds root v e = + binderDisplayName v == binderDisplayName root + -- The commented check is cheaper, but a direct self-reference check would + -- miss a loop routed through a same-named helper (@$wf -> $s$wgo -> $wf@); + -- the reachability check does not, so a real fusion hit can never be + -- hidden in a recursive worker. + -- && not (v `elemVarSet` exprVarOccs e) + && not (participatesInCycle allBinds v e) + +-- | True if 'v' can be reached from its own RHS 'e' by following term-level +-- references transitively within 'allBinds' -- i.e. 'v' takes part in a +-- recursion cycle, whether direct (@v@'s RHS mentions @v@) or mutual (through +-- one or more other bindings that lead back to @v@). +-- +-- TODO(perf): called per closure member with an O(n) list 'lookup' and a +-- rebuilt 'topSet'. For huge modules, precompute the cyclic members once from +-- 'binderClosure' and make eligibility an O(1) set lookup. +participatesInCycle :: [(CoreBndr, CoreExpr)] -> CoreBndr -> CoreExpr -> Bool +participatesInCycle allBinds v e0 = reach (refsOf e0) emptyVarSet + + where + + topSet = mkVarSet (map fst allBinds) + + -- The top-level binders directly referenced by an expression. + refsOf e = nonDetEltsUniqSet (intersectVarSet (exprVarOccs e) topSet) + + reach [] _ = False + reach (w : ws) seen + | w == v = True + | w `elemVarSet` seen = reach ws seen + | otherwise = + case lookup w allBinds of + Just e -> reach (refsOf e ++ ws) (extendVarSet seen w) + Nothing -> reach ws (extendVarSet seen w) + -- | Report whether data constructors of interest are case matched or returned -- anywhere in the binders, not just case match on entry or construction on -- return. -- containsAnns - :: DynFlags -> (Name -> Bool) -> CoreBind -> [([CoreBind], Context)] -containsAnns dflags isInteresting bind = - -- The first argument is current binder and its parent chain. We add a new - -- element to this path when we enter a let statement. - goLet [] bind + :: DynFlags -> (Name -> Bool) -> Bool -> CoreBind + -> [([CoreBind], Context)] +containsAnns dflags isInteresting boundaryEligible bind = + -- 'parents' is the current binder's let-parent chain (extended on entry to + -- each let). 'lams' holds the binding's own top-level parameters: a @case@ + -- on one of them is a boundary unpack (see 'Context'). It is seeded once, + -- from the leading lambdas of the RHS, and never extended -- lambdas nested + -- deeper (steppers, join points) bind values produced within the binding. + goBind bind where + -- Split a binding's RHS into its leading lambda binders (the function's own + -- parameters) and the body under them. + collectLams :: CoreExpr -> ([CoreBndr], CoreExpr) + collectLams (Lam b e) = let (bs, body) = collectLams e in (b : bs, body) + collectLams e = ([], e) + + goBind :: CoreBind -> [([CoreBind], Context)] + goBind b@(NonRec _ e) = + let (bndrs, body) = collectLams e + -- A boundary exists only at a user function's signature. In a + -- compiler-generated binding (a @$w@ worker, a @$s@ specialization, + -- etc.) the leading lambdas are internal plumbing -- loop state or + -- specialized arguments the optimizer invented -- not external + -- input, so we seed no boundary here and report all its matches. + lams | boundaryEligible = mkVarSet (filter isId bndrs) + | otherwise = emptyVarSet + -- The body is in return position only for an eligible binding; + -- there its tail constructions are the unavoidable output repack. + in go boundaryEligible lams [b] body + goBind (Rec bs) = bs >>= (\(v, e) -> goBind (NonRec v e)) + + -- A @case@ scrutinee is a boundary unpack when, after peeling any 'Cast' or + -- 'Tick' wrappers, it is a bare reference to a top-level parameter. An + -- application head (e.g. @step s@) is deliberately not peeled: that is a + -- computed value, not a parameter, so it is not a boundary. + scrutVar :: CoreExpr -> Maybe Id + scrutVar (Var v) = Just v + scrutVar (Cast e _) = scrutVar e + scrutVar (Tick _ e) = scrutVar e + scrutVar _ = Nothing + + -- We exclude by boundary rather than positively selecting let-bound + -- scrutinees: a leftover `case step s of Yield/..` has an /application/ + -- scrutinee (not a let binder), and that is the main failure to catch. + isBoundaryScrut :: VarSet -> CoreExpr -> Bool + isBoundaryScrut lams scrut = + maybe False (`elemVarSet` lams) (scrutVar scrut) + -- A data-constructor 'Id' of an interesting type is a construction hit, -- whether applied to its fields (head of an 'App' spine, e.g. `Yield x y`) -- or nullary (a bare 'Var', e.g. `Nothing`, `[]`). An ordinary variable is -- not: even at a boxed type like `Int` it only references a value boxed -- elsewhere, so it allocates nothing. - dataConHit :: [CoreBind] -> Id -> [([CoreBind], Context)] - dataConHit parents i + dataConHit :: Bool -> [CoreBind] -> Id -> [([CoreBind], Context)] + dataConHit inRet parents i | Just dcon <- isDataConId_maybe i - , isInteresting (getName (dataConTyCon dcon)) = [(parents, Constr i)] + , isInteresting (getName (dataConTyCon dcon)) = [(parents, Constr inRet i)] | otherwise = [] + -- A saturated data-constructor application: its fields are themselves part + -- of the returned value when the construction is in return position. + isConApp :: CoreExpr -> Bool + isConApp (Var i) = isJust (isDataConId_maybe i) + isConApp _ = False + -- Like 'dataConHit' but keyed on a binder's /type/ rather than a data -- constructor: a scrutiny hit when the case binder's type is an -- interesting TyCon. Used for a default-only (or literal) case, which -- matches no data constructor, so the type must come from the scrutinee. - scrutHit :: [CoreBind] -> CoreBndr -> [([CoreBind], Context)] - scrutHit parents bndr = + scrutHit :: [CoreBind] -> Bool -> CoreBndr -> [([CoreBind], Context)] + scrutHit parents boundary bndr = case tyConAppTyConPicky_maybe (varType bndr) of Just tycon | isInteresting (getName tycon) -> - [(parents, CaseScrut bndr)] + [(parents, CaseScrut boundary bndr)] _ -> [] - go :: [CoreBind] -> CoreExpr -> [([CoreBind], Context)] + -- The 'Bool' is 'inRet': whether the current position is the binding's + -- return/tail position, used to flag a construction as an output boundary. + go :: Bool -> VarSet -> [CoreBind] -> CoreExpr -> [([CoreBind], Context)] -- Match and record the case alternative if it contains a constructor -- annotated with "Fuse", and traverse both the scrutinee and the Alt @@ -135,68 +268,85 @@ containsAnns dflags isInteresting bind = -- scrutinee ('scrut') matters for matches buried there -- e.g. a stream -- stepper lambda passed to an un-inlined imported combinator (such as -- 'foldBreak'), which lands in the scrutinee of the outer result-unpacking - -- @case (# _, _ #)@. - go parents (Case scrut caseBndr _ alts) = + -- @case (# _, _ #)@. The scrutinee is not in return position; each alt + -- inherits the case's return position. + go inRet lams parents (Case scrut caseBndr _ alts) = let binders = - go parents scrut - ++ (alts >>= (\(ALT_CONSTR(_,_,expr1)) -> go parents expr1)) + go False lams parents scrut + ++ (alts >>= (\(ALT_CONSTR(_,_,expr1)) -> + go inRet lams parents expr1)) + boundary = isBoundaryScrut lams scrut hit = case altsContainsAnn dflags isInteresting alts of - Just x -> [(parents, CaseAlt x)] + Just x -> [(parents, CaseAlt boundary x)] -- 'altsContainsAnn' recognizes an interesting type only -- through a matched data constructor. A default-only (or -- literal) case has none, so fall back to the scrutinee's -- type -- otherwise e.g. `case s of _ -> ...` with `s :: -- SPEC` would go unreported. - Nothing -> scrutHit parents caseBndr + Nothing -> scrutHit parents boundary caseBndr in hit ++ binders - go parents e@(App _ _) = + -- A construction's fields stay in return position; the arguments of an + -- ordinary call/jump are consumed inputs, so they leave return position. + go inRet lams parents e@(App _ _) = let (fun, args) = collectArgs e hit = case fun of - Var i -> dataConHit parents i + Var i -> dataConHit inRet parents i _ -> [] - in hit ++ go parents fun ++ concatMap (go parents) args + argRet = inRet && isConApp fun + in hit + ++ go inRet lams parents fun + ++ concatMap (go argRet lams parents) args - go parents (Var i) = dataConHit parents i + go inRet _ parents (Var i) = dataConHit inRet parents i -- Recursive traversal - go parents (Let bndr expr1) = goLet parents bndr ++ go parents expr1 - go parents (Lam _ expr1) = go parents expr1 - go parents (Cast expr1 _) = go parents expr1 + go inRet lams parents (Let bndr expr1) = + goLet lams parents bndr ++ go inRet lams parents expr1 + -- A lambda nested below the top-level parameters (a stepper, join point or + -- continuation) binds a value produced within the binding, not one handed in + -- from outside, so it does /not/ extend 'lams'; nor is its body the outer + -- binding's return, so 'inRet' drops to 'False'. Only the RHS's leading + -- lambdas, seeded in 'goBind', are boundary parameters. + go _ lams parents (Lam _ expr1) = go False lams parents expr1 + go inRet lams parents (Cast expr1 _) = go inRet lams parents expr1 -- A 'Tick' (cost-centre, HPC, or debug/source note, present under -prof, -- -fhpc, or -g) wraps a sub-expression, which may itself contain matches or -- constructions, so descend into it. - go parents (Tick _ expr1) = go parents expr1 + go inRet lams parents (Tick _ expr1) = go inRet lams parents expr1 -- These carry no sub-expression to traverse. - go _ (Lit _) = [] - go _ (Type _) = [] - go _ (Coercion _) = [] - - goLet :: [CoreBind] -> CoreBind -> [([CoreBind], Context)] - goLet parents bndr@(NonRec _ expr1) = go (bndr : parents) expr1 - goLet parents (Rec bs) = - bs >>= (\(b, expr1) -> goLet parents $ NonRec b expr1) + go _ _ _ (Lit _) = [] + go _ _ _ (Type _) = [] + go _ _ _ (Coercion _) = [] + + -- A let-bound RHS is not the binding's return value (conservatively: we do + -- not chase a let-bound construction that is later returned through its + -- binder), so it is traversed with 'inRet' = 'False'. + goLet :: VarSet -> [CoreBind] -> CoreBind -> [([CoreBind], Context)] + goLet lams parents bndr@(NonRec _ expr1) = go False lams (bndr : parents) expr1 + goLet lams parents (Rec bs) = + bs >>= (\(b, expr1) -> goLet lams parents $ NonRec b expr1) contextTyConName :: Context -> Maybe Name -contextTyConName (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = +contextTyConName (CaseAlt _ (ALT_CONSTR(DataAlt dcon,_,_))) = Just (getName $ dataConTyCon dcon) -contextTyConName (CaseAlt _) = Nothing -contextTyConName (CaseScrut bndr) = +contextTyConName (CaseAlt _ _) = Nothing +contextTyConName (CaseScrut _ bndr) = getName <$> tyConAppTyConPicky_maybe (varType bndr) -contextTyConName (Constr con) = getName <$> constrTyCon con +contextTyConName (Constr _ con) = getName <$> constrTyCon con -- | Like 'contextTyConName' but yields the fully-qualified @Module.Type@ name -- (via 'qualifiedTyConName') used in reports rather than the raw 'Name'. contextQualifiedName :: Context -> Maybe String -contextQualifiedName (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = +contextQualifiedName (CaseAlt _ (ALT_CONSTR(DataAlt dcon,_,_))) = Just (qualifiedTyConName (dataConTyCon dcon)) -contextQualifiedName (CaseAlt _) = Nothing -contextQualifiedName (CaseScrut bndr) = +contextQualifiedName (CaseAlt _ _) = Nothing +contextQualifiedName (CaseScrut _ bndr) = qualifiedTyConName <$> tyConAppTyConPicky_maybe (varType bndr) -contextQualifiedName (Constr con) = qualifiedTyConName <$> constrTyCon con +contextQualifiedName (Constr _ con) = qualifiedTyConName <$> constrTyCon con -- | Drop any hit whose TyCon 'Name' is in the given exclusion list. filterExcluded @@ -208,16 +358,22 @@ filterExcluded excl = -- position -- a value being deconstructed. Note this is a /use/ of the value, -- not an allocation: the box was allocated elsewhere (see 'isBoxedHit'). isPatternMatch :: Context -> Bool -isPatternMatch (CaseAlt _) = True -isPatternMatch (CaseScrut _) = True -isPatternMatch (Constr _) = False +isPatternMatch (CaseAlt _ _) = True +isPatternMatch (CaseScrut _ _) = True +isPatternMatch (Constr _ _) = False + +-- | True when the hit is an unavoidable boundary pattern deconstruction. +isBoundary :: Context -> Bool +isBoundary (CaseAlt b _) = b +isBoundary (CaseScrut b _) = b +isBoundary (Constr b _) = b -- | True when the type occurs in a constructing (allocating) position -- a -- value being built here. isConstruction :: Context -> Bool -isConstruction (Constr _) = True -isConstruction (CaseAlt _) = False -isConstruction (CaseScrut _) = False +isConstruction (Constr _ _) = True +isConstruction (CaseAlt _ _) = False +isConstruction (CaseScrut _ _) = False -- | True for unboxed TyCons: unboxed primitives (e.g. 'Int#', 'State#'), -- unboxed tuples and unboxed sums. @@ -239,13 +395,13 @@ isUnboxedTyCon tycon = -- -- This covers all usage including case scrutiny as well as construction. isBoxedHit :: Context -> Bool -isBoxedHit (CaseAlt (ALT_CONSTR(DataAlt dcon,_,_))) = +isBoxedHit (CaseAlt _ (ALT_CONSTR(DataAlt dcon,_,_))) = not (isUnboxedTyCon (dataConTyCon dcon)) -isBoxedHit (CaseAlt _) = True -isBoxedHit (CaseScrut bndr) = +isBoxedHit (CaseAlt _ _) = True +isBoxedHit (CaseScrut _ bndr) = maybe True (not . isUnboxedTyCon) (tyConAppTyConPicky_maybe (varType bndr)) -isBoxedHit (Constr con) = +isBoxedHit (Constr _ con) = case isDataConId_maybe con of -- A genuine data-constructor 'Id' is never itself the "bare -- reference to something of function type" this guards against @@ -265,8 +421,8 @@ keepBoxedOnly keepBoxedOnly = filter (isBoxedHit . snd) forbidding :: Bool -> UNIQ_FM -> [Name] -> Name -> Bool -forbidding forbidFused anns names n = - n `elem` names || (forbidFused && isJust (lookupUFM anns n)) +forbidding inspectFused anns names n = + n `elem` names || (inspectFused && isJust (lookupUFM anns n)) -- | Show a scrutinizing hit for the detailed report. A 'Left' is a scrutiny -- that matched a data constructor (delegated to 'showDetailsCaseMatch'); a @@ -325,12 +481,12 @@ data NormInspect = NormInspect -- act on the scrutinizing (pattern-match) position. normPatternMatches :: Bool -> UNIQ_FM -> InspectPatternMatches -> CoreM NormInspect -normPatternMatches forbidFused anns d = do +normPatternMatches inspectFused anns d = do (interesting, excl, explicit, permit, banner) <- case d of ForbidPatternMatches thNames -> do names <- resolveTHNames thNames return - ( forbidding forbidFused anns names + ( forbidding inspectFused anns names , [] , names , Nothing @@ -359,12 +515,12 @@ normPatternMatches forbidFused anns d = do -- on the constructing (allocating) position. normConstructions :: Bool -> UNIQ_FM -> InspectConstructions -> CoreM NormInspect -normConstructions forbidFused anns d = do +normConstructions inspectFused anns d = do (interesting, excl, explicit, permit, banner) <- case d of ForbidConstructions thNames -> do names <- resolveTHNames thNames return - ( forbidding forbidFused anns names + ( forbidding inspectFused anns names , [] , names , Nothing @@ -444,20 +600,20 @@ consumedFusibleTyCons fuseAnns e0 = -- fired -- so the caller can dump the Core for it without counting it as a -- violation. reportInspected - :: DynFlags -> ReportMode -> Bool -> Bool -> UNIQ_FM + :: DynFlags -> ReportMode -> Bool -> Bool -> Bool -> UNIQ_FM -> INSPECT_PM_FM -> INSPECT_CONSTR_FM -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM (Int, Bool) reportInspected - dflags reportMode forbidFused inspectUnboxed anns pmAnns constrAnns - allBinds (NonRec b _) + dflags reportMode inspectFused inspectUnboxed inspectBoundaries + anns pmAnns constrAnns allBinds (NonRec b _) | subsumedBySameName allBinds b = return (0, False) | otherwise = do n1 <- maybe (return 0) - (\d -> normPatternMatches forbidFused anns d >>= go) + (\d -> normPatternMatches inspectFused anns d >>= go) (lookupBinderAnn b pmAnns) (n2, advised) <- maybe (return (0, False)) (\d -> do - ni <- normConstructions forbidFused anns d + ni <- normConstructions inspectFused anns d r <- go ni -- Advisory only: references to fusible values that fusion -- would try to inline away. Not counted as a violation, but @@ -480,9 +636,18 @@ reportInspected || maybe False (`elem` explicit) (contextTyConName ctx) let allHits = filter (inPosition . snd) $ filter keep + $ filter (\(_, ctx) -> + inspectBoundaries || not (isBoundary ctx)) + -- Boundary detection runs on every closure member, worker + -- included -- not just the wrapper. A sum-typed argument is + -- not W/W-unpacked, so its boundary unpack lands in the + -- worker, and an inlined-away wrapper leaves the worker as + -- the only binder holding the arg unpacks. $ concatMap (\(v, e) -> - containsAnns dflags isInteresting (NonRec v e)) + containsAnns dflags isInteresting + (boundaryEligibleBinder allBinds b v e) + (NonRec v e)) (binderClosure allBinds b) results = filterExcluded exclusion allHits warnStalePermitted ni allHits @@ -546,8 +711,8 @@ reportInspected ++ ": inspecting (" ++ niBanner ni ++ ")..." let getAlts x = case x of - (bs, CaseAlt alt) -> Just (bs, Left alt) - (bs, CaseScrut bndr) -> Just (bs, Right bndr) + (bs, CaseAlt _ alt) -> Just (bs, Left alt) + (bs, CaseScrut _ bndr) -> Just (bs, Right bndr) _ -> Nothing patternMatches = mapMaybe getAlts results uniqBinders = @@ -555,7 +720,7 @@ reportInspected getConstrs x = case x of - (bs, Constr con) -> Just (bs, con) + (bs, Constr _ con) -> Just (bs, con) _ -> Nothing constrs = mapMaybe getConstrs results uniqConstr = DL.nub (map (getNonRecBinder . head . fst) constrs) @@ -564,7 +729,7 @@ reportInspected uniqBinders patternMatches showDetailsScrutinize showInfo b dflags reportMode "CONSTRUCT" uniqConstr constrs showDetailsConstr -reportInspected _ _ _ _ _ _ _ _ (Rec _) = +reportInspected _ _ _ _ _ _ _ _ _ (Rec _) = error "reportInspected: expecting only NonRec binders" ------------------------------------------------------------------------------- @@ -915,7 +1080,7 @@ fusionReport mesg reportMode runInspect opts guts = do -> String -> String -> VarSet -> [(CoreBndr, CoreExpr)] -> CoreBind -> CoreM Int transformBind dflags anns iAnns - pkgName modName liveBndrs allBinds bind@(NonRec b _) = do + pkgName modName liveBndrs allBinds bind@(NonRec b rhs) = do let pmAnns = iaPatternMatches iAnns constrAnns = iaConstructions iAnns classAnns = iaClasses iAnns @@ -923,8 +1088,9 @@ fusionReport mesg reportMode runInspect opts guts = do dumpAnns = iaDumps iAnns (n1, advised) <- if runInspect then reportInspected - dflags reportMode (optionsForbidFused opts) + dflags reportMode (optionsInspectFused opts) (optionsInspectUnboxed opts) + (optionsInspectBoundaries opts) anns pmAnns constrAnns allBinds bind else return (0, False) n2 <- if runInspect @@ -953,12 +1119,21 @@ fusionReport mesg reportMode runInspect opts guts = do when (shouldDump && notSubsumed) $ dumpBindCore dflags pkgName modName allBinds b when (b `elemVarSet` liveBndrs) $ do - let results = keepBoxedOnly - $ containsAnns dflags (isJust . lookupUFM anns) bind + -- Drop boundary unpacks here too (unless overridden), just as the + -- annotated report does. With no annotated root, 'b' is its own + -- root, so eligibility reduces to the cycle check (see + -- 'boundaryEligibleBinder'): 'b's own arguments are boundaries + -- unless 'b' is a loop. + let inspectBoundaries = optionsInspectBoundaries opts + results = filter (\(_, ctx) -> + inspectBoundaries || not (isBoundary ctx)) + $ keepBoxedOnly + $ containsAnns dflags (isJust . lookupUFM anns) + (boundaryEligibleBinder allBinds b b rhs) bind let getAlts x = case x of - (bs, CaseAlt alt) -> Just (bs, alt) + (bs, CaseAlt _ alt) -> Just (bs, alt) _ -> Nothing let patternMatches = mapMaybe getAlts results let uniqBinders = DL.nub (map (getNonRecBinder . head . fst) @@ -967,7 +1142,7 @@ fusionReport mesg reportMode runInspect opts guts = do -- let constrs = constructingBinders anns bind let getConstrs x = case x of - (bs, Constr con) -> Just (bs, con) + (bs, Constr _ con) -> Just (bs, con) _ -> Nothing let constrs = mapMaybe getConstrs results let uniqConstr = DL.nub (map (getNonRecBinder. head . fst) constrs)