Commit 791ce2a5 authored by simonm's avatar simonm
Browse files

[project @ 1999-04-19 16:30:51 by simonm]

Allow a worker to be present for functions with no strictness info in
an interface file.  This is useful for functions which get hit by CPR
but not the strictness analyser.
parent 07876618
......@@ -448,17 +448,16 @@ instance (Outputable name) => Outputable (IfaceSig name) where
data HsIdInfo name
= HsArity ArityInfo
| HsStrictness (HsStrictnessInfo name)
| HsStrictness HsStrictnessInfo
| HsUnfold InlinePragInfo (Maybe (UfExpr name))
| HsUpdate UpdateInfo
| HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
| HsNoCafRefs
| HsCprInfo CprInfo
| HsWorker name [name] -- Worker, if any
-- and needed constructors
data HsStrictnessInfo name
data HsStrictnessInfo
= HsStrictnessInfo ([Demand], Bool)
(Maybe (name, [name])) -- Worker, if any
-- and needed constructors
| HsBottom
\end{code}
......@@ -526,13 +526,12 @@ akind :: { Kind }
--------------------------------------------------------------------------
id_info :: { [HsIdInfo RdrName] }
id_info : { [] }
: { [] }
| id_info_item id_info { $1 : $2 }
| strict_info id_info { $1 ++ $2 }
id_info_item :: { HsIdInfo RdrName }
id_info_item : '__A' arity_info { HsArity $2 }
| strict_info { HsStrictness $1 }
| '__M' { HsCprInfo $1 }
: '__A' arity_info { HsArity $2 }
| '__U' core_expr { HsUnfold $1 (Just $2) }
| '__U' { HsUnfold $1 Nothing }
| '__P' spec_tvs
......@@ -540,18 +539,28 @@ id_info_item : '__A' arity_info { HsArity $2 }
| '__C' { HsNoCafRefs }
strict_info :: { [HsIdInfo RdrName] }
: cpr worker { ($1:$2) }
| strict worker { ($1:$2) }
| cpr strict worker { ($1:$2:$3) }
cpr :: { HsIdInfo RdrName }
: '__M' { HsCprInfo $1 }
strict :: { HsIdInfo RdrName }
: '__S' { HsStrictness (HsStrictnessInfo $1) }
worker :: { [HsIdInfo RdrName] }
: qvar_name '{' qdata_names '}' { [HsWorker $1 $3] }
| qvar_name { [HsWorker $1 []] }
| {- nothing -} { [] }
spec_tvs :: { [HsTyVar RdrName] }
spec_tvs : '[' tv_bndrs ']' { $2 }
: '[' tv_bndrs ']' { $2 }
arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) }
strict_info :: { HsStrictnessInfo RdrName }
strict_info : '__S' qvar_name '{' qdata_names '}'
{ HsStrictnessInfo $1 (Just ($2,$4)) }
| '__S' qvar_name { HsStrictnessInfo $1 (Just ($2,[])) }
| '__S' { HsStrictnessInfo $1 Nothing }
: INTEGER { exactArity (fromInteger $1) }
-------------------------------------------------------
core_expr :: { UfExpr RdrName }
......
......@@ -630,9 +630,16 @@ rnContext doc ctxt
%*********************************************************
\begin{code}
rnIdInfo (HsStrictness strict)
= rnStrict strict `thenRn` \ strict' ->
returnRn (HsStrictness strict')
rnIdInfo (HsStrictness str) = returnRn (HsStrictness str)
rnIdInfo (HsWorker worker cons)
-- The sole purpose of the "cons" field is so that we can mark the
-- constructors needed to build the wrapper as "needed", so that their
-- data type decl will be slurped in. After that their usefulness is
-- o'er, so we just put in the empty list.
= lookupOccRn worker `thenRn` \ worker' ->
mapRn lookupOccRn cons `thenRn_`
returnRn (HsWorker worker' [])
rnIdInfo (HsUnfold inline (Just expr)) = rnCoreExpr expr `thenRn` \ expr' ->
returnRn (HsUnfold inline (Just expr'))
......@@ -648,19 +655,6 @@ rnIdInfo (HsSpecialise tyvars tys expr)
returnRn (HsSpecialise tyvars' tys' expr')
where
doc = text "Specialise in interface pragma"
rnStrict (HsStrictnessInfo demands (Just (worker,cons)))
-- The sole purpose of the "cons" field is so that we can mark the constructors
-- needed to build the wrapper as "needed", so that their data type decl will be
-- slurped in. After that their usefulness is o'er, so we just put in the empty list.
= lookupOccRn worker `thenRn` \ worker' ->
mapRn lookupOccRn cons `thenRn_`
returnRn (HsStrictnessInfo demands (Just (worker',[])))
-- Boring, but necessary for the type checker.
rnStrict (HsStrictnessInfo demands Nothing) = returnRn (HsStrictnessInfo demands Nothing)
rnStrict HsBottom = returnRn HsBottom
\end{code}
UfCore expressions.
......
......@@ -107,8 +107,11 @@ tcIdInfo unf_env name ty info info_ins
in
returnTc info2
tcPrag info (HsStrictness strict)
= tcStrictness unf_env ty info strict
tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
= returnTc (StrictnessInfo demands bot_result `setStrictnessInfo` info)
tcPrag info (HsWorker nm cons)
= tcWorkerInfo unf_env ty info nm cons
tcPrag info (HsSpecialise tyvars tys rhs)
= tcExtendTyVarScope tyvars $ \ tyvars' ->
......@@ -134,12 +137,17 @@ tcIdInfo unf_env name ty info info_ins
\end{code}
\begin{code}
tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worker)
= tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
-- We are relying here on cpr info always appearing before strictness info
-- fingers crossed ....
uniqSMToTcM (mkWrapper ty demands (cprInfo info))
`thenNF_Tc` \ wrap_fn ->
tcWorkerInfo unf_env ty info nm cons
= tcWorker unf_env (Just (nm,cons)) `thenNF_Tc` \ maybe_worker_id ->
-- We are relying here on cpr and strictness info always appearing
-- before strictness info, fingers crossed ....
let
demands = case strictnessInfo info of
StrictnessInfo d _ -> d
_ -> []
cpr_info = cprInfo info
in
uniqSMToTcM (mkWrapper ty demands cpr_info) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on maybe_worker_id too eagerly!
info' = case maybe_worker_id of
......@@ -151,7 +159,7 @@ tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worke
has_worker = maybeToBool maybe_worker_id
in
returnTc (StrictnessInfo demands bot_result `setStrictnessInfo` info')
returnTc info'
\end{code}
\begin{code}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment