diff options
author | Ian Lynagh <igloo@earth.li> | 2012-05-29 20:37:35 +0100 |
---|---|---|
committer | Ian Lynagh <igloo@earth.li> | 2012-05-29 20:48:58 +0100 |
commit | 1bf927addf1951eec7ab3514733c9beab6de3cec (patch) | |
tree | 5d3efa8ad0c9d8b0c8d65db3ce846e8c53831e40 | |
parent | 8b4d97059ef8b02996e6533c31a520700542b9bd (diff) | |
download | haskell-1bf927addf1951eec7ab3514733c9beab6de3cec.tar.gz |
Fix whitespace in coreSyn/CorePrep.lhs
-rw-r--r-- | compiler/coreSyn/CorePrep.lhs | 412 |
1 files changed, 203 insertions, 209 deletions
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 7f107137b6..55c78b8741 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -6,12 +6,6 @@ Core pass to saturate constructors and PrimOps \begin{code} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details module CorePrep ( corePrepPgm, corePrepExpr @@ -23,7 +17,7 @@ import PrelNames import CoreUtils import CoreArity import CoreFVs -import CoreMonad ( endPass, CoreToDo(..) ) +import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import CoreSubst import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here @@ -53,7 +47,7 @@ import MonadUtils import FastString import Config import Data.Bits -import Data.List ( mapAccumL ) +import Data.List ( mapAccumL ) import Control.Monad \end{code} @@ -69,15 +63,15 @@ The goal of this pass is to prepare for code generation. are always variables. * Use case for strict arguments: - f E ==> case E of x -> f x - (where f is strict) + f E ==> case E of x -> f x + (where f is strict) * Use let for non-trivial lazy arguments - f E ==> let x = E in f x - (were f is lazy and x is non-trivial) + f E ==> let x = E in f x + (were f is lazy and x is non-trivial) 3. Similarly, convert any unboxed lets into cases. - [I'm experimenting with leaving 'ok-for-speculation' + [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form right up to this point.] 4. Ensure that *value* lambdas only occur as the RHS of a binding @@ -87,11 +81,11 @@ The goal of this pass is to prepare for code generation. 5. [Not any more; nuked Jun 2002] Do the seq/par munging. 6. Clone all local Ids. - This means that all such Ids are unique, rather than the + This means that all such Ids are unique, rather than the weaker guarantee of no clashes which the simplifier provides. And that is what the code generator needs. - We don't clone TyVars or CoVars. The code gen doesn't need that, + We don't clone TyVars or CoVars. The code gen doesn't need that, and doing so would be tiresome because then we'd need to substitute in types and coercions. @@ -99,11 +93,11 @@ The goal of this pass is to prepare for code generation. rather like the cloning step above. 8. Inject bindings for the "implicit" Ids: - * Constructor wrappers - * Constructor workers + * Constructor wrappers + * Constructor workers We want curried definitions for all of these in case they aren't inlined by some caller. - + 9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs 10. Convert (LitInteger i mkInteger) into the core representation @@ -116,24 +110,24 @@ This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. - + Invariants ~~~~~~~~~~ Here is the syntax of the Core produced by CorePrep: - Trivial expressions - triv ::= lit | var - | triv ty | /\a. triv + Trivial expressions + triv ::= lit | var + | triv ty | /\a. triv | truv co | /\c. triv | triv |> co Applications app ::= lit | var | app triv | app ty | app co | app |> co Expressions - body ::= app + body ::= app | let(rec) x = rhs in body -- Boxed only | case body of pat -> body - | /\a. body | /\c. body + | /\a. body | /\c. body | body |> co Right hand sides (only place where value lambdas can occur) @@ -143,16 +137,16 @@ 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' +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 -%* * +%* * + Top level stuff +%* * %************************************************************************ \begin{code} @@ -183,7 +177,7 @@ corePrepExpr dflags expr = do corePrepTopBinds :: [CoreBind] -> UniqSM Floats -- Note [Floating out of top level bindings] -corePrepTopBinds binds +corePrepTopBinds binds = go emptyCorePrepEnv binds where go _ [] = return emptyFloats @@ -194,8 +188,8 @@ corePrepTopBinds binds mkDataConWorkers :: [TyCon] -> [CoreBind] -- See Note [Data constructor workers] mkDataConWorkers data_tycons - = [ NonRec id (Var id) -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it + = [ NonRec id (Var id) -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it data_con <- tyConDataCons tycon, let id = dataConWorkId data_con ] \end{code} @@ -203,17 +197,17 @@ mkDataConWorkers data_tycons Note [Floating out of top level bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB: we do need to float out of top-level bindings -Consider x = length [True,False] +Consider x = length [True,False] We want to get - s1 = False : [] - s2 = True : s1 - x = length s2 + s1 = False : [] + s2 = True : s1 + x = length s2 We return a *list* of bindings, because we may start with - x* = f (g y) + x* = f (g y) where x is demanded, in which case we want to finish with - a = g y - x* = f a + a = g y + x* = f a And then x will actually end up case-bound Note [CafInfo and floating] @@ -237,9 +231,9 @@ b) The top-level binding is marked NoCafRefs. This really happens So what we *want* is sat [NoCafRefs] = \xy. retry x y $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... - + So, gruesomely, we must set the NoCafRefs flag on the sat bindings, - *and* substutite the modified 'sat' into the old RHS. + *and* substutite the modified 'sat' into the old RHS. It should be the case that 'sat' is itself [NoCafRefs] (a value, no cafs) else the original top-level binding would not itself have been @@ -247,7 +241,7 @@ b) The top-level binding is marked NoCafRefs. This really happens consistentCafInfo will find this. This is all very gruesome and horrible. It would be better to figure -out CafInfo later, after CorePrep. We'll do that in due course. +out CafInfo later, after CorePrep. We'll do that in due course. Meanwhile this horrible hack works. @@ -256,7 +250,7 @@ Note [Data constructor workers] Create any necessary "implicit" bindings for data con workers. We create the rather strange (non-recursive!) binding - $wC = \x y -> $wC x y + $wC = \x y -> $wC x y i.e. a curried constructor that allocates. This means that we can treat the worker for a constructor like any other function in the rest @@ -285,7 +279,7 @@ After specialisation and SpecConstr, we would get something like this: f :: Show b => Int -> (Int, b -> Maybe Int -> Int) f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) where - {-# RULES g $dBool = g$Bool + {-# RULES g $dBool = g$Bool g $dUnit = g$Unit #-} g = ... {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} @@ -331,28 +325,28 @@ Into this one: %************************************************************************ -%* * - The main code -%* * +%* * + The main code +%* * %************************************************************************ \begin{code} cpeBind :: TopLevelFlag - -> CorePrepEnv -> CoreBind - -> UniqSM (CorePrepEnv, Floats) + -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) = do { (_, bndr1) <- cpCloneBndr env bndr ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) - ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive - (is_strict || is_unlifted) - env bndr1 rhs + ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive + (is_strict || is_unlifted) + env bndr1 rhs ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2 -- We want bndr'' in the envt, because it records -- the evaluated-ness of the binder - ; return (extendCorePrepEnv env bndr bndr2, - addFloat floats new_float) } + ; return (extendCorePrepEnv env bndr bndr2, + addFloat floats new_float) } cpeBind top_lvl env (Rec pairs) = do { let (bndrs,rhss) = unzip pairs @@ -361,20 +355,20 @@ cpeBind top_lvl env (Rec pairs) ; let (floats_s, bndrs2, rhss2) = unzip3 stuff all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) - (concatFloats floats_s) + (concatFloats floats_s) ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), - unitFloat (FloatLet (Rec all_pairs))) } + unitFloat (FloatLet (Rec all_pairs))) } where - -- Flatten all the floats, and the currrent - -- group into a single giant Rec + -- Flatten all the floats, and the currrent + -- group into a single giant Rec add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 add_float b _ = pprPanic "cpeBind" (ppr b) --------------- cpePair :: TopLevelFlag -> RecFlag -> RhsDemand - -> CorePrepEnv -> Id -> CoreExpr - -> UniqSM (Floats, Id, CpeRhs) + -> CorePrepEnv -> Id -> CoreExpr + -> UniqSM (Floats, Id, CpeRhs) -- Used for all bindings cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs = do { (floats1, rhs1) <- cpeRhsE env rhs @@ -384,26 +378,26 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs -- Make the arity match up ; (floats3, rhs') - <- if manifestArity rhs1 <= arity - then return (floats2, cpeEtaExpand arity rhs2) - else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) - -- Note [Silly extra arguments] - (do { v <- newVar (idType bndr) - ; let float = mkFloat False False v rhs2 - ; return ( addFloat floats2 float + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + -- Note [Silly extra arguments] + (do { v <- newVar (idType bndr) + ; let float = mkFloat False False v rhs2 + ; return ( addFloat floats2 float , cpeEtaExpand arity (Var v)) }) - -- Record if the binder is evaluated - -- and otherwise trim off the unfolding altogether - -- It's not used by the code generator; getting rid of it reduces - -- heap usage and, since we may be changing uniques, we'd have - -- to substitute to keep it right + -- Record if the binder is evaluated + -- and otherwise trim off the unfolding altogether + -- It's not used by the code generator; getting rid of it reduces + -- heap usage and, since we may be changing uniques, we'd have + -- to substitute to keep it right ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding - | otherwise = bndr `setIdUnfolding` noUnfolding + | otherwise = bndr `setIdUnfolding` noUnfolding ; return (floats3, bndr', rhs') } where - arity = idArity bndr -- We must match this arity + arity = idArity bndr -- We must match this arity --------------------- float_from_rhs floats rhs @@ -418,7 +412,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs | otherwise = dont_float floats rhs --------------------- - float_top floats rhs -- Urhgh! See Note [CafInfo and floating] + float_top floats rhs -- Urhgh! See Note [CafInfo and floating] | mayHaveCafRefs (idCafInfo bndr) , allLazyTop floats = return (floats, rhs) @@ -437,35 +431,35 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs -- But: rhs1 might have lambdas, and we can't -- put them inside a wrapBinds = do { body <- rhsToBodyNF rhs - ; return (emptyFloats, wrapBinds floats body) } + ; return (emptyFloats, wrapBinds floats body) } {- Note [Silly extra arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we had this - f{arity=1} = \x\y. e + f{arity=1} = \x\y. e We *must* match the arity on the Id, so we have to generate f' = \x\y. e - f = \x. f' x + f = \x. f' x It's a bizarre case: why is the arity on the Id wrong? Reason -(in the days of __inline_me__): +(in the days of __inline_me__): f{arity=0} = __inline_me__ (let v = expensive in \xy. e) When InlineMe notes go away this won't happen any more. But it seems good for CorePrep to be robust. -} -- --------------------------------------------------------------------------- --- CpeRhs: produces a result satisfying CpeRhs +-- CpeRhs: produces a result satisfying CpeRhs -- --------------------------------------------------------------------------- cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- If --- e ===> (bs, e') --- then --- e = let bs in e' (semantically, that is!) +-- e ===> (bs, e') +-- then +-- e = let bs in e' (semantically, that is!) -- -- For example --- f (g x) ===> ([v = g x], f v) +-- f (g x) ===> ([v = g x], f v) cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) @@ -475,8 +469,8 @@ cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env (Var f `App` _ `App` arg) - | f `hasKey` lazyIdKey -- Replace (lazy a) by a - = cpeRhsE env arg -- See Note [lazyId magic] in MkId + | f `hasKey` lazyIdKey -- Replace (lazy a) by a + = cpeRhsE env arg -- See Note [lazyId magic] in MkId cpeRhsE env expr@(App {}) = cpeApp env expr @@ -504,8 +498,8 @@ cpeRhsE env (Cast expr co) cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr ; (env', bndrs') <- cpCloneBndrs env bndrs - ; body' <- cpeBodyNF env' body - ; return (emptyFloats, mkLams bndrs' body') } + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut @@ -523,8 +517,8 @@ cpeRhsE env (Case scrut bndr ty alts) cvtLitInteger :: Integer -> Id -> CoreExpr -- Here we convert a literal Integer to the low-level -- represenation. Exactly how we do this depends on the --- library that implements Integer. If it's GMP we --- use the S# data constructor for small literals. +-- library that implements Integer. If it's GMP we +-- use the S# data constructor for small literals. -- See Note [Integer literals] in Literal cvtLitInteger i mk_integer | cIntegerLibraryType == IntegerGMP @@ -544,11 +538,11 @@ cvtLitInteger i mk_integer mask = 2 ^ bits - 1 -- --------------------------------------------------------------------------- --- CpeBody: produces a result satisfying CpeBody +-- CpeBody: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody -cpeBodyNF env expr +cpeBodyNF env expr = do { (floats, body) <- cpeBody env expr ; return (wrapBinds floats body) } @@ -562,7 +556,7 @@ cpeBody env expr -------- rhsToBodyNF :: CpeRhs -> UniqSM CpeBody rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs - ; return (wrapBinds floats body) } + ; return (wrapBinds floats body) } -------- rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) @@ -582,12 +576,12 @@ rhsToBody (Cast e co) rhsToBody expr@(Lam {}) | Just no_lam_result <- tryEtaReducePrep bndrs body = return (emptyFloats, no_lam_result) - | all isTyVar bndrs -- Type lambdas are ok + | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) - | otherwise -- Some value lambdas + | otherwise -- Some value lambdas = do { fn <- newVar (exprType expr) ; let rhs = cpeEtaExpand (exprArity expr) expr - float = FloatLet (NonRec fn rhs) + float = FloatLet (NonRec fn rhs) ; return (unitFloat float, Var fn) } where (bndrs,body) = collectBinders expr @@ -597,19 +591,19 @@ rhsToBody expr = return (emptyFloats, expr) -- --------------------------------------------------------------------------- --- CpeApp: produces a result satisfying CpeApp +-- CpeApp: produces a result satisfying CpeApp -- --------------------------------------------------------------------------- cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- May return a CpeRhs because of saturating primops -cpeApp env expr +cpeApp env expr = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0 - ; MASSERT(null ss) -- make sure we used all the strictness info + ; MASSERT(null ss) -- make sure we used all the strictness info - -- Now deal with the function + -- Now deal with the function ; case head of Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth - ; return (floats, sat_app) } + ; return (floats, sat_app) } _other -> return (floats, app) } where @@ -620,14 +614,14 @@ cpeApp env expr -- has a constructor or primop at the head. collect_args - :: CoreExpr - -> Int -- Current app depth - -> UniqSM (CpeApp, -- The rebuilt expression - (CoreExpr,Int), -- The head of the application, - -- and no. of args it was applied to - Type, -- Type of the whole expr - Floats, -- Any floats we pulled out - [Demand]) -- Remaining argument demands + :: CoreExpr + -> Int -- Current app depth + -> UniqSM (CpeApp, -- The rebuilt expression + (CoreExpr,Int), -- The head of the application, + -- and no. of args it was applied to + Type, -- Type of the whole expr + Floats, -- Any floats we pulled out + [Demand]) -- Remaining argument demands collect_args (App fun arg@(Type arg_ty)) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth @@ -639,7 +633,7 @@ cpeApp env expr collect_args (App fun arg) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) - ; let + ; let (ss1, ss_rest) = case ss of (ss1:ss_rest) -> (ss1, ss_rest) [] -> (lazyDmd, []) @@ -649,42 +643,42 @@ cpeApp env expr ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } - collect_args (Var v) depth + collect_args (Var v) depth = do { v1 <- fiddleCCall v ; let v2 = lookupCorePrepEnv env v1 ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } - where - stricts = case idStrictness v of - StrictSig (DmdType _ demands _) - | listLengthCmp demands depth /= GT -> demands - -- length demands <= depth - | otherwise -> [] - -- If depth < length demands, then we have too few args to - -- satisfy strictness info so we have to ignore all the - -- strictness info, e.g. + (error "urk") - -- Here, we can't evaluate the arg strictly, because this - -- partial application might be seq'd + where + stricts = case idStrictness v of + StrictSig (DmdType _ demands _) + | listLengthCmp demands depth /= GT -> demands + -- length demands <= depth + | otherwise -> [] + -- If depth < length demands, then we have too few args to + -- satisfy strictness info so we have to ignore all the + -- strictness info, e.g. + (error "urk") + -- Here, we can't evaluate the arg strictly, because this + -- partial application might be seq'd collect_args (Cast fun co) depth = do { let Pair _ty1 ty2 = coercionKind co ; (fun', hd, _, floats, ss) <- collect_args fun depth ; return (Cast fun' co, hd, ty2, floats, ss) } - + collect_args (Tick tickish fun) depth | ignoreTickish tickish -- Drop these notes altogether = collect_args fun depth -- They aren't used by the code generator - -- N-variable fun, better let-bind it + -- N-variable fun, better let-bind it collect_args fun depth = do { (fun_floats, fun') <- cpeArg env True fun ty - -- The True says that it's sure to be evaluated, - -- so we'll end up case-binding it + -- The True says that it's sure to be evaluated, + -- so we'll end up case-binding it ; return (fun', (fun', depth), ty, fun_floats, []) } where - ty = exprType fun + ty = exprType fun -- --------------------------------------------------------------------------- --- CpeArg: produces a result satisfying CpeArg +-- CpeArg: produces a result satisfying CpeArg -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound @@ -692,19 +686,19 @@ cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) cpeArg env is_strict arg arg_ty = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda - ; (floats2, arg2) <- if want_float floats1 arg1 - then return (floats1, arg1) - else do { body1 <- rhsToBodyNF arg1 - ; return (emptyFloats, wrapBinds floats1 body1) } - -- Else case: arg1 might have lambdas, and we can't - -- put them inside a wrapBinds + ; (floats2, arg2) <- if want_float floats1 arg1 + then return (floats1, arg1) + else do { body1 <- rhsToBodyNF arg1 + ; return (emptyFloats, wrapBinds floats1 body1) } + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument then return (floats2, arg2) else do { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 - arg_float = mkFloat is_strict is_unlifted v arg3 + arg_float = mkFloat is_strict is_unlifted v arg3 ; return (addFloat floats2 arg_float, varToCoreExpr v) } } where is_unlifted = isUnLiftedType arg_ty @@ -739,13 +733,13 @@ maybeSaturate fn expr n_args -- A gruesome special case = saturateDataToTag sat_expr - | hasNoBinding fn -- There's no binding + | hasNoBinding fn -- There's no binding = return sat_expr - | otherwise + | otherwise = return expr where - fn_arity = idArity fn + fn_arity = idArity fn excess_arity = fn_arity - n_args sat_expr = cpeEtaExpand excess_arity expr @@ -760,7 +754,7 @@ saturateDataToTag sat_expr eval_data2tag_arg :: CpeApp -> UniqSM CpeBody eval_data2tag_arg app@(fun `App` arg) | exprIsHNF arg -- Includes nullary constructors - = return app -- The arg is evaluated + = return app -- The arg is evaluated | otherwise -- Arg not evaluated, so evaluate it = do { arg_id <- newVar (exprType arg) ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding @@ -771,8 +765,8 @@ saturateDataToTag sat_expr = do { app' <- eval_data2tag_arg app ; return (Tick t app') } - eval_data2tag_arg other -- Should not happen - = pprPanic "eval_data2tag" (ppr other) + eval_data2tag_arg other -- Should not happen + = pprPanic "eval_data2tag" (ppr other) \end{code} Note [dataToTag magic] @@ -786,9 +780,9 @@ of the scope of a `seq`, or dropped the `seq` altogether. %************************************************************************ -%* * - Simple CoreSyn operations -%* * +%* * + Simple CoreSyn operations +%* * %************************************************************************ \begin{code} @@ -810,7 +804,7 @@ cpe_ExprIsTrivial _ = False \end{code} -- ----------------------------------------------------------------------------- --- Eta reduction +-- Eta reduction -- ----------------------------------------------------------------------------- Note [Eta expansion] @@ -840,14 +834,14 @@ It turns out to be much much easier to do eta expansion on the eta expander: given a CpeRhs, it must return a CpeRhs. For example here is what we do not want: - f = /\a -> g (h 3) -- h has arity 2 + f = /\a -> g (h 3) -- h has arity 2 After ANFing we get - f = /\a -> let s = h 3 in g s + f = /\a -> let s = h 3 in g s and now we do NOT want eta expansion to give - f = /\a -> \ y -> (let s = h 3 in g s) y + f = /\a -> \ y -> (let s = h 3 in g s) y Instead CoreArity.etaExpand gives - f = /\a -> \y -> let s = h 3 in g s y + f = /\a -> \y -> let s = h 3 in g s y \begin{code} cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs @@ -857,14 +851,14 @@ cpeEtaExpand arity expr \end{code} -- ----------------------------------------------------------------------------- --- Eta reduction +-- Eta reduction -- ----------------------------------------------------------------------------- Why try eta reduction? Hasn't the simplifier already done eta? But the simplifier only eta reduces if that leaves something 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 -> \xs. map f xs } ==> case x of { p -> map f } \begin{code} @@ -887,15 +881,15 @@ tryEtaReducePrep bndrs expr@(App _ _) ok bndr (Var arg) = bndr == arg ok _ _ = False - -- We can't eta reduce something which must be saturated. + -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False -- Safe. ToDo: generalise tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) = case tryEtaReducePrep bndrs body of - Just e -> Just (Let bind e) - Nothing -> Nothing + Just e -> Just (Let bind e) + Nothing -> Nothing where fvs = exprFreeVars r @@ -912,20 +906,20 @@ type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recurs \end{code} %************************************************************************ -%* * - Floats -%* * +%* * + Floats +%* * %************************************************************************ \begin{code} -data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - -- They are always of lifted type; - -- unlifted ones are done with FloatCase - - | FloatCase - Id CpeBody - Bool -- The bool indicates "ok-for-speculation" +data FloatingBind + = FloatLet CoreBind -- Rhs of bindings are CpeRhss + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + + | FloatCase + Id CpeBody + Bool -- The bool indicates "ok-for-speculation" data Floats = Floats OkToSpec (OrdList FloatingBind) @@ -941,15 +935,15 @@ instance Outputable OkToSpec where ppr OkToSpec = ptext (sLit "OkToSpec") ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") ppr NotOkToSpec = ptext (sLit "NotOkToSpec") - + -- Can we float these binds out of the rhs of a let? We cache this decision -- to avoid having to recompute it in a non-linear way when there are -- deeply nested lets. data OkToSpec - = OkToSpec -- Lazy bindings of lifted type - | IfUnboxedOk -- A mixture of lazy lifted bindings and n - -- ok-to-speculate unlifted bindings - | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings + = OkToSpec -- Lazy bindings of lifted type + | IfUnboxedOk -- A mixture of lazy lifted bindings and n + -- ok-to-speculate unlifted bindings + | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind mkFloat is_strict is_unlifted bndr rhs @@ -957,10 +951,10 @@ mkFloat is_strict is_unlifted bndr rhs | otherwise = FloatLet (NonRec bndr rhs) where use_case = is_unlifted || is_strict && not (exprIsHNF rhs) - -- Don't make a case for a value binding, - -- even if it's strict. Otherwise we get - -- case (\x -> e) of ...! - + -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL @@ -979,13 +973,13 @@ addFloat (Floats ok_to_spec floats) new_float = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) where check (FloatLet _) = OkToSpec - check (FloatCase _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level unitFloat :: FloatingBind -> Floats unitFloat = addFloat emptyFloats @@ -1003,7 +997,7 @@ combine _ NotOkToSpec = NotOkToSpec combine IfUnboxedOk _ = IfUnboxedOk combine _ IfUnboxedOk = IfUnboxedOk combine _ _ = OkToSpec - + deFloatTop :: Floats -> [CoreBind] -- For top level only; we don't expect any FloatCases deFloatTop (Floats _ floats) @@ -1011,7 +1005,7 @@ deFloatTop (Floats _ floats) where get (FloatLet b) bs = occurAnalyseRHSs b : bs get b _ = pprPanic "corePrepPgm" (ppr b) - + -- See Note [Dead code in CorePrep] occurAnalyseRHSs (NonRec x e) = NonRec x (fst (dropDeadCode e)) occurAnalyseRHSs (Rec xes) = Rec [ (x, fst (dropDeadCode e)) @@ -1074,10 +1068,10 @@ dropDeadCodeAlts alts = (alts', unionVarSets fvss) canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -- Note [CafInfo and floating] canFloatFromNoCaf (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec -- Worth trying + | OkToSpec <- ok_to_spec -- Worth trying , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) = Just (Floats OkToSpec fs', subst_expr subst rhs) - | otherwise + | otherwise = Nothing where subst_expr = substExpr (text "CorePrep") @@ -1086,8 +1080,8 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs -> Maybe (Subst, OrdList FloatingBind) go (subst, fbs_out) [] = Just (subst, fbs_out) - - go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) + + go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) | rhs_ok r = go (subst', fbs_out `snocOL` new_fb) fbs_in where @@ -1103,10 +1097,10 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs rs' = map (subst_expr subst') rs new_fb = FloatLet (Rec (bs' `zip` rs')) - go _ _ = Nothing -- Encountered a caffy binding + go _ _ = Nothing -- Encountered a caffy binding ------------ - set_nocaf_bndr subst bndr + set_nocaf_bndr subst bndr = (extendIdSubst subst bndr (Var bndr'), bndr') where bndr' = bndr `setIdCafInfo` NoCafRefs @@ -1123,14 +1117,14 @@ wantFloatNested is_rec strict_or_unlifted floats rhs = isEmptyFloats floats || strict_or_unlifted || (allLazyNested is_rec floats && exprIsHNF rhs) - -- Why the test for allLazyNested? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early + -- Why the test for allLazyNested? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early allLazyTop :: Floats -> Bool allLazyTop (Floats OkToSpec _) = True -allLazyTop _ = False +allLazyTop _ = False allLazyNested :: RecFlag -> Floats -> Bool allLazyNested _ (Floats OkToSpec _) = True @@ -1140,17 +1134,17 @@ allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec %************************************************************************ -%* * - Cloning -%* * +%* * + Cloning +%* * %************************************************************************ \begin{code} -- --------------------------------------------------------------------------- --- The environment +-- The environment -- --------------------------------------------------------------------------- -data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids +data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids emptyCorePrepEnv :: CorePrepEnv emptyCorePrepEnv = CPE emptyVarEnv @@ -1164,8 +1158,8 @@ extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs) lookupCorePrepEnv :: CorePrepEnv -> Id -> Id lookupCorePrepEnv (CPE env) id = case lookupVarEnv env id of - Nothing -> id - Just id' -> id' + Nothing -> id + Just id' -> id' ------------------------------------------------------------------------------ -- Cloning binders @@ -1178,7 +1172,7 @@ cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cpCloneBndr env bndr | isLocalId bndr, not (isCoVar bndr) = do bndr' <- setVarUnique bndr <$> getUniqueM - + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings -- so that we can drop more stuff as dead code. -- See also Note [Dead code in CorePrep] @@ -1186,11 +1180,11 @@ cpCloneBndr env bndr `setIdSpecialisation` emptySpecInfo return (extendCorePrepEnv env bndr bndr'', bndr'') - | otherwise -- Top level things, which we don't want - -- to clone, have become GlobalIds by now - -- And we don't clone tyvars, or coercion variables + | otherwise -- Top level things, which we don't want + -- to clone, have become GlobalIds by now + -- And we don't clone tyvars, or coercion variables = return (env, bndr) - + ------------------------------------------------------------------------------ -- Cloning ccall Ids; each must have a unique name, @@ -1198,7 +1192,7 @@ cpCloneBndr env bndr -- --------------------------------------------------------------------------- fiddleCCall :: Id -> UniqSM Id -fiddleCCall id +fiddleCCall id | isFCallId id = (id `setVarUnique`) <$> getUniqueM | otherwise = return id |