From 791ce2a522626b1332617e9af79e4909dd9bdb2b Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Mon, 19 Apr 1999 16:30:55 +0000
Subject: [PATCH] [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.
---
ghc/compiler/hsSyn/HsDecls.lhs | 9 ++++----
ghc/compiler/rename/ParseIface.y | 33 +++++++++++++++++----------
ghc/compiler/rename/RnSource.lhs | 26 ++++++++-------------
ghc/compiler/typecheck/TcIfaceSig.lhs | 26 +++++++++++++--------
4 files changed, 52 insertions(+), 42 deletions(-)
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index adefae8d337f..5874f69df479 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -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}
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 4b48681da531..2e7218c8a6c3 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -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 }
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 9e1d592a707b..fbcae1c48101 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -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.
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index df7745432176..7bf4f4c345f9 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -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}
--
GitLab