[project @ 2001-05-03 09:32:48 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcIfaceSig.lhs

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 0a97ff4..b922e62 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -25,7 +25,7 @@ import CoreUnfold
 import CoreLint                ( lintUnfolding )
 import WorkWrap                ( mkWrapper )
 
-import Id              ( Id, mkId, mkVanillaId, idName, isDataConWrapId_maybe )
+import Id              ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
 import Module          ( Module )
 import MkId            ( mkCCallOpId )
 import IdInfo
@@ -74,17 +74,24 @@ tcInterfaceSigs unf_env mod decls
        tcIfaceType ty                                  `thenTc` \ sigma_ty ->
        tcIdInfo unf_env in_scope_vars name 
                 sigma_ty id_infos                      `thenTc` \ id_info ->
-       returnTc (mkId name sigma_ty id_info)
+       returnTc (mkVanillaGlobal name sigma_ty id_info)
 \end{code}
 
 \begin{code}
 tcIdInfo unf_env in_scope_vars name ty info_ins
-  = foldlTc tcPrag constantIdInfo info_ins
+  = foldlTc tcPrag init_info info_ins 
   where
-    tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
+    -- set the CgInfo to something sensible but uninformative before
+    -- we start, because the default CgInfo is a panic.
+    init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
+
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`   NoCafRefs)
     tcPrag info HsCprInfo       = returnTc (info `setCprInfo`   ReturnsCPR)
 
+    tcPrag info (HsArity arity) = 
+       returnTc (info `setArityInfo` (ArityExactly arity)
+                      `setCgArity`   arity)
+
     tcPrag info (HsUnfold inline_prag expr)
        = tcPragExpr unf_env name in_scope_vars expr    `thenNF_Tc` \ maybe_expr' ->
          let
@@ -101,35 +108,34 @@ tcIdInfo unf_env in_scope_vars name ty info_ins
     tcPrag info (HsStrictness strict_info)
        = returnTc (info `setStrictnessInfo` strict_info)
 
-    tcPrag info (HsWorker nm)
-       = tcWorkerInfo unf_env ty info nm
+    tcPrag info (HsWorker nm arity)
+       = tcWorkerInfo unf_env ty info nm arity
 \end{code}
 
 \begin{code}
-tcWorkerInfo unf_env ty info worker_name
-  | not (hasArity arity_info)
-  = pprPanic "Worker with no arity info" (ppr worker_name)
- 
-  | otherwise
+tcWorkerInfo unf_env ty info worker_name arity
   = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
     let
        -- Watch out! We can't pull on unf_env too eagerly!
        info' = case tcLookupRecId_maybe unf_env worker_name of
-                 Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
-                                         `setWorkerInfo`     HasWorker worker_id arity
+                 Just worker_id -> 
+                   info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
+                        `setWorkerInfo`     HasWorker worker_id arity
 
-                 Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
+                 Nothing -> pprTrace "tcWorkerInfo failed:" 
+                               (ppr worker_name) info
     in
     returnTc info'
   where
-       -- We are relying here on arity, cpr and strictness info always appearing 
+       -- We are relying here on cpr and strictness info always appearing 
        -- before worker info,  fingers crossed ....
-      arity_info = arityInfo info
-      arity      = arityLowerBound arity_info
       cpr_info   = cprInfo info
-      (demands, res_bot)    = case strictnessInfo info of
-                               StrictnessInfo d r -> (d,r)
-                               _                  -> (take arity (repeat wwLazy),False)        -- Noncommittal
+
+      (demands, res_bot)
+       = case strictnessInfo info of
+               StrictnessInfo d r -> (d,r)
+               _                  -> (take arity (repeat wwLazy),False)
+                                       -- Noncommittal
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
@@ -236,7 +242,7 @@ tcCoreExpr (UfCase scrut case_bndr alts)
   = tcCoreExpr scrut                                   `thenTc` \ scrut' ->
     let
        scrut_ty = exprType scrut'
-       case_bndr' = mkVanillaId case_bndr scrut_ty
+       case_bndr' = mkLocalId case_bndr scrut_ty
     in
     tcExtendGlobalValEnv [case_bndr']  $
     mapTc (tcCoreAlt scrut_ty) alts    `thenTc` \ alts' ->
@@ -271,7 +277,7 @@ tcCoreExpr (UfNote note expr)
 tcCoreLamBndr (UfValBinder name ty) thing_inside
   = tcIfaceType ty             `thenTc` \ ty' ->
     let
-       id = mkVanillaId name ty'
+       id = mkLocalId name ty'
     in
     tcExtendGlobalValEnv [id] $
     thing_inside id
@@ -291,7 +297,7 @@ tcCoreLamBndrs (b:bs) thing_inside
 tcCoreValBndr (UfValBinder name ty) thing_inside
   = tcIfaceType ty                     `thenTc` \ ty' ->
     let
-       id = mkVanillaId name ty'
+       id = mkLocalId name ty'
     in
     tcExtendGlobalValEnv [id] $
     thing_inside id
@@ -299,7 +305,7 @@ tcCoreValBndr (UfValBinder name ty) thing_inside
 tcCoreValBndrs bndrs thing_inside              -- Expect them all to be ValBinders
   = mapTc tcIfaceType tys              `thenTc` \ tys' ->
     let
-       ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
+       ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
     in
     tcExtendGlobalValEnv ids $
     thing_inside ids
@@ -348,7 +354,7 @@ tcCoreAlt scrut_ty alt@(con, names, rhs)
                                         ppr arg_tys)
                | otherwise
 #endif
-               = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
+               = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
     in
     ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
     tcExtendTyVarEnv ex_tyvars'                        $