+data SimplCont -- Strict contexts
+ = Stop OutType -- Type of the result
+ Bool -- True => This is the RHS of a thunk whose type suggests
+ -- that update-in-place would be possible
+ -- (This makes the inliner a little keener.)
+
+ | CoerceIt OutType -- The To-type, simplified
+ SimplCont
+
+ | InlinePlease -- This continuation makes a function very
+ SimplCont -- keen to inline itelf
+
+ | ApplyTo DupFlag
+ InExpr SubstEnv -- The argument, as yet unsimplified,
+ SimplCont -- and its subst-env
+
+ | Select DupFlag
+ InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
+ SimplCont
+
+ | ArgOf DupFlag -- An arbitrary strict context: the argument
+ -- of a strict function, or a primitive-arg fn
+ -- or a PrimOp
+ OutType -- cont_ty: the type of the expression being sought by the context
+ -- f (error "foo") ==> coerce t (error "foo")
+ -- when f is strict
+ -- We need to know the type t, to which to coerce.
+ (OutExpr -> SimplM OutExprStuff) -- What to do with the result
+ -- The result expression in the OutExprStuff has type cont_ty
+
+instance Outputable SimplCont where
+ ppr (Stop _ _) = ptext SLIT("Stop")
+ ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
+ ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
+ ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
+ (nest 4 (ppr alts)) $$ ppr cont
+ ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
+ ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
+
+data DupFlag = OkToDup | NoDup
+
+instance Outputable DupFlag where
+ ppr OkToDup = ptext SLIT("ok")
+ ppr NoDup = ptext SLIT("nodup")
+
+
+-------------------
+mkRhsStop, mkStop :: OutType -> SimplCont
+mkStop ty = Stop ty False
+mkRhsStop ty = Stop ty (canUpdateInPlace ty)
+
+
+-------------------
+contIsDupable :: SimplCont -> Bool
+contIsDupable (Stop _ _) = True
+contIsDupable (ApplyTo OkToDup _ _ _) = True
+contIsDupable (ArgOf OkToDup _ _) = True
+contIsDupable (Select OkToDup _ _ _ _) = True
+contIsDupable (CoerceIt _ cont) = contIsDupable cont
+contIsDupable (InlinePlease cont) = contIsDupable cont
+contIsDupable other = False
+
+-------------------
+discardInline :: SimplCont -> SimplCont
+discardInline (InlinePlease cont) = cont
+discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
+discardInline cont = cont
+
+-------------------
+discardableCont :: SimplCont -> Bool
+discardableCont (Stop _ _) = False
+discardableCont (CoerceIt _ cont) = discardableCont cont
+discardableCont (InlinePlease cont) = discardableCont cont
+discardableCont other = True
+
+discardCont :: SimplCont -- A continuation, expecting
+ -> SimplCont -- Replace the continuation with a suitable coerce
+discardCont cont = case cont of
+ Stop to_ty _ -> cont
+ other -> CoerceIt to_ty (mkStop to_ty)
+ where
+ to_ty = contResultType cont
+
+-------------------
+contResultType :: SimplCont -> OutType
+contResultType (Stop to_ty _) = to_ty
+contResultType (ArgOf _ to_ty _) = to_ty
+contResultType (ApplyTo _ _ _ cont) = contResultType cont
+contResultType (CoerceIt _ cont) = contResultType cont
+contResultType (InlinePlease cont) = contResultType cont
+contResultType (Select _ _ _ _ cont) = contResultType cont
+
+-------------------
+countValArgs :: SimplCont -> Int
+countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
+countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
+countValArgs other = 0
+
+countArgs :: SimplCont -> Int
+countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
+countArgs other = 0
+\end{code}
+
+
+\begin{code}
+getContArgs :: OutId -> SimplCont
+ -> SimplM ([(InExpr, SubstEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont, -- Remaining continuation
+ Bool) -- Whether we came across an InlineCall
+-- getContArgs id k = (args, k', inl)
+-- args are the leading ApplyTo items in k
+-- (i.e. outermost comes first)
+-- augmented with demand info from the functionn
+getContArgs fun orig_cont
+ = getSwitchChecker `thenSmpl` \ chkr ->
+ let
+ -- Ignore strictness info if the no-case-of-case
+ -- flag is on. Strictness changes evaluation order
+ -- and that can change full laziness
+ stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
+ | otherwise = computed_stricts
+ in
+ go [] stricts False orig_cont
+ where
+ ----------------------------
+
+ -- Type argument
+ go acc ss inl (ApplyTo _ arg@(Type _) se cont)
+ = go ((arg,se,False) : acc) ss inl cont
+ -- NB: don't bother to instantiate the function type
+
+ -- Value argument
+ go acc (s:ss) inl (ApplyTo _ arg se cont)
+ = go ((arg,se,s) : acc) ss inl cont
+
+ -- An Inline continuation
+ go acc ss inl (InlinePlease cont)
+ = go acc ss True cont
+
+ -- We're run out of arguments, or else we've run out of demands
+ -- The latter only happens if the result is guaranteed bottom
+ -- This is the case for
+ -- * case (error "hello") of { ... }
+ -- * (error "Hello") arg
+ -- * f (error "Hello") where f is strict
+ -- etc
+ go acc ss inl cont
+ | null ss && discardableCont cont = tick BottomFound `thenSmpl_`
+ returnSmpl (reverse acc, discardCont cont, inl)
+ | otherwise = returnSmpl (reverse acc, cont, inl)
+
+ ----------------------------
+ vanilla_stricts, computed_stricts :: [Bool]
+ vanilla_stricts = repeat False
+ computed_stricts = zipWith (||) fun_stricts arg_stricts
+
+ ----------------------------
+ (val_arg_tys, _) = splitRepFunTys (idType fun)
+ arg_stricts = map isStrictType val_arg_tys ++ repeat False
+ -- These argument types are used as a cheap and cheerful way to find
+ -- unboxed arguments, which must be strict. But it's an InType
+ -- and so there might be a type variable where we expect a function
+ -- type (the substitution hasn't happened yet). And we don't bother
+ -- doing the type applications for a polymorphic function.
+ -- Hence the split*Rep*FunTys
+
+ ----------------------------
+ -- If fun_stricts is finite, it means the function returns bottom
+ -- after that number of value args have been consumed
+ -- Otherwise it's infinite, extended with False
+ fun_stricts
+ = case idStrictness fun of
+ StrictnessInfo demands result_bot
+ | not (demands `lengthExceeds` countValArgs orig_cont)
+ -> -- Enough args, use the strictness given.
+ -- For bottoming functions we used to pretend that the arg
+ -- is lazy, so that we don't treat the arg as an
+ -- interesting context. This avoids substituting
+ -- top-level bindings for (say) strings into
+ -- calls to error. But now we are more careful about
+ -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
+ if result_bot then
+ map isStrict demands -- Finite => result is bottom
+ else
+ map isStrict demands ++ vanilla_stricts
+
+ other -> vanilla_stricts -- Not enough args, or no strictness
+
+-------------------
+interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
+ -- An argument is interesting if it has *some* structure
+ -- We are here trying to avoid unfolding a function that
+ -- is applied only to variables that have no unfolding
+ -- (i.e. they are probably lambda bound): f x y z
+ -- There is little point in inlining f here.
+interestingArg in_scope arg subst
+ = analyse (substExpr (mkSubst in_scope subst) arg)
+ -- 'analyse' only looks at the top part of the result
+ -- and substExpr is lazy, so this isn't nearly as brutal
+ -- as it looks.
projects / ghc-hetmet.git / blobdiff