\begin{code}
dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
dmdAnalPgm dflags binds
+ = panic "dmdAnalPgm called"
+dmdAnalPgm dflags binds
= do {
showPass dflags "Demand analysis" ;
let { binds_plus_dmds = do_prog binds ;
dmd_changes = get_changes binds_plus_dmds } ;
endPass dflags "Demand analysis"
Opt_D_dump_stranal binds_plus_dmds ;
+#ifdef DEBUG
+ -- Only if DEBUG is on, because only then is the old strictness analyser run
printDump (text "Changes in demands" $$ dmd_changes) ;
+#endif
return binds_plus_dmds
}
where
isProductTyCon tycon,
not (isRecursiveTyCon tycon)
= let
- bndr_ids = filter isId bndrs
- (alt_ty, alt') = dmdAnalAlt sigs dmd alt
- (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
- (_, bndrs', _) = alt'
- scrut_dmd = Seq Drop Now [idNewDemandInfo b | b <- bndrs', isId b]
- (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
+ bndr_ids = filter isId bndrs
+ (alt_ty, alt') = dmdAnalAlt sigs dmd alt
+ (alt_ty1, case_bndr') = annotateBndr alt_ty case_bndr
+ (_, bndrs', _) = alt'
+
+ -- Figure out whether the case binder is used, and use
+ -- that to set the keepity of the demand. This is utterly essential.
+ -- Consider f x = case x of y { (a,b) -> k y a }
+ -- If we just take scrut_demand = U(L,A), then we won't pass x to the
+ -- worker, so the worker will rebuild
+ -- x = (a, absent-error)
+ -- and that'll crash.
+ dead_case_bndr = isAbsentDmd (idNewDemandInfo case_bndr')
+ keepity | dead_case_bndr = Drop
+ | otherwise = Keep
+
+ scrut_dmd = Seq keepity Now [idNewDemandInfo b | b <- bndrs', isId b]
+ (scrut_ty, scrut') = dmdAnal sigs scrut_dmd scrut
in
(alt_ty1 `bothType` scrut_ty, Case scrut' case_bndr' [alt'])
-- processing the RHSs with sigs (= sigs'), whereas pairs
-- is the result of processing the RHSs with the *previous*
-- iteration of sigs.
- | n >= 5 = pprTrace "dmdFix" (ppr n <+> ppr pairs) (loop (n+1) sigs' pairs')
+ | n >= 5 = pprTrace "dmdFix" (ppr n <+> (vcat
+ [ text "Sigs:" <+> ppr [(id,lookup sigs id, lookup sigs' id) | (id,_) <- pairs],
+ text "env:" <+> ppr (ufmToList sigs),
+ text "binds:" <+> ppr pairs]))
+ (loop (n+1) sigs' pairs')
| otherwise = {- pprTrace "dmdFixLoop" (ppr id_sigs) -} (loop (n+1) sigs' pairs')
where
-- Use the new signature to do the next pair
lub Abs (Seq k _ ds) = Seq k Defer ds -- Very important ('radicals' example)
lub Abs d = Lazy
-lub Eval Abs = Lazy
-lub Eval Lazy = Lazy
-lub Eval (Seq k Now ds) = Seq Keep Now ds
-lub Eval d = Eval
+lub Eval Abs = Lazy
+lub Eval Lazy = Lazy
+lub Eval (Seq k Now ds) = Seq Keep Now ds
+lub Eval (Seq k Defer ds) = Lazy
+lub Eval d = Eval
lub (Call d1) (Call d2) = Call (lub d1 d2)
-- both Bot d = Bot
-- The experimental one
+-- The idea is that (error x) places on x
+-- both demand Bot (like on all free vars)
+-- and demand Eval (for the arg to error)
+-- and we want the result to be Eval.
both Bot Bot = Bot
both Bot Abs = Bot
both Bot d = d
-
-both Abs Bot = Bot
both Abs d = d
-both Err Bot = Bot
+both Err Bot = Err
both Err Abs = Err
both Err d = d
-both Lazy Bot = Bot
-both Lazy Abs = Lazy
-both Lazy Err = Lazy
-both Lazy (Seq k Now ds) = Seq Keep Now ds
-both Lazy d = d
+both Lazy Bot = Lazy
+both Lazy Abs = Lazy
+both Lazy Err = Lazy
+both Lazy (Seq k l ds) = Seq Keep l ds
+both Lazy d = d
+ -- Notice that the Seq case ensures that we have the
+ -- boxed value. The equation originally said
+ -- both (Seq k Now ds) = Seq Keep Now ds
+ -- but it's important that the Keep is switched on even
+ -- for a deferred demand. Otherwise a (Seq Drop Now [])
+ -- might both'd with the result, and then we won't pass
+ -- the boxed value. Here's an example:
+ -- (x-1) `seq` (x+1, x)
+ -- From the (x+1, x) we get (U*(V) `both` L), which must give S*(V)
+ -- From (x-1) we get U(V). Combining, we must get S(V).
+ -- If we got U*(V) from the pair, we'd end up with U(V), and that
+ -- can be a disaster if a component of the data structure is absent.
+ -- [Disaster = enter an absent argument.]
--- Part of the Bot like Err experiment
--- both Eval Bot = Bot
both Eval (Seq k l ds) = Seq Keep Now ds
both Eval (Call d) = Call d
both Eval d = Eval
get_changes_expr (App e1 e2) = get_changes_expr e1 $$ get_changes_expr e2
get_changes_expr (Lam b e) = {- get_changes_var b $$ -} get_changes_expr e
get_changes_expr (Let b e) = get_changes_bind b $$ get_changes_expr e
-get_changes_expr (Case e b a) = get_changes_expr e $$ get_changes_var b $$ vcat (map get_changes_alt a)
+get_changes_expr (Case e b a) = get_changes_expr e $$ {- get_changes_var b $$ -} vcat (map get_changes_alt a)
get_changes_alt (con,bs,rhs) = {- vcat (map get_changes_var bs) $$ -} get_changes_expr rhs
projects / ghc-hetmet.git / blobdiff