[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.

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index adefae8..5874f69 100644 (file)
--- 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 4b48681..2e7218c 100644 (file)
--- 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 9e1d592..fbcae1c 100644 (file)
--- 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 df77454..7bf4f4c 100644 (file)
--- 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}