diff options
| -rw-r--r-- | compiler/coreSyn/CoreArity.hs (renamed from compiler/coreSyn/CoreArity.lhs) | 57 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreFVs.hs (renamed from compiler/coreSyn/CoreFVs.lhs) | 94 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs (renamed from compiler/coreSyn/CoreLint.lhs) | 169 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.hs (renamed from compiler/coreSyn/CorePrep.lhs) | 91 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSubst.hs (renamed from compiler/coreSyn/CoreSubst.lhs) | 126 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSyn.hs (renamed from compiler/coreSyn/CoreSyn.lhs) | 189 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreTidy.hs (renamed from compiler/coreSyn/CoreTidy.lhs) | 42 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUnfold.hs (renamed from compiler/coreSyn/CoreUnfold.lhs) | 100 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreUtils.hs (renamed from compiler/coreSyn/CoreUtils.lhs) | 276 | ||||
| -rw-r--r-- | compiler/coreSyn/MkCore.hs (renamed from compiler/coreSyn/MkCore.lhs) | 134 | ||||
| -rw-r--r-- | compiler/coreSyn/PprCore.hs (renamed from compiler/coreSyn/PprCore.lhs) | 77 | ||||
| -rw-r--r-- | compiler/coreSyn/TrieMap.hs (renamed from compiler/coreSyn/TrieMap.lhs) | 115 |
12 files changed, 658 insertions, 812 deletions
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.hs index 37517d6190..5128891763 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Arity and eta expansion +-} -\begin{code} {-# LANGUAGE CPP #-} -- | Arity and eta expansion @@ -34,13 +34,13 @@ import Outputable import FastString import Pair import Util ( debugIsOn ) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * manifestArity and exprArity -%* * -%************************************************************************ +* * +************************************************************************ exprArity is a cheap-and-cheerful version of exprEtaExpandArity. It tells how many things the expression can be applied to before doing @@ -65,8 +65,8 @@ won't be eta-expanded. And in any case it seems more robust to have exprArity be a bit more intelligent. But note that (\x y z -> f x y z) should have arity 3, regardless of f's arity. +-} -\begin{code} manifestArity :: CoreExpr -> Arity -- ^ manifestArity sees how many leading value lambdas there are, -- after looking through casts @@ -142,8 +142,8 @@ exprBotStrictness_maybe e env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } sig ar = mkClosedStrictSig (replicate ar topDmd) botRes -- For this purpose we can be very simple -\end{code} +{- Note [exprArity invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~ exprArity has the following invariant: @@ -238,11 +238,11 @@ When we come to an application we check that the arg is trivial. unknown, hence arity 0 -%************************************************************************ -%* * +************************************************************************ +* * Computing the "arity" of an expression -%* * -%************************************************************************ +* * +************************************************************************ Note [Definition of arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -465,7 +465,8 @@ Then f :: AT [False,False] ATop f <expensive> :: AT [] ATop -------------------- Main arity code ---------------------------- -\begin{code} +-} + -- See Note [ArityType] data ArityType = ATop [OneShotInfo] | ABot Arity -- There is always an explicit lambda @@ -559,8 +560,8 @@ rhsEtaExpandArity dflags cheap_app e has_lam (Tick _ e) = has_lam e has_lam (Lam b e) = isId b || has_lam e has_lam _ = False -\end{code} +{- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~ The motivating example for arity analysis is this: @@ -628,8 +629,8 @@ PAPSs because that might in turn make g inline (if it has an inline pragma), which we might not want. After all, INLINE pragmas say "inline only when saturated" so we don't want to be too gung-ho about saturating! +-} -\begin{code} arityLam :: Id -> ArityType -> ArityType arityLam id (ATop as) = ATop (idOneShotInfo id : as) arityLam _ (ABot n) = ABot (n+1) @@ -660,8 +661,8 @@ andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs combine [] bs = takeWhile isOneShotInfo bs combine as [] = takeWhile isOneShotInfo as -\end{code} +{- Note [Combining case branches] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -679,8 +680,8 @@ lambda wasn't one-shot we don't want to do this. So we combine the best of the two branches, on the (slightly dodgy) basis that if we know one branch is one-shot, then they all must be. +-} -\begin{code} --------------------------- type CheapFun = CoreExpr -> Maybe Type -> Bool -- How to decide if an expression is cheap @@ -767,14 +768,13 @@ arityType env (Tick t e) | not (tickishIsCode t) = arityType env e arityType _ _ = vanillaArityType -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * The main eta-expander -%* * -%************************************************************************ +* * +************************************************************************ We go for: f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym @@ -822,8 +822,8 @@ Note that SCCs are not treated specially by etaExpand. If we have etaExpand 2 (\x -> scc "foo" e) = (\xy -> (scc "foo" e) y) So the costs of evaluating 'e' (not 'e y') are attributed to "foo" +-} -\begin{code} -- | @etaExpand n us e ty@ returns an expression with -- the same meaning as @e@, but with arity @n@. -- @@ -1001,4 +1001,3 @@ freshEtaId n subst ty eta_id' = uniqAway (getTvInScope subst) $ mkSysLocal (fsLit "eta") (mkBuiltinUnique n) ty' subst' = extendTvInScope subst eta_id' -\end{code} diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.hs index fc804d7c6e..af475bab3f 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Taken quite directly from the Peyton Jones/Lester paper. +-} -\begin{code} {-# LANGUAGE CPP #-} -- | A module concerned with finding the free variables of an expression. @@ -20,7 +20,7 @@ module CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars, -- * Free variables of Rules, Vars and Ids - varTypeTyVars, + varTypeTyVars, idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars, ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, @@ -50,14 +50,13 @@ import Maybes( orElse ) import Util import BasicTypes( Activation ) import Outputable -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \section{Finding the free variables of an expression} -%* * -%************************************************************************ +* * +************************************************************************ This function simply finds the free variables of an expression. So far as type variables are concerned, it only finds tyvars that are @@ -66,8 +65,8 @@ So far as type variables are concerned, it only finds tyvars that are * free in the type of a binder, but not those that are free in the type of variable occurrence. +-} -\begin{code} -- | Find all locally-defined free Ids or type variables in an expression exprFreeVars :: CoreExpr -> VarSet exprFreeVars = exprSomeFreeVars isLocalVar @@ -101,14 +100,11 @@ exprsSomeFreeVars fv_cand = mapUnionVarSet (exprSomeFreeVars fv_cand) -- | Predicate on possible free variables: returns @True@ iff the variable is interesting type InterestingVarFun = Var -> Bool -\end{code} - -\begin{code} type FV = InterestingVarFun -> VarSet -- Locally bound -> VarSet -- Free vars - -- Return the vars that are both (a) interesting + -- Return the vars that are both (a) interesting -- and (b) not locally bound -- See function keep_it @@ -172,10 +168,7 @@ addBndr bndr fv fv_cand in_scope addBndrs :: [CoreBndr] -> FV -> FV addBndrs bndrs fv = foldr addBndr fv bndrs -\end{code} - -\begin{code} expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) = someVars (tyVarsOfType ty) @@ -213,16 +206,15 @@ exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs tickish_fvs :: Tickish Id -> FV tickish_fvs (Breakpoint _ ids) = someVars (mkVarSet ids) tickish_fvs _ = noVars -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \section{Free names} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | ruleLhsOrphNames is used when deciding whether -- a rule is an orphan. In particular, suppose that T is defined in this -- module; we want to avoid declaring that a rule like: @@ -268,15 +260,15 @@ exprOrphNames e -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details exprsOrphNames :: [CoreExpr] -> NameSet exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Those variables free in the right hand side of a rule ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule {}) = noFVs @@ -314,8 +306,8 @@ ruleLhsFreeIds :: CoreRule -> VarSet ruleLhsFreeIds (BuiltinRule {}) = noFVs ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet -\end{code} +{- Note [Rule free var hack] (Not a hack any more) ~~~~~~~~~~~~~~~~~~~~~~~~~ We used not to include the Id in its own rhs free-var set. @@ -326,8 +318,8 @@ However, the occurrence analyser distinguishes "non-rule loop breakers" from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will put this 'f' in a Rec block, but will mark the binding as a non-rule loop breaker, which is perfectly inlinable. +-} -\begin{code} -- |Free variables of a vectorisation declaration vectsFreeVars :: [CoreVect] -> VarSet vectsFreeVars = mapUnionVarSet vectFreeVars @@ -338,19 +330,18 @@ vectsFreeVars = mapUnionVarSet vectFreeVars vectFreeVars (VectClass _) = noFVs vectFreeVars (VectInst _) = noFVs -- this function is only concerned with values, not types -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * -%************************************************************************ +* * +************************************************************************ The free variable pass annotates every node in the expression with its NON-GLOBAL free variables and type variables. +-} -\begin{code} -- | Every node in a binding group annotated with its -- (non-global) free variables, both Ids and TyVars type CoreBindWithFVs = AnnBind Id VarSet @@ -444,22 +435,21 @@ stableUnfoldingVars :: Unfolding -> Maybe VarSet stableUnfoldingVars unf = case unf of CoreUnfolding { uf_tmpl = rhs, uf_src = src } - | isStableSource src + | isStableSource src -> Just (exprFreeVars rhs) - DFunUnfolding { df_bndrs = bndrs, df_args = args } + DFunUnfolding { df_bndrs = bndrs, df_args = args } -> Just (exprs_fvs args isLocalVar (mkVarSet bndrs)) -- DFuns are top level, so no fvs from types of bndrs _other -> Nothing -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Free variables (and types)} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} freeVars :: CoreExpr -> CoreExprWithFVs -- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node freeVars (Var v) @@ -541,5 +531,3 @@ freeVars (Tick tickish expr) freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) -\end{code} - diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.hs index 7a050a801b..26519cc928 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.hs @@ -1,12 +1,11 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -% A ``lint'' pass to check for Core correctness +-} -\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fprof-auto #-} @@ -48,8 +47,8 @@ import Control.Monad import MonadUtils import Data.Maybe import Pair -\end{code} +{- Note [GHC Formalism] ~~~~~~~~~~~~~~~~~~~~ This file implements the type-checking algorithm for System FC, the "official" @@ -62,11 +61,11 @@ just about anything in this file or you change other types/functions throughout the Core language (all signposted to this note), you should update that formalism. See docs/core-spec/README for more info about how to do so. -%************************************************************************ -%* * +************************************************************************ +* * \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface} -%* * -%************************************************************************ +* * +************************************************************************ Checks that a set of core bindings is well-formed. The PprStyle and String just control what we print in the event of an error. The Bool value @@ -111,9 +110,8 @@ to the type of the binding variable. lintBinders does this. For Ids, the type-substituted Id is added to the in_scope set (which itself is part of the TvSubst we are carrying down), and when we find an occurrence of an Id, we fetch it from the in-scope set. +-} - -\begin{code} lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc) -- Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism @@ -149,18 +147,18 @@ lintCoreBindings local_in_scope binds -- See Note [GHC Formalism] lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[lintUnfolding]{lintUnfolding} -%* * -%************************************************************************ +* * +************************************************************************ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): +-} -\begin{code} lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr @@ -185,17 +183,17 @@ lintExpr vars expr (_warns, errs) = initL (addLoc TopLevelBindings $ addInScopeVars vars $ lintCoreExpr expr) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[lintCoreBinding]{lintCoreBinding} -%* * -%************************************************************************ +* * +************************************************************************ Check a core binding, returning the list of variables bound. +-} -\begin{code} lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -263,15 +261,15 @@ lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) ; checkTys bndr_ty ty (mkRhsMsg bndr (ptext (sLit "unfolding")) ty) } lintIdUnfolding _ _ _ = return () -- We could check more -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[lintCoreExpr]{lintCoreExpr} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} --type InKind = Kind -- Substitution not yet applied type InType = Type type InCoercion = Coercion @@ -415,8 +413,7 @@ lintCoreExpr (Coercion co) = do { (_kind, ty1, ty2, role) <- lintInCo co ; return (mkCoercionType role ty1 ty2) } -\end{code} - +{- Note [Kind instantiation in coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following coercion axiom: @@ -436,16 +433,16 @@ kind coercions and produce the following substitution which is to be applied in the type variables: k_ag ~~> * -> * -%************************************************************************ -%* * +************************************************************************ +* * \subsection[lintCoreArgs]{lintCoreArgs} -%* * -%************************************************************************ +* * +************************************************************************ The basic version of these functions checks that the argument is a subtype of the required type, as one would expect. +-} -\begin{code} lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg fun_ty (Type arg_ty) = do { arg_ty' <- applySubstTy arg_ty @@ -496,9 +493,7 @@ lintValApp arg fun_ty arg_ty where err1 = mkAppMsg fun_ty arg_ty arg err2 = mkNonFunAppMsg fun_ty arg_ty arg -\end{code} -\begin{code} checkTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied @@ -528,16 +523,15 @@ checkDeadIdOcc id (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } | otherwise = return () -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[lintCoreAlts]{lintCoreAlts} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM () -- a) Check that the alts are non-empty -- b1) Check that the DEFAULT comes first, if it exists @@ -574,9 +568,7 @@ checkCaseAlts e ty alts = is_infinite_ty = case tyConAppTyCon_maybe ty of Nothing -> False Just tycon -> isPrimTyCon tycon -\end{code} -\begin{code} checkAltExpr :: CoreExpr -> OutType -> LintM () checkAltExpr expr ann_ty = do { actual_ty <- lintCoreExpr expr @@ -620,15 +612,15 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) | otherwise -- Scrut-ty is wrong shape = addErrL (mkBadAltMsg scrut_ty alt) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[lint-types]{Types} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- When we lint binders, we (one at a time and in order): -- 1. Lint var types or kinds (possibly substituting) -- 2. Add the binder to the in scope set, and if its a coercion var, @@ -675,20 +667,19 @@ lintAndScopeId id linterF = do { ty <- lintInTy (idType id) ; let id' = setIdType id ty ; addInScopeVar id' $ (linterF id') } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Types and kinds -%* * -%************************************************************************ +* * +************************************************************************ We have a single linter for types and kinds. That is convenient because sometimes it's not clear whether the thing we are looking at is a type or a kind. +-} -\begin{code} lintInTy :: InType -> LintM LintedType -- Types only, not kinds -- Check the type, and apply the substitution to it @@ -746,10 +737,6 @@ lintType (ForAllTy tv ty) lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) -\end{code} - - -\begin{code} lintKind :: OutKind -> LintM () -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -757,10 +744,7 @@ lintKind k = do { sk <- lintType k ; unless (isSuperKind sk) (addErrL (hang (ptext (sLit "Ill-kinded kind:") <+> ppr k) 2 (ptext (sLit "has kind:") <+> ppr sk))) } -\end{code} - -\begin{code} lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -823,15 +807,15 @@ lint_app doc kfn kas ; return (substKiWith [kv] [ta] kfn) } go_app _ _ = failWithL fail_msg -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Linting coercions -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} lintInCo :: InCoercion -> LintM (LintedKind, LintedType, LintedType, Role) -- Check the coercion, and apply the substitution to it -- See Note [Linting type lets] @@ -1053,15 +1037,13 @@ lintCoercion this@(AxiomRuleCo co ts cs) [ txt "Expected:" <+> int (n + length es) , txt "Provided:" <+> int n ] -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[lint-monad]{The Lint monad} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] @@ -1118,17 +1100,12 @@ data LintLocInfo | TopLevelBindings | InType Type -- Inside a type | InCo Coercion -- Inside a coercion -\end{code} - -\begin{code} initL :: LintM a -> WarnsAndErrs -- Errors and warnings initL m = case unLintM m [] emptyTvSubst (emptyBag, emptyBag) of (_, errs) -> errs -\end{code} -\begin{code} checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg @@ -1195,9 +1172,7 @@ applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co extendSubstL :: TyVar -> Type -> LintM a -> LintM a extendSubstL tv ty m = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs) -\end{code} -\begin{code} lookupIdInScope :: Id -> LintM Id lookupIdInScope id | not (mustHaveLocalBinding id) @@ -1247,15 +1222,14 @@ checkRole co r1 r2 ptext (sLit "got") <+> ppr r2 $$ ptext (sLit "in") <+> ppr co) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Error messages} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} dumpLoc :: LintLocInfo -> (SrcLoc, SDoc) dumpLoc (RhsOf v) @@ -1294,9 +1268,7 @@ pp_binders bs = sep (punctuate comma (map pp_binder bs)) pp_binder :: Var -> SDoc pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)] -\end{code} -\begin{code} ------------------------------------------------------ -- Messages for case expressions @@ -1468,4 +1440,3 @@ dupExtVars :: [[Name]] -> MsgDoc dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) -\end{code} diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.hs index 537cc01b43..9037fcb126 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.hs @@ -1,10 +1,10 @@ -% -% (c) The University of Glasgow, 1994-2006 -% +{- +(c) The University of Glasgow, 1994-2006 + Core pass to saturate constructors and PrimOps +-} -\begin{code} {-# LANGUAGE BangPatterns, CPP #-} module CorePrep ( @@ -56,8 +56,8 @@ import Config import Data.Bits import Data.List ( mapAccumL ) import Control.Monad -\end{code} +{- -- --------------------------------------------------------------------------- -- Overview -- --------------------------------------------------------------------------- @@ -142,21 +142,21 @@ Here is the syntax of the Core produced by CorePrep: We define a synonym for each of these non-terminals. Functions with the corresponding name produce a result in that syntax. +-} -\begin{code} type CpeTriv = CoreExpr -- Non-terminal 'triv' type CpeApp = CoreExpr -- Non-terminal 'app' type CpeBody = CoreExpr -- Non-terminal 'body' type CpeRhs = CoreExpr -- Non-terminal 'rhs' -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Top level stuff -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} corePrepPgm :: DynFlags -> HscEnv -> CoreProgram -> [TyCon] -> IO CoreProgram corePrepPgm dflags hsc_env binds data_tycons = do showPass dflags "CorePrep" @@ -202,8 +202,8 @@ mkDataConWorkers data_tycons | tycon <- data_tycons, -- CorePrep will eta-expand it data_con <- tyConDataCons tycon, let id = dataConWorkId data_con ] -\end{code} +{- Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings @@ -335,13 +335,13 @@ Into this one: (Since f is not considered to be free in its own RHS.) -%************************************************************************ -%* * +************************************************************************ +* * The main code -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) @@ -349,7 +349,7 @@ cpeBind top_lvl env (NonRec bndr rhs) ; let dmd = idDemandInfo bndr is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive - dmd + dmd is_unlifted env bndr1 rhs ; let new_float = mkFloat dmd is_unlifted bndr2 rhs2 @@ -697,7 +697,7 @@ cpeApp env expr -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound -cpeArg :: CorePrepEnv -> Demand +cpeArg :: CorePrepEnv -> Demand -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) cpeArg env dmd arg arg_ty = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda @@ -719,8 +719,8 @@ cpeArg env dmd arg arg_ty is_unlifted = isUnLiftedType arg_ty is_strict = isStrictDmd dmd want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) -\end{code} +{- Note [Floating unlifted arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider C (let v* = expensive in v) @@ -741,8 +741,8 @@ because that has different strictness. Hence the use of 'allLazy'. maybeSaturate deals with saturating primops and constructors The type is the type of the entire application +-} -\begin{code} maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs maybeSaturate fn expr n_args | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg @@ -783,8 +783,8 @@ saturateDataToTag sat_expr eval_data2tag_arg other -- Should not happen = pprPanic "eval_data2tag" (ppr other) -\end{code} +{- Note [dataToTag magic] ~~~~~~~~~~~~~~~~~~~~~~ Horrid: we must ensure that the arg of data2TagOp is evaluated @@ -795,13 +795,13 @@ How might it not be evaluated? Well, we might have floated it out of the scope of a `seq`, or dropped the `seq` altogether. -%************************************************************************ -%* * +************************************************************************ +* * Simple CoreSyn operations -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- we don't ignore any Tickishes at the moment. ignoreTickish :: Tickish Id -> Bool ignoreTickish _ = False @@ -817,8 +817,8 @@ cpe_ExprIsTrivial (Tick t e) = not (tickishIsCode t) && cpe_ExprIsTrivial e cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body cpe_ExprIsTrivial _ = False -\end{code} +{- -- ----------------------------------------------------------------------------- -- Eta reduction -- ----------------------------------------------------------------------------- @@ -858,14 +858,14 @@ and now we do NOT want eta expansion to give Instead CoreArity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y +-} -\begin{code} cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs cpeEtaExpand arity expr | arity == 0 = expr | otherwise = etaExpand arity expr -\end{code} +{- -- ----------------------------------------------------------------------------- -- Eta reduction -- ----------------------------------------------------------------------------- @@ -876,8 +876,8 @@ trivial (like f, or f Int). But for deLam it would be enough to get to a partial application: case x of { p -> \xs. map f xs } ==> case x of { p -> map f } +-} -\begin{code} tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _) | ok_to_eta_reduce f @@ -910,20 +910,19 @@ tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) fvs = exprFreeVars r tryEtaReducePrep _ _ = Nothing -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Floats -%* * -%************************************************************************ +* * +************************************************************************ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets so that we can see the one-shot thunks. +-} -\begin{code} data FloatingBind = FloatLet CoreBind -- Rhs of bindings are CpeRhss -- They are always of lifted type; @@ -1093,16 +1092,15 @@ allLazyNested :: RecFlag -> Floats -> Bool allLazyNested _ (Floats OkToSpec _) = True allLazyNested _ (Floats NotOkToSpec _) = False allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Cloning -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- --------------------------------------------------------------------------- -- The environment -- --------------------------------------------------------------------------- @@ -1208,4 +1206,3 @@ newVar ty = seqType ty `seq` do uniq <- getUniqueM return (mkSysLocal (fsLit "sat") uniq ty) -\end{code} diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.hs index 76f42f4bb9..82e18ca5ba 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Utility functions on @Core@ syntax +-} -\begin{code} {-# LANGUAGE CPP #-} module CoreSubst ( -- * Main data types @@ -82,16 +82,15 @@ import FastString import Data.List import TysWiredIn -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Substitutions} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | A substitution environment, containing both 'Id' and 'TyVar' substitutions. -- -- Some invariants apply to how you use the substitution: @@ -124,8 +123,8 @@ data Subst -- Types.TvSubstEnv -- -- INVARIANT 3: See Note [Extending the Subst] -\end{code} +{- Note [Extending the Subst] ~~~~~~~~~~~~~~~~~~~~~~~~~~ For a core Subst, which binds Ids as well, we make a different choice for Ids @@ -179,8 +178,8 @@ TvSubstEnv and CvSubstEnv? * For TyVars, only coercion variables can possibly change, and they are easy to spot +-} -\begin{code} -- | An environment for substituting for 'Id's type IdSubstEnv = IdEnv CoreExpr @@ -331,11 +330,9 @@ extendInScopeIds (Subst in_scope ids tvs cvs) vs setInScope :: Subst -> InScopeSet -> Subst setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs -\end{code} -Pretty printing, for debugging only +-- Pretty printing, for debugging only -\begin{code} instance Outputable Subst where ppr (Subst in_scope ids tvs cvs) = ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) @@ -343,16 +340,15 @@ instance Outputable Subst where $$ ptext (sLit " TvSubst =") <+> ppr tvs $$ ptext (sLit " CvSubst =") <+> ppr cvs <> char '>' -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Substituting expressions -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only -- apply the substitution /once/: see "CoreSubst#apply_once" -- @@ -428,9 +424,7 @@ substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss')) (bndrs, rhss) = unzip pairs (subst', bndrs') = substRecBndrs subst bndrs rhss' = map (subst_expr subst') rhss -\end{code} -\begin{code} -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply -- by running over the bindings with an empty substitution, because substitution -- returns a result that has no-shadowing guaranteed. @@ -442,21 +436,20 @@ substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss')) -- short and simple that I'm going to leave it here deShadowBinds :: CoreProgram -> CoreProgram deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Substituting binders -%* * -%************************************************************************ +* * +************************************************************************ Remember that substBndr and friends are used when doing expression substitution only. Their only business is substitution, so they preserve all IdInfo (suitably substituted). For example, we *want* to preserve occ info in rules. +-} -\begin{code} -- | Substitutes a 'Var' for another one according to the 'Subst' given, returning -- the result and an updated 'Subst' that should be used by subsequent substitutions. -- 'IdInfo' is preserved by this process, although it is substituted into appropriately. @@ -476,10 +469,7 @@ substRecBndrs subst bndrs = (new_subst, new_bndrs) where -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs -\end{code} - -\begin{code} substIdBndr :: SDoc -> Subst -- ^ Substitution to use for the IdInfo -> Subst -> Id -- ^ Substitution and Id to transform @@ -513,12 +503,12 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id no_change = id1 == old_id -- See Note [Extending the Subst] -- it's /not/ necessary to check mb_new_info and no_type_change -\end{code} +{- Now a variant that unconditionally allocates a new unique. It also unconditionally zaps the OccInfo. +-} -\begin{code} -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for -- each variable in its output. It substitutes the IdInfo though. cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) @@ -564,20 +554,19 @@ clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Types and Coercions -%* * -%************************************************************************ +* * +************************************************************************ For types and coercions we just call the corresponding functions in Type and Coercion, but we have to repackage the substitution, from a Subst to a TvSubst. +-} -\begin{code} substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of @@ -609,16 +598,15 @@ getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv -- | See 'Coercion.substCo' substCo :: Subst -> Coercion -> Coercion substCo subst co = Coercion.substCo (getCvSubst subst) co -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \section{IdInfo substitution} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} substIdType :: Subst -> Id -> Id substIdType subst@(Subst _ _ tv_env cv_env) id | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id @@ -760,8 +748,8 @@ for an Id in a breakpoint. We ensure this by never storing an Id with an unlifted type in a Breakpoint - see Coverage.mkTickish. Breakpoints can't handle free variables with unlifted types anyway. -} -\end{code} +{- Note [Worker inlining] ~~~~~~~~~~~~~~~~~~~~~~ A worker can get sustituted away entirely. @@ -774,11 +762,11 @@ In all all these cases we simply drop the special case, returning to InlVanilla. The WARN is just so I can see if it happens a lot. -%************************************************************************ -%* * +************************************************************************ +* * The Very Simple Optimiser -%* * -%************************************************************************ +* * +************************************************************************ Note [Optimise coercion boxes agressively] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -830,8 +818,8 @@ we wouldn't simplify this expression at all: The rule LHS desugarer can't deal with Let at all, so we need to push that box into the use sites. +-} -\begin{code} simpleOptExpr :: CoreExpr -> CoreExpr -- Do simple optimisation on an expression -- The optimisation is very straightforward: just @@ -1093,8 +1081,8 @@ simpleUnfoldingFun :: IdUnfoldingFun simpleUnfoldingFun id | isAlwaysActive (idInlineActivation id) = idUnfolding id | otherwise = noUnfolding -\end{code} +{- Note [Inline prag in simplOpt] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If there's an INLINE/NOINLINE pragma that restricts the phase in @@ -1121,11 +1109,11 @@ match if we replace coerce by its unfolding on the LHS, because that is the core that the rule matching engine will find. So do that for everything that has a compulsory unfolding. Also see Note [Desugaring coerce as cast] in Desugar -%************************************************************************ -%* * +************************************************************************ +* * exprIsConApp_maybe -%* * -%************************************************************************ +* * +************************************************************************ Note [exprIsConApp_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1157,8 +1145,8 @@ Just (':', [Char], ['a', unpackCString# "bc"]). We need to be careful about UTF8 strings here. ""# contains a ByteString, so we must parse it back into a FastString to split off the first character. That way we can treat unpackCString# and unpackCStringUtf8# in the same way. +-} -\begin{code} data ConCont = CC [CoreExpr] Coercion -- Substitution already applied @@ -1314,8 +1302,8 @@ stripTypeArgs :: [CoreExpr] -> [Type] stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) [ty | Type ty <- args] -- We really do want isTypeArg here, not isTyCoArg! -\end{code} +{- Note [Unfolding DFuns] ~~~~~~~~~~~~~~~~~~~~~~ DFuns look like @@ -1333,8 +1321,8 @@ Note [DFun arity check] Here we check that the total number of supplied arguments (inclding type args) matches what the dfun is expecting. This may be *less* than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn +-} -\begin{code} exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal -- Same deal as exprIsConApp_maybe, but much simpler -- Nevertheless we do need to look through unfoldings for @@ -1347,8 +1335,8 @@ exprIsLiteral_maybe env@(_, id_unf) e Var v | Just rhs <- expandUnfolding_maybe (id_unf v) -> exprIsLiteral_maybe env rhs _ -> Nothing -\end{code} +{- Note [exprIsLambda_maybe] ~~~~~~~~~~~~~~~~~~~~~~~~~~ exprIsLambda_maybe will, given an expression `e`, try to turn it into the form @@ -1358,8 +1346,8 @@ has a greater arity than arguments are present. Currently, it is used in Rules.match, and is required to make "map coerce = coerce" match. +-} -\begin{code} exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr) -- See Note [exprIsLambda_maybe] @@ -1418,5 +1406,3 @@ pushCoercionIntoLambda in_scope x e co | otherwise = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) Nothing - -\end{code} diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.hs index 47418e22ec..0c6ee7c38e 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.hs @@ -1,9 +1,8 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} -\begin{code} {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection @@ -105,17 +104,17 @@ import Data.Word infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The main data types} -%* * -%************************************************************************ +* * +************************************************************************ These data types are the heart of the compiler +-} -\begin{code} -- | This is the data type that represents GHCs core intermediate language. Currently -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose, -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>. @@ -287,8 +286,8 @@ data AltCon data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] deriving (Data, Typeable) -\end{code} +{- Note [Shadowing] ~~~~~~~~~~~~~~~~ While various passes attempt to rename on-the-fly in a manner that @@ -422,13 +421,13 @@ if for no other reason that we don't need to instantiate the (~) at an unboxed type. -%************************************************************************ -%* * +************************************************************************ +* * Ticks -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Allows attaching extra information to points in expressions -- If you edit this type, you may need to update the GHC formalism @@ -513,19 +512,18 @@ tickishCanSplit :: Tickish Id -> Bool tickishCanSplit Breakpoint{} = False tickishCanSplit HpcTick{} = False tickishCanSplit _ = True -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Transformation rules} -%* * -%************************************************************************ +* * +************************************************************************ The CoreRule type and its friends are dealt with mainly in CoreRules, but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. +-} -\begin{code} -- | A 'CoreRule' is: -- -- * \"Local\" if the function it is a rule for is defined in the @@ -620,36 +618,34 @@ isLocalRule = ru_local -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side setRuleIdName :: Name -> CoreRule -> CoreRule setRuleIdName nm ru = ru { ru_fn = nm } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Vectorisation declarations} -%* * -%************************************************************************ +* * +************************************************************************ Representation of desugared vectorisation declarations that are fed to the vectoriser (via 'ModGuts'). +-} -\begin{code} data CoreVect = Vect Id CoreExpr | NoVect Id | VectType Bool TyCon (Maybe TyCon) | VectClass TyCon -- class tycon | VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Unfoldings -%* * -%************************************************************************ +* * +************************************************************************ The @Unfolding@ type is declared here to avoid numerous loops +-} -\begin{code} -- | Records the /unfolding/ of an identifier, which is approximately the form the -- identifier would have if we substituted its definition in for the identifier. -- This type should be treated as abstract everywhere except in "CoreUnfold" @@ -770,8 +766,8 @@ data UnfoldingGuidance -- (where there are the right number of arguments.) | UnfNever -- The RHS is big, so don't inline it -\end{code} +{- Note [Historical note: unfoldings for wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to have a nice clever scheme in interface files for @@ -818,8 +814,8 @@ why we record the number of expected arguments in the DFunUnfolding. Note that although it's an Arity, it's most convenient for it to give the *total* number of arguments, both type and value. See the use site in exprIsConApp_maybe. +-} -\begin{code} -- Constants for the UnfWhen constructor needSaturated, unSaturatedOk :: Bool needSaturated = False @@ -853,9 +849,7 @@ seqUnfolding _ = () seqGuidance :: UnfoldingGuidance -> () seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () seqGuidance _ = () -\end{code} -\begin{code} isStableSource :: UnfoldingSource -> Bool -- Keep the unfolding template isStableSource InlineCompulsory = True @@ -963,8 +957,8 @@ neverUnfoldGuidance _ = False canUnfold :: Unfolding -> Bool canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) canUnfold _ = False -\end{code} +{- Note [InlineRules] ~~~~~~~~~~~~~~~~~ When you say @@ -1008,13 +1002,13 @@ the occurrence info is wrong without a loop breaker marked -%************************************************************************ -%* * +************************************************************************ +* * AltCon -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- The Ord is needed for the FiniteMap used in the lookForConstructor -- in SimplEnv. If you declared that lookForConstructor *ignores* -- constructor-applications with LitArg args, then you could get @@ -1044,13 +1038,13 @@ cmpAltCon (LitAlt _) DEFAULT = GT cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> ppr con1 <+> ppr con2 ) LT -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Useful synonyms} -%* * -%************************************************************************ +* * +************************************************************************ Note [CoreProgram] ~~~~~~~~~~~~~~~~~~ @@ -1071,8 +1065,7 @@ a list of CoreBind bindings where possible. So the program typically starts life as a single giant Rec, which is then dependency-analysed into smaller chunks. - -\begin{code} +-} -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in coreSyn/CoreLint.lhs @@ -1089,15 +1082,15 @@ type CoreArg = Arg CoreBndr type CoreBind = Bind CoreBndr -- | Case alternatives where binders are 'CoreBndr's type CoreAlt = Alt CoreBndr -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Tagging} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Binders are /tagged/ with a t data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" @@ -1132,16 +1125,15 @@ deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs deTagAlt :: TaggedAlt t -> CoreAlt deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Core-constructing functions with checking} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to -- use 'MkCore.mkCoreApps' if possible mkApps :: Expr b -> [Arg b] -> Expr b @@ -1253,16 +1245,15 @@ varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) varsToCoreExprs :: [CoreBndr] -> [Expr b] varsToCoreExprs vs = map varToCoreExpr vs -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Simple access functions} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Extract every variable by this group bindersOf :: Bind b -> [b] -- If you edit this function, you may need to update the GHC formalism @@ -1287,9 +1278,7 @@ flattenBinds :: [Bind b] -> [(b, Expr b)] flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds flattenBinds [] = [] -\end{code} -\begin{code} -- | We often want to strip off leading lambdas before getting down to -- business. This function is your friend. collectBinders :: Expr b -> ([b], Expr b) @@ -1325,9 +1314,7 @@ collectValBinders expr where go ids (Lam b e) | isId b = go (b:ids) e go ids body = (reverse ids, body) -\end{code} -\begin{code} -- | Takes a nested application expression and returns the the function -- being applied and the arguments to which it is applied collectArgs :: Expr b -> (Expr b, [Arg b]) @@ -1336,20 +1323,20 @@ collectArgs expr where go (App f a) as = go f (a:as) go e as = (e, as) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Predicates} -%* * -%************************************************************************ +* * +************************************************************************ At one time we optionally carried type arguments through to runtime. @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, i.e. if type applications are actual lambdas because types are kept around at runtime. Similarly isRuntimeArg. +-} -\begin{code} -- | Will this variable exist at runtime? isRuntimeVar :: Var -> Bool isRuntimeVar = isId @@ -1384,16 +1371,15 @@ valBndrCount = count isId -- | The number of argument expressions that are values rather than types at their top level valArgCount :: [Arg b] -> Int valArgCount = count isValArg -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Seq stuff} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} seqExpr :: CoreExpr -> () seqExpr (Var v) = v `seq` () seqExpr (Lit lit) = lit `seq` () @@ -1439,15 +1425,15 @@ seqRules [] = () seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules seqRules (BuiltinRule {} : rules) = seqRules rules -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Annotated core} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Annotated core: allows annotation at every node in the tree type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) @@ -1472,9 +1458,7 @@ type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) data AnnBind bndr annot = AnnNonRec bndr (AnnExpr bndr annot) | AnnRec [(bndr, AnnExpr bndr annot)] -\end{code} -\begin{code} -- | Takes a nested application expression and returns the the function -- being applied and the arguments to which it is applied collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) @@ -1483,9 +1467,7 @@ collectAnnArgs expr where go (_, AnnApp f a) as = go f (a:as) go e as = (e, as) -\end{code} -\begin{code} deAnnotate :: AnnExpr bndr annot -> Expr bndr deAnnotate (_, e) = deAnnotate' e @@ -1510,9 +1492,7 @@ deAnnotate' (AnnCase scrut v t alts) deAnnAlt :: AnnAlt bndr annot -> Alt bndr deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) -\end{code} -\begin{code} -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) collectAnnBndrs e @@ -1520,4 +1500,3 @@ collectAnnBndrs e where collect bs (_, AnnLam b body) = collect (b:bs) body collect bs body = (reverse bs, body) -\end{code} diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.hs index 810a71ca6c..7f09c68ca2 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.hs @@ -1,12 +1,12 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1996-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + This module contains "tidying" code for *nested* expressions, bindings, rules. The code for *top-level* bindings is in TidyPgm. +-} -\begin{code} {-# LANGUAGE CPP #-} module CoreTidy ( tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding @@ -27,16 +27,15 @@ import Name hiding (tidyNameOcc) import SrcLoc import Maybes import Data.List -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Tidying expressions, rules} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tidyBind :: TidyEnv -> CoreBind -> (TidyEnv, CoreBind) @@ -105,16 +104,15 @@ tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, ru_rhs = tidyExpr env' rhs, ru_fn = tidyNameOcc env fn, ru_rough = map (fmap (tidyNameOcc env')) mb_ns } -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Tidying non-top-level binders} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} tidyNameOcc :: TidyEnv -> Name -> Name -- In rules and instances, we have Names, and we must tidy them too -- Fortunately, we can lookup in the VarEnv with a name @@ -223,8 +221,8 @@ tidyUnfolding tidy_env | otherwise = unf_from_rhs tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon -\end{code} +{- Note [Tidy IdInfo] ~~~~~~~~~~~~~~~~~~ All nested Ids now have the same IdInfo, namely vanillaIdInfo, which @@ -268,9 +266,7 @@ optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we must preserve this info in inlinings. This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} - -\begin{code} (=:) :: a -> (a -> b) -> b m =: k = m `seq` k m -\end{code} diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.hs index fd485ae2b7..dc9f95e73a 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -1,7 +1,7 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1994-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + Core-syntax unfoldings @@ -13,8 +13,8 @@ unfoldings, capturing ``higher-level'' things we know about a binding, usually things that the simplifier found out (e.g., ``it's a literal''). In the corner of a @CoreUnfolding@ unfolding, you will find, unsurprisingly, a Core expression. +-} -\begin{code} {-# LANGUAGE CPP #-} module CoreUnfold ( @@ -66,16 +66,15 @@ import ForeignCall import qualified Data.ByteString as BS import Data.Maybe -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Making unfoldings} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding mkTopUnfolding dflags = mkUnfolding dflags InlineRhs True {- Top level -} @@ -184,8 +183,8 @@ specUnfolding _ _ _ _ _ = noUnfolding spec_doc :: SDoc spec_doc = ptext (sLit "specUnfolding") -\end{code} +{- Note [Specialising unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we specialise a function for some given type-class arguments, we use @@ -214,9 +213,8 @@ specUnfolding to specialise its unfolding. Some important points: we keep it (so the specialised thing too will always inline) if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs (which arises from INLINEABLE), we discard it +-} - -\begin{code} mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it @@ -253,8 +251,8 @@ mkUnfolding dflags src top_lvl is_bottoming expr guidance = calcUnfoldingGuidance dflags expr -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))! -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] -\end{code} +{- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do occurrence-analysis of unfoldings once and for all, when the @@ -297,13 +295,13 @@ it gets fixed up next round. And it should be rare, because large let-bound things that are dead are usually caught by preInlineUnconditionally -%************************************************************************ -%* * +************************************************************************ +* * \subsection{The UnfoldingGuidance type} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} inlineBoringOk :: CoreExpr -> Bool -- See Note [INLINE for small functions] -- True => the result of inlining the expression is @@ -361,8 +359,8 @@ calcUnfoldingGuidance dflags expr plus_disc | isFunTy (idType bndr) = max | otherwise = (+) -- See Note [Function and non-function discounts] -\end{code} +{- Note [Computing the size of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The basic idea of sizeExpr is obvious enough: count nodes. But getting the @@ -457,8 +455,8 @@ Things to note: NB: you might think that PostInlineUnconditionally would do this but it doesn't fire for top-level things; see SimplUtils Note [Top level and postInlineUnconditionally] +-} -\begin{code} uncondInline :: CoreExpr -> Arity -> Int -> Bool -- Inline unconditionally if there no size increase -- Size of call is arity (+1 for the function) @@ -466,10 +464,7 @@ uncondInline :: CoreExpr -> Arity -> Int -> Bool uncondInline rhs arity size | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) -\end{code} - -\begin{code} sizeExpr :: DynFlags -> FastInt -- Bomb out if it gets bigger than this -> [Id] -- Arguments; we're interested in which of these @@ -630,10 +625,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr -- an expression of type State# RealWorld must be a variable isRealWorldExpr (Var id) = isRealWorldId id isRealWorldExpr _ = False -\end{code} - -\begin{code} -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by CoreUnfold.sizeExpr @@ -699,8 +691,8 @@ conSize dc n_val_args -- See Note [Constructor size and result discount] | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (1 + n_val_args))) -\end{code} +{- Note [Constructor size and result discount] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Treat a constructors application as size 10, regardless of how many @@ -771,8 +763,8 @@ There's no point in doing so -- any optimisations will see the S# through n's unfolding. Nor will a big size inhibit unfoldings functions that mention a literal Integer, because the float-out pass will float all those constants to top level. +-} -\begin{code} primOpSize :: PrimOp -> Int -> ExprSize primOpSize op n_val_args = if primOpOutOfLine op @@ -800,8 +792,8 @@ augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (iUnbox (ufFunAppDiscount dflags)) lamScrutDiscount _ TooBig = TooBig -\end{code} +{- Note [addAltSize result discounts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When adding the size of alternatives, we *add* the result discounts @@ -854,8 +846,8 @@ In a function application (f a b) get a saturated application) Code for manipulating sizes +-} -\begin{code} data ExprSize = TooBig | SizeIs FastInt -- Size found !(Bag (Id,Int)) -- Arguments cased herein, and discount for each such @@ -886,21 +878,20 @@ sizeN :: Int -> ExprSize sizeZero = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} -%* * -%************************************************************************ +* * +************************************************************************ We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that we ``couldn't possibly use'' on the other side. Can be overridden w/ flaggery. Just the same as smallEnoughToInline, except that it has no actual arguments. +-} -\begin{code} couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool couldBeSmallEnoughToInline dflags threshold rhs = case sizeExpr dflags (iUnbox threshold) [] body of @@ -947,8 +938,8 @@ certainlyWillInline _ unf@(DFunUnfolding {}) certainlyWillInline _ _ = Nothing -\end{code} +{- Note [certainlyWillInline: be careful of thunks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't claim that thunks will certainly inline, because that risks work @@ -959,11 +950,11 @@ found that the WorkWrap phase thought that was certainlyWillInline, so the addition got duplicated. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{callSiteInline} -%* * -%************************************************************************ +* * +************************************************************************ This is the key function. It decides whether to inline a variable at a call site @@ -980,8 +971,8 @@ NOTE: we don't want to inline top-level functions that always diverge. It just makes the code bigger. Tt turns out that the convenient way to prevent them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId +-} -\begin{code} callSiteInline :: DynFlags -> Id -- The Id -> Bool -- True <=> unfolding is active @@ -1117,8 +1108,8 @@ tryUnfolding dflags id lone_variable RhsCtxt -> uf_arity > 0 -- _ -> not is_top && uf_arity > 0 -- Note [Nested functions] -- Note [Inlining in ArgCtxt] -\end{code} +{- Note [Unfold into lazy contexts], Note [RHS of lets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the call is the argument of a function with a RULE, or the RHS of a let, @@ -1310,8 +1301,8 @@ This kind of thing can occur if you have foo = let x = e in (x,x) which Roman did. +-} -\begin{code} computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int computeDiscount dflags arg_discounts res_discount arg_infos cont_info @@ -1361,13 +1352,13 @@ computeDiscount dflags arg_discounts res_discount arg_infos cont_info -- Otherwise we, rather arbitrarily, threshold it. Yuk. -- But we want to aovid inlining large functions that return -- constructors into contexts that are simply "interesting" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Interesting arguments -%* * -%************************************************************************ +* * +************************************************************************ Note [Interesting arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1398,8 +1389,8 @@ where df is con-like. Then we'd really like to inline 'f' so that the rule for (*) (df d) can fire. To do this a) we give a discount for being an argument of a class-op (eg (*) d) b) we say that a con-like argument (eg (df d)) is interesting +-} -\begin{code} data ArgSummary = TrivArg -- Nothing interesting | NonTrivArg -- Arg has structure | ValueArg -- Arg is a con-app or PAP @@ -1439,4 +1430,3 @@ interestingArg e = go e 0 nonTriv :: ArgSummary -> Bool nonTriv TrivArg = False nonTriv _ = True -\end{code} diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.hs index 86db946f26..ffb327523c 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + Utility functions on @Core@ syntax +-} -\begin{code} {-# LANGUAGE CPP #-} -- | Commonly useful utilites for manipulating the Core language @@ -71,16 +71,15 @@ import Platform import Util import Pair import Data.List -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Find the type of a Core atom/expression} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} exprType :: CoreExpr -> Type -- ^ Recover the type of a well-typed Core expression. Fails when -- applied to the actual 'CoreSyn.Type' expression as it cannot @@ -88,7 +87,7 @@ exprType :: CoreExpr -> Type exprType (Var var) = idType var exprType (Lit lit) = literalType lit exprType (Coercion co) = coercionType co -exprType (Let bind body) +exprType (Let bind body) | NonRec tv rhs <- bind -- See Note [Type bindings] , Type ty <- rhs = substTyWith [tv] [ty] (exprType body) | otherwise = exprType body @@ -116,15 +115,15 @@ coreAltsType :: [CoreAlt] -> Type -- ^ Returns the type of the first alternative, which should be the same as for all alternatives coreAltsType (alt:_) = coreAltType alt coreAltsType [] = panic "corAltsType" -\end{code} +{- Note [Type bindings] ~~~~~~~~~~~~~~~~~~~~ Core does allow type bindings, although such bindings are not much used, except in the output of the desuguarer. Example: let a = Int in (\x:a. x) -Given this, exprType must be careful to substitute 'a' in the +Given this, exprType must be careful to substitute 'a' in the result type (Trac #8522). Note [Existential variables and silly type synonyms] @@ -150,8 +149,8 @@ Various possibilities suggest themselves: - Expand synonyms on the fly, when the problem arises. That is what we are doing here. It's not too expensive, I think. +-} -\begin{code} applyTypeToArg :: Type -> CoreExpr -> Type -- ^ Determines the type resulting from applying an expression with given type -- to a given argument expression @@ -180,15 +179,15 @@ applyTypeToArgs e op_ty args panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e , ptext (sLit "Type:") <+> ppr op_ty , ptext (sLit "Args:") <+> ppr args ] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Attaching notes} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions mkCast :: CoreExpr -> Coercion -> CoreExpr @@ -196,7 +195,7 @@ mkCast e co | ASSERT2( coercionRole co == Representational , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) ) isReflCo co = e -mkCast (Coercion e_co) co +mkCast (Coercion e_co) co | isCoVarType (pSnd (coercionKind co)) -- The guard here checks that g has a (~#) on both sides, -- otherwise decomposeCo fails. Can in principle happen @@ -219,9 +218,7 @@ mkCast expr co -- else WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co)) (Cast expr co) -\end{code} -\begin{code} -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: Tickish Id -> CoreExpr -> CoreExpr @@ -288,15 +285,15 @@ tickHNFArgs t e = push t e push t (App f (Type u)) = App (push t f) (Type u) push t (App f arg) = App (push t f) (mkTick t arg) push _t e = e -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Other expression construction} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr -- ^ @bindNonRec x r b@ produces either: -- @@ -323,9 +320,7 @@ needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs) -- Make a case expression instead of a let -- These can arise either from the desugarer, -- or from beta reductions: (\x.e) (x +# y) -\end{code} -\begin{code} mkAltExpr :: AltCon -- ^ Case alternative constructor -> [CoreBndr] -- ^ Things bound by the pattern match -> [Type] -- ^ The type arguments to the case alternative @@ -338,19 +333,18 @@ mkAltExpr (LitAlt lit) [] [] = Lit lit mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Taking expressions apart} -%* * -%************************************************************************ +* * +************************************************************************ The default alternative must be first, if it exists at all. This makes it easy to find, though it makes matching marginally harder. +-} -\begin{code} -- | Extract the default case alternative findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) @@ -404,16 +398,14 @@ trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] trimConArgs DEFAULT args = ASSERT( null args ) [] trimConArgs (LitAlt _) args = ASSERT( null args ) [] trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args -\end{code} -\begin{code} filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon -> Type -- ^ Type of scrutinee (used to prune possibilities) -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee -> [(AltCon, [Var], a)] -- ^ Alternatives -> ([AltCon], Bool, [(AltCon, [Var], a)]) -- Returns: - -- 1. Constructors that will never be encountered by the + -- 1. Constructors that will never be encountered by the -- *default* case (if any). A superset of imposs_cons -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) -- 3. The new alternatives, trimmed by @@ -424,13 +416,13 @@ filterAlts :: [Unique] -- ^ Supply of uniques used in case we have t -- -- NB: the final list of alternatives may be empty: -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- which GHC allows, or if the imposs_cons covers all constructors (after taking -- account of GADTs), then no alternatives can match. -- -- If callers need to preserve the invariant that there is always at least one branch -- in a "case" statement then they will need to manually add a dummy case branch that just -- calls "error" or similar. -filterAlts us ty imposs_cons alts +filterAlts us ty imposs_cons alts | Just (tycon, inst_tys) <- splitTyConApp_maybe ty = filter_alts tycon inst_tys | otherwise @@ -439,31 +431,31 @@ filterAlts us ty imposs_cons alts (alts_wo_default, maybe_deflt) = findDefault alts alt_cons = [con | (con,_,_) <- alts_wo_default] - filter_alts tycon inst_tys + filter_alts tycon inst_tys = (imposs_deflt_cons, refined_deflt, merged_alts) where trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default imposs_deflt_cons = nub (imposs_cons ++ alt_cons) - -- "imposs_deflt_cons" are handled - -- EITHER by the context, + -- "imposs_deflt_cons" are handled + -- EITHER by the context, -- OR by a non-DEFAULT branch in this case expression. merged_alts = mergeAlts trimmed_alts (maybeToList maybe_deflt') - -- We need the mergeAlts in case the new default_alt + -- We need the mergeAlts in case the new default_alt -- has turned into a constructor alternative. -- The merge keeps the inner DEFAULT at the front, if there is one -- and interleaves the alternatives in the right order (refined_deflt, maybe_deflt') = case maybe_deflt of Nothing -> (False, Nothing) - Just deflt_rhs - | isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + Just deflt_rhs + | isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: -- case x of { DEFAULT -> e } -- and we don't want to fill in a default for them! , Just all_cons <- tyConDataCons_maybe tycon - , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type + , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type impossible con = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con -> case filterOut impossible all_cons of -- Eliminate the default alternative @@ -489,8 +481,8 @@ filterAlts us ty imposs_cons alts impossible_alt _ (con, _, _) | con `elem` imposs_cons = True impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con impossible_alt _ _ = False -\end{code} +{- Note [Unreachable code] ~~~~~~~~~~~~~~~~~~~~~~~ It is possible (although unusual) for GHC to find a case expression @@ -521,11 +513,11 @@ Similar things can happen (augmented by GADTs) when the Simplifier filters down the matching alternatives in Simplify.rebuildCase. -%************************************************************************ -%* * +************************************************************************ +* * exprIsTrivial -%* * -%************************************************************************ +* * +************************************************************************ Note [exprIsTrivial] ~~~~~~~~~~~~~~~~~~~~ @@ -552,8 +544,8 @@ Note [Tick trivial] Ticks are not trivial. If we treat "tick<n> x" as trivial, it will be inlined inside lambdas and the entry count will be skewed, for example. Furthermore "scc<n> x" will turn into just "x" in mkTick. +-} -\begin{code} exprIsTrivial :: CoreExpr -> Bool exprIsTrivial (Var _) = True -- See Note [Variables are trivial] exprIsTrivial (Type _) = True @@ -564,14 +556,14 @@ exprIsTrivial (Tick _ _) = False -- See Note [Tick trivial] exprIsTrivial (Cast e _) = exprIsTrivial e exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial _ = False -\end{code} +{- When substituting in a breakpoint we need to strip away the type cruft from a trivial expression and get back to the Id. The invariant is that the expression we're substituting was originally trivial according to exprIsTrivial. +-} -\begin{code} getIdFromTrivialExpr :: CoreExpr -> Id getIdFromTrivialExpr e = go e where go (Var v) = v @@ -579,14 +571,14 @@ getIdFromTrivialExpr e = go e go (Cast e _) = go e go (Lam b e) | not (isRuntimeVar b) = go e go e = pprPanic "getIdFromTrivialExpr" (ppr e) -\end{code} +{- exprIsBottom is a very cheap and cheerful function; it may return False for bottoming expressions, but it never costs much to ask. See also CoreArity.exprBotStrictness_maybe, but that's a bit more expensive. +-} -\begin{code} exprIsBottom :: CoreExpr -> Bool exprIsBottom e = go 0 e @@ -598,14 +590,13 @@ exprIsBottom e go n (Cast e _) = go n e go n (Let _ e) = go n e go _ _ = False -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * exprIsDupable -%* * -%************************************************************************ +* * +************************************************************************ Note [exprIsDupable] ~~~~~~~~~~~~~~~~~~~~ @@ -618,9 +609,8 @@ Note [exprIsDupable] Its only purpose is to avoid fruitless let-binding and then inlining of case join points +-} - -\begin{code} exprIsDupable :: DynFlags -> CoreExpr -> Bool exprIsDupable dflags e = isJust (go dupAppSize e) @@ -644,13 +634,13 @@ dupAppSize = 8 -- Size of term we are prepared to duplicate -- This is *just* big enough to make test MethSharing -- inline enough join points. Really it should be -- smaller, and could be if we fixed Trac #4960. -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * exprIsCheap, exprIsExpandable -%* * -%************************************************************************ +* * +************************************************************************ Note [exprIsWorkFree] ~~~~~~~~~~~~~~~~~~~~~ @@ -676,11 +666,11 @@ The function 'noFactor' is heap-allocated and then called. Turns out that 'notDivBy' is strict in its THIRD arg, but that is invisible to the caller of noFactor, which therefore cannot do w/w and heap-allocates noFactor's argument. At the moment (May 12) we are just -going to put up with this, because the previous more aggressive inlining -(which treated 'noFactor' as work-free) was duplicating primops, which +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which in turn was making inner loops of array calculations runs slow (#5623) +-} -\begin{code} exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] exprIsWorkFree e = go 0 e @@ -689,7 +679,7 @@ exprIsWorkFree e = go 0 e go _ (Type {}) = True go _ (Coercion {}) = True go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) + go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut) [ go n rhs | (_,_,rhs) <- alts ] -- See Note [Case expressions are work-free] go _ (Let {}) = False @@ -700,8 +690,8 @@ exprIsWorkFree e = go 0 e | otherwise = go n e go n (App f e) | isRuntimeArg e = exprIsWorkFree e && go (n+1) f | otherwise = go n f -\end{code} +{- Note [Case expressions are work-free] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Are case-expressions work-free? Consider @@ -750,8 +740,8 @@ Note that exprIsHNF does not imply exprIsCheap. Eg let x = fac 20 in Just x This responds True to exprIsHNF (you can discard a seq), but False to exprIsCheap. +-} -\begin{code} exprIsCheap :: CoreExpr -> Bool exprIsCheap = exprIsCheap' isCheapApp @@ -793,17 +783,17 @@ exprIsCheap' good_app other_expr -- Applications and variables go (App f a) val_args | isRuntimeArg a = go f (a:val_args) | otherwise = go f val_args - go (Var _) [] = True + go (Var _) [] = True -- Just a type application of a variable -- (f t1 t2 t3) counts as WHNF -- This case is probably handeld by the good_app case -- below, which should have a case for n=0, but putting -- it here too is belt and braces; and it's such a common - -- case that checking for null directly seems like a + -- case that checking for null directly seems like a -- good plan go (Var f) args - | good_app f (length args) + | good_app f (length args) = go_pap args | otherwise @@ -845,16 +835,16 @@ exprIsCheap' good_app other_expr -- Applications and variables -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) ------------------------------------- -type CheapAppFun = Id -> Int -> Bool - -- Is an application of this function to n *value* args - -- always cheap, assuming the arguments are cheap? +type CheapAppFun = Id -> Int -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? -- Mainly true of partial applications, data constructors, -- and of course true if the number of args is zero isCheapApp :: CheapAppFun isCheapApp fn n_val_args - = isDataConWorkId fn - || n_val_args == 0 + = isDataConWorkId fn + || n_val_args == 0 || n_val_args < idArity fn isExpandableApp :: CheapAppFun @@ -872,8 +862,8 @@ isExpandableApp fn n_val_args | Just (arg, ty) <- splitFunTy_maybe ty , isPredTy arg = go (n_val_args-1) ty | otherwise = False -\end{code} +{- Note [Expandable overloadings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose the user wrote this @@ -887,13 +877,13 @@ So we treat the application of a function (negate in this case) to a it's applied only to dictionaries. -%************************************************************************ -%* * +************************************************************************ +* * exprOkForSpeculation -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} ----------------------------- -- | 'exprOkForSpeculation' returns True of an expression that is: -- @@ -1030,8 +1020,8 @@ isDivOp WordRemOp = True isDivOp FloatDivOp = True isDivOp DoubleDivOp = True isDivOp _ = False -\end{code} +{- Note [exprOkForSpeculation: case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's always sound for exprOkForSpeculation to return False, and we @@ -1104,13 +1094,13 @@ We say "yes", even though 'x' may not be evaluated. Reasons before code gen. Until then, it's not guaranteed -%************************************************************************ -%* * +************************************************************************ +* * exprIsHNF, exprIsConLike -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] -- ~~~~~~~~~~~~~~~~ -- | exprIsHNF returns true for expressions that are certainly /already/ @@ -1144,9 +1134,7 @@ We say "yes", even though 'x' may not be evaluated. Reasons -- unboxed type must be ok-for-speculation (or trivial). exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding -\end{code} -\begin{code} -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as -- data constructors. Conlike arguments are considered interesting by the -- inliner. @@ -1209,18 +1197,17 @@ regarded as HNF if the expression they surround is HNF, because the tick is there to tell us that the expression was evaluated, so we don't want to discard a seq on it. -} -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Instantiating data constructors -%* * -%************************************************************************ +* * +************************************************************************ These InstPat functions go here to avoid circularity between DataCon and Id +-} -\begin{code} dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) @@ -1297,8 +1284,8 @@ dataConInstPat fss uniqs con inst_tys info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding | otherwise = vanillaIdInfo -- See Note [Mark evaluated arguments] -\end{code} +{- Note [Mark evaluated arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When pattern matching on a constructor with strict fields, the binder @@ -1313,13 +1300,13 @@ case in the RHS of the binding for 'v' is fine. But only if we c.f. add_evals in Simplify.simplAlt -%************************************************************************ -%* * +************************************************************************ +* * Equality -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | A cheap equality test which bales out fast! -- If it returns @True@ the arguments are definitely equal, -- otherwise, they may or may not be equal. @@ -1339,9 +1326,7 @@ cheapEqExpr (Cast e1 t1) (Cast e2 t2) = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2 cheapEqExpr _ _ = False -\end{code} -\begin{code} exprIsBig :: Expr b -> Bool -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' exprIsBig (Lit _) = False @@ -1352,9 +1337,7 @@ exprIsBig (Lam _ e) = exprIsBig e exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! exprIsBig _ = True -\end{code} -\begin{code} eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool -- Compares for equality, modulo alpha eqExpr in_scope e1 e2 @@ -1402,21 +1385,21 @@ eqExpr in_scope e1 e2 go_tickish env (Breakpoint lid lids) (Breakpoint rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids go_tickish _ l r = l == r -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The size of an expression} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data CoreStats = CS { cs_tm :: Int -- Terms , cs_ty :: Int -- Types , cs_co :: Int } -- Coercions -instance Outputable CoreStats where +instance Outputable CoreStats where ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) = braces (sep [ptext (sLit "terms:") <+> intWithCommas i1 <> comma, ptext (sLit "types:") <+> intWithCommas i2 <> comma, @@ -1471,10 +1454,7 @@ tyStats ty = zeroCS { cs_ty = typeSize ty } coStats :: Coercion -> CoreStats coStats co = zeroCS { cs_co = coercionSize co } -\end{code} - -\begin{code} coreBindsSize :: [CoreBind] -> Int -- We use coreBindStats for user printout -- but this one is a quick and dirty basis for @@ -1518,14 +1498,13 @@ pairSize (b,e) = bndrSize b + exprSize e altSize :: CoreAlt -> Int altSize (c,bs,e) = c `seq` bndrsSize bs + exprSize e -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Eta reduction -%* * -%************************************************************************ +* * +************************************************************************ Note [Eta reduction conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1612,8 +1591,8 @@ It's true that we could also hope to eta reduce these: (\xy. (f x y) |> g) But the simplifier pushes those casts outwards, so we don't need to address that here. +-} -\begin{code} tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body = go (reverse bndrs) body (mkReflCo Representational (exprType body)) @@ -1627,7 +1606,7 @@ tryEtaReduce bndrs body -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion go [] fun co - | ok_fun fun + | ok_fun fun , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co , not (any (`elemVarSet` used_vars) bndrs) = Just (mkCast fun co) -- Check for any of the binders free in the result @@ -1654,7 +1633,7 @@ tryEtaReduce bndrs body | isLocalId fun , isStrongLoopBreaker (idOccInfo fun) = 0 | arity > 0 = arity - | isEvaldUnfolding (idUnfolding fun) = 1 + | isEvaldUnfolding (idUnfolding fun) = 1 -- See Note [Eta reduction of an eval'd function] | otherwise = 0 where @@ -1681,28 +1660,28 @@ tryEtaReduce bndrs body -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg _ _ _ = Nothing -\end{code} +{- Note [Eta reduction of an eval'd function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In Haskell is is not true that f = \x. f x because f might be bottom, and 'seq' can distinguish them. -But it *is* true that f = f `seq` \x. f x +But it *is* true that f = f `seq` \x. f x and we'd like to simplify the latter to the former. This amounts -to the rule that +to the rule that * when there is just *one* value argument, * f is not bottom we can eta-reduce \x. f x ===> f -This turned up in Trac #7542. +This turned up in Trac #7542. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Determining non-updatable right-hand-sides} -%* * -%************************************************************************ +* * +************************************************************************ Top-level constructor applications can usually be allocated statically, but they can't if the constructor, or any of the @@ -1711,8 +1690,8 @@ labels in other DLLs). If this happens we simply make the RHS into an updatable thunk, and 'execute' it rather than allocating it statically. +-} -\begin{code} -- | This function is called only on *top-level* right-hand sides. -- Returns @True@ if the RHS can be allocated statically in the output, -- with no thunks involved at all. @@ -1826,4 +1805,3 @@ rhsIsStatic platform is_dynamic_name rhs = is_static False rhs = case isDataConWorkId_maybe f of Just dc -> n_val_args == dataConRepArity dc Nothing -> False -\end{code} diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.hs index 81f05338b3..6905641f56 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.hs @@ -1,4 +1,3 @@ -\begin{code} {-# LANGUAGE CPP #-} -- | Handy functions for creating much Core syntax @@ -91,15 +90,15 @@ import Data.Word ( Word ) #endif infixl 4 `mkCoreApp`, `mkCoreApps` -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Basic CoreSyn construction} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} sortQuantVars :: [Var] -> [Var] -- Sort the variables (KindVars, TypeVars, and Ids) -- into order: Kind, then Type, then Id @@ -219,26 +218,26 @@ castBottomExpr e res_ty | otherwise = Case e (mkWildValBinder e_ty) res_ty [] where e_ty = exprType e -\end{code} +{- The functions from this point don't really do anything cleverer than their counterparts in CoreSyn, but they are here for consistency +-} -\begin{code} -- | Create a lambda where the given expression has a number of variables -- bound over it. The leftmost binder is that bound by the outermost -- lambda in the result mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr mkCoreLams = mkLams -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Making literals} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Create a 'CoreExpr' which will evaluate to the given @Int@ mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int mkIntExpr dflags i = mkConApp intDataCon [mkIntLit dflags i] @@ -295,9 +294,6 @@ mkStringExprFS str where chars = unpackFS str safeChar c = ord c >= 1 && ord c <= 0x7F -\end{code} - -\begin{code} -- This take a ~# b (or a ~# R b) and returns a ~ b (or Coercible a b) mkEqBox :: Coercion -> CoreExpr @@ -310,15 +306,14 @@ mkEqBox co = ASSERT2( typeKind ty2 `eqKind` k, ppr co $$ ppr ty1 $$ ppr ty2 $$ p Representational -> coercibleDataCon Phantom -> pprPanic "mkEqBox does not support boxing phantom coercions" (ppr co) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Tuple constructors} -%* * -%************************************************************************ - -\begin{code} +* * +************************************************************************ +-} -- $big_tuples -- #big_tuples# @@ -361,8 +356,7 @@ chunkify xs split [] = [] split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) -\end{code} - +{- Creating tuples and their types for Core expressions @mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. @@ -371,8 +365,7 @@ Creating tuples and their types for Core expressions * If there are more elements than a big tuple can have, it nests the tuples. - -\begin{code} +-} -- | Build a small tuple holding the specified variables mkCoreVarTup :: [Id] -> CoreExpr @@ -404,16 +397,15 @@ mkBigCoreTup = mkChunkified mkCoreTup -- | Build the type of a big tuple that holds the specified type of thing mkBigCoreTupTy :: [Type] -> Type mkBigCoreTupTy = mkChunkified mkBoxedTupleTy -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Floats -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data FloatBind = FloatLet CoreBind | FloatCase CoreExpr Id AltCon [Var] @@ -428,15 +420,15 @@ instance Outputable FloatBind where wrapFloat :: FloatBind -> CoreExpr -> CoreExpr wrapFloat (FloatLet defns) body = Let defns body wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Tuple destructors} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} -- | Builds a selector which scrutises the given -- expression and extracts the one name from the list given. -- If you want the no-shadowing rule to apply, the caller @@ -475,9 +467,7 @@ mkTupleSelector vars the_var scrut_var scrut tpl_vs = mkTemplateLocals tpl_tys [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, the_var `elem` gp ] -\end{code} -\begin{code} -- | Like 'mkTupleSelector' but for tuples that are guaranteed -- never to be \"big\". -- @@ -495,9 +485,7 @@ mkSmallTupleSelector vars the_var scrut_var scrut = ASSERT( notNull vars ) Case scrut scrut_var (idType the_var) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, Var the_var)] -\end{code} -\begin{code} -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression. -- @@ -535,9 +523,7 @@ mkTupleCase uniqs vars body scrut_var scrut (mkBoxedTupleTy (map idType chunk_vars)) body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) in (us', scrut_var:vs, body') -\end{code} -\begin{code} -- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed -- not to need nesting. mkSmallTupleCase @@ -552,18 +538,18 @@ mkSmallTupleCase [var] body _scrut_var scrut mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement? = Case scrut scrut_var (exprType body) [(DataAlt (tupleCon BoxedTuple (length vars)), vars, body)] -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Common list manipulation expressions} -%* * -%************************************************************************ +* * +************************************************************************ Call the constructor Ids when building explicit lists, so that they interact well with rules. +-} -\begin{code} -- | Makes a list @[]@ for lists of the specified type mkNilExpr :: Type -> CoreExpr mkNilExpr ty = mkConApp nilDataCon [Type ty] @@ -613,16 +599,15 @@ mkBuildExpr elt_ty mk_build_inside = do newTyVars tyvar_tmpls = do uniqs <- getUniquesM return (zipWith setTyVarUnique tyvar_tmpls uniqs) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Error expressions -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} mkRuntimeErrorApp :: Id -- Should be of type (forall a. Addr# -> a) -- where Addr# points to a UTF8 encoded string @@ -638,13 +623,13 @@ mkRuntimeErrorApp err_id res_ty err_msg mkImpossibleExpr :: Type -> CoreExpr mkImpossibleExpr res_ty = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Error Ids -%* * -%************************************************************************ +* * +************************************************************************ GHC randomly injects these into the code. @@ -660,8 +645,8 @@ crash). @parError@ is a special version of @error@ which the compiler does not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ templates, but we don't ever expect to generate code for it. +-} -\begin{code} errorIds :: [Id] errorIds = [ eRROR_ID, -- This one isn't used anywhere else in the compiler @@ -719,9 +704,7 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy runtimeErrorTy :: Type -- The runtime error Ids take a UTF8-encoded string as argument runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) -\end{code} -\begin{code} errorName :: Name errorName = mkWiredInIdName gHC_ERR (fsLit "error") errorIdKey eRROR_ID @@ -739,8 +722,8 @@ uNDEFINED_ID = pc_bottoming_Id0 undefinedName undefinedTy undefinedTy :: Type -- See Note [Error and friends have an "open-tyvar" forall] undefinedTy = mkSigmaTy [openAlphaTyVar] [] openAlphaTy -\end{code} +{- Note [Error and friends have an "open-tyvar" forall] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'error' and 'undefined' have types @@ -754,13 +737,13 @@ This is OK because it never returns, so the return type is irrelevant. See Note [OpenTypeKind accepts foralls] in TcUnify. -%************************************************************************ -%* * +************************************************************************ +* * \subsection{Utilities} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} pc_bottoming_Id1 :: Name -> Type -> Id -- Function of arity 1, which diverges after being given one argument pc_bottoming_Id1 name ty @@ -789,4 +772,3 @@ pc_bottoming_Id0 name ty where bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig strict_sig = mkClosedStrictSig [] botRes -\end{code} diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.hs index 593c670cae..acc6c79fa1 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.hs @@ -1,11 +1,11 @@ -% -% (c) The University of Glasgow 2006 -% (c) The AQUA Project, Glasgow University, 1996-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + Printing of Core syntax +-} -\begin{code} {-# OPTIONS_GHC -fno-warn-orphans #-} module PprCore ( pprCoreExpr, pprParendExpr, @@ -29,17 +29,17 @@ import BasicTypes import Util import Outputable import FastString -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{Public interfaces for Core printing (excluding instances)} -%* * -%************************************************************************ +* * +************************************************************************ @pprParendCoreExpr@ puts parens around non-atomic Core expressions. +-} -\begin{code} pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc pprCoreBinding :: OutputableBndr b => Bind b -> SDoc pprCoreExpr :: OutputableBndr b => Expr b -> SDoc @@ -53,16 +53,15 @@ instance OutputableBndr b => Outputable (Bind b) where instance OutputableBndr b => Outputable (Expr b) where ppr expr = pprCoreExpr expr -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * \subsection{The guts} -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc pprTopBinds binds = vcat (map pprTopBind binds) @@ -78,9 +77,7 @@ pprTopBind (Rec (b:bs)) vcat [blankLine $$ ppr_binding b | b <- bs], ptext (sLit "end Rec }"), blankLine] -\end{code} -\begin{code} ppr_bind :: OutputableBndr b => Bind b -> SDoc ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) @@ -92,17 +89,13 @@ ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc ppr_binding (val_bdr, expr) = pprBndr LetBind val_bdr $$ hang (ppr val_bdr <+> equals) 2 (pprCoreExpr expr) -\end{code} -\begin{code} pprParendExpr expr = ppr_expr parens expr pprCoreExpr expr = ppr_expr noParens expr noParens :: SDoc -> SDoc noParens pp = pp -\end{code} -\begin{code} ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) @@ -158,7 +151,7 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) = sdocWithDynFlags $ \dflags -> if gopt Opt_PprCaseAsLet dflags then add_par $ -- See Note [Print case as let] - sep [ sep [ ptext (sLit "let! {") + sep [ sep [ ptext (sLit "let! {") <+> ppr_case_pat con args <+> ptext (sLit "~") <+> ppr_bndr var @@ -252,23 +245,23 @@ pprArg (Type ty) else ptext (sLit "@") <+> pprParendType ty pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co pprArg expr = pprParendExpr expr -\end{code} +{- Note [Print case as let] ~~~~~~~~~~~~~~~~~~~~~~~~ Single-branch case expressions are very common: - case x of y { I# x' -> + case x of y { I# x' -> case p of q { I# p' -> ... } } These are, in effect, just strict let's, with pattern matching. With -dppr-case-as-let we print them as such: let! { I# x' ~ y <- x } in let! { I# p' ~ q <- p } in ... - + Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. +-} -\begin{code} instance OutputableBndr Var where pprBndr = pprCoreBinder pprInfixOcc = pprInfixName . varName @@ -351,7 +344,7 @@ pprIdBndrInfo info has_prag = not (isDefaultInlinePragma prag_info) has_occ = not (isNoOcc occ_info) - has_dmd = not $ isTopDmd dmd_info + has_dmd = not $ isTopDmd dmd_info has_lbv = not (hasNoOneShotInfo lbv_info) doc = showAttributes @@ -360,14 +353,13 @@ pprIdBndrInfo info , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) , (has_lbv , ptext (sLit "OS=") <> ppr lbv_info) ] -\end{code} - +{- ----------------------------------------------------- -- IdDetails and IdInfo ----------------------------------------------------- +-} -\begin{code} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info = sdocWithDynFlags $ \dflags -> @@ -412,13 +404,13 @@ showAttributes stuff | otherwise = brackets (sep (punctuate comma docs)) where docs = [d | (True,d) <- stuff] -\end{code} +{- ----------------------------------------------------- -- Unfolding and UnfoldingGuidance ----------------------------------------------------- +-} -\begin{code} instance Outputable UnfoldingGuidance where ppr UnfNever = ptext (sLit "NEVER") ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) @@ -441,7 +433,7 @@ instance Outputable Unfolding where ppr NoUnfolding = ptext (sLit "No unfolding") ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) - = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") + = hang (ptext (sLit "DFun:") <+> ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) 2 (ppr con <+> sep (map ppr args)) ppr (CoreUnfolding { uf_src = src @@ -463,13 +455,13 @@ instance Outputable Unfolding where | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! -\end{code} +{- ----------------------------------------------------- -- Rules ----------------------------------------------------- +-} -\begin{code} instance Outputable CoreRule where ppr = pprRule @@ -489,13 +481,13 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) ]) -\end{code} +{- ----------------------------------------------------- -- Tickish ----------------------------------------------------- +-} -\begin{code} instance Outputable id => Outputable (Tickish id) where ppr (HpcTick modl ix) = hcat [ptext (sLit "tick<"), @@ -514,13 +506,13 @@ instance Outputable id => Outputable (Tickish id) where (True,True) -> hcat [ptext (sLit "scctick<"), ppr cc, char '>'] (True,False) -> hcat [ptext (sLit "tick<"), ppr cc, char '>'] _ -> hcat [ptext (sLit "scc<"), ppr cc, char '>'] -\end{code} +{- ----------------------------------------------------- -- Vectorisation declarations ----------------------------------------------------- +-} -\begin{code} instance Outputable CoreVect where ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') 4 (pprCoreExpr e) @@ -533,4 +525,3 @@ instance Outputable CoreVect where char '=' <+> ppr tc ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var -\end{code} diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.hs index d552506b10..57f360e181 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.hs @@ -1,9 +1,8 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} -\begin{code} {-# LANGUAGE RankNTypes, TypeFamilies #-} module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, @@ -34,8 +33,8 @@ import VarEnv import NameEnv import Outputable import Control.Monad( (>=>) ) -\end{code} +{- This module implements TrieMaps, which are finite mappings whose key is a structured value like a CoreExpr or Type. @@ -43,13 +42,13 @@ The code is very regular and boilerplate-like, but there is some neat handling of *binders*. In effect they are deBruijn numbered on the fly. -%************************************************************************ -%* * +************************************************************************ +* * The TrieMap class -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) -- or an existing elt (Just) @@ -94,15 +93,15 @@ x |> f = f x deMaybe :: TrieMap m => Maybe (m a) -> m a deMaybe Nothing = emptyTM deMaybe (Just m) = m -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * IntMaps -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} instance TrieMap IntMap.IntMap where type Key IntMap.IntMap = Int emptyTM = IntMap.empty @@ -129,19 +128,18 @@ instance TrieMap UniqFM where alterTM k f m = alterUFM f m k foldTM k m z = foldUFM k z m mapTM f m = mapUFM f m -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Lists -%* * -%************************************************************************ +* * +************************************************************************ If m is a map from k -> val then (MaybeMap m) is a map from (Maybe k) -> val +-} -\begin{code} data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } instance TrieMap m => TrieMap (MaybeMap m) where @@ -205,16 +203,15 @@ fdList k m = foldMaybe k (lm_nil m) foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b foldMaybe _ Nothing b = b foldMaybe k (Just a) b = k a b -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Basic maps -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} lkNamed :: NamedThing n => n -> NameEnv a -> Maybe a lkNamed n env = lookupNameEnv env (getName n) @@ -232,13 +229,13 @@ lkLit = lookupTM xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a xtLit = alterTM -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * CoreMap -%* * -%************************************************************************ +* * +************************************************************************ Note [Binders] ~~~~~~~~~~~~~~ @@ -268,8 +265,8 @@ is that it's unnecesary, so we have two fields (cm_case and cm_ecase) for the two possibilities. Only cm_ecase looks at the type. See also Note [Empty case alternatives] in CoreSyn. +-} -\begin{code} data CoreMap a = EmptyCM | CM { cm_var :: VarMap a @@ -449,15 +446,15 @@ fdA :: (a -> b -> b) -> AltMap a -> b -> b fdA k m = foldTM k (am_deflt m) . foldTM (foldTM k) (am_data m) . foldTM (foldTM k) (am_lit m) -\end{code} -%************************************************************************ -%* * +{- +************************************************************************ +* * Coercions -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data CoercionMap a = EmptyKM | KM { km_refl :: RoleMap (TypeMap a) @@ -586,10 +583,6 @@ fdC k m = foldTM (foldTM k) (km_refl m) . foldTM k (km_sub m) . foldTM (foldTM (foldTM k)) (km_axiom_rule m) -\end{code} - -\begin{code} - newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) } instance TrieMap RoleMap where @@ -616,16 +609,14 @@ fdR f (RM m) = foldTM f m mapR :: (a -> b) -> RoleMap a -> RoleMap b mapR f = RM . mapTM f . unRM -\end{code} - - -%************************************************************************ -%* * +{- +************************************************************************ +* * Types -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} data TypeMap a = EmptyTM | TM { tm_var :: VarMap a @@ -764,16 +755,15 @@ xtTyLit l f m = foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b foldTyLit l m = flip (Map.fold l) (tlm_string m) . flip (Map.fold l) (tlm_number m) -\end{code} - -%************************************************************************ -%* * +{- +************************************************************************ +* * Variables -%* * -%************************************************************************ +* * +************************************************************************ +-} -\begin{code} type BoundVar = Int -- Bound variables are deBruijn numbered type BoundVarMap a = IntMap.IntMap a @@ -837,4 +827,3 @@ lkFreeVar var env = lookupVarEnv env var xtFreeVar :: Var -> XT a -> VarEnv a -> VarEnv a xtFreeVar v f m = alterVarEnv f m v -\end{code} |