[project @ 2001-12-07 11:34:48 by sewardj]

[ghc-hetmet.git] / ghc / compiler / basicTypes / MkId.lhs

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index e15b79a..c112a2a 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -45,7 +45,7 @@ import TcType         ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
                          tcSplitFunTys, tcSplitForAllTys, mkPredTy
                        )
 import Module          ( Module )
-import CoreUtils       ( mkInlineMe, exprType )
+import CoreUtils       ( exprType )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
 import Literal         ( Literal(..), nullAddrLit )
 import TyCon           ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
@@ -71,13 +71,13 @@ import Id           ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
                        )
 import IdInfo          ( IdInfo, noCafNoTyGenIdInfo,
                          setUnfoldingInfo, 
-                         setArityInfo, setSpecInfo,  setCgInfo, setCafInfo,
-                         mkNewStrictnessInfo, setNewStrictnessInfo,
-                         GlobalIdDetails(..), CafInfo(..), CprInfo(..), 
-                         CgInfo 
+                         setArityInfo, setSpecInfo, setCafInfo,
+                         newStrictnessFromOld, setAllStrictnessInfo,
+                         GlobalIdDetails(..), CafInfo(..), CprInfo(..)
                        )
 import NewDemand       ( mkStrictSig, strictSigResInfo, DmdResult(..),
-                         mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) )
+                         mkTopDmdType, topDmd, evalDmd, lazyDmd, 
+                         Demand(..), Demands(..) )
 import FieldLabel      ( mkFieldLabel, fieldLabelName, 
                          firstFieldLabelTag, allFieldLabelTags, fieldLabelType
                        )
@@ -147,7 +147,7 @@ mkDataConId work_name data_con
   where
     info = noCafNoTyGenIdInfo
           `setArityInfo`               arity
-          `setNewStrictnessInfo`       Just strict_sig
+          `setAllStrictnessInfo`       Just strict_sig
 
     arity      = dataConRepArity data_con
 
@@ -238,15 +238,15 @@ mkDataConWrapId data_con
           `setArityInfo`       arity
                -- It's important to specify the arity, so that partial
                -- applications are treated as values
-          `setNewStrictnessInfo`       Just wrap_sig
+          `setAllStrictnessInfo`       Just wrap_sig
 
     wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
 
     wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
     res_info = strictSigResInfo (idNewStrictness work_id)
     arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks
-    mk_dmd str | isMarkedStrict str = Eval
-              | otherwise          = Lazy
+    mk_dmd str | isMarkedStrict str = evalDmd
+              | otherwise          = lazyDmd
        -- The Cpr info can be important inside INLINE rhss, where the
        -- wrapper constructor isn't inlined.
        -- And the argument strictness can be important too; we
@@ -444,7 +444,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
           `setCafInfo`           caf_info
           `setArityInfo`         arity
           `setUnfoldingInfo`     mkTopUnfolding rhs_w_str
-          `setNewStrictnessInfo` Just strict_sig
+          `setAllStrictnessInfo` Just strict_sig
 
        -- Allocate Ids.  We do it a funny way round because field_dict_tys is
        -- almost always empty.  Also note that we use length_tycon_theta
@@ -588,7 +588,7 @@ mkDictSelId name clas
     info      = noCafNoTyGenIdInfo
                `setArityInfo`          1
                `setUnfoldingInfo`      mkTopUnfolding rhs
-               `setNewStrictnessInfo`  Just strict_sig
+               `setAllStrictnessInfo`  Just strict_sig
 
        -- We no longer use 'must-inline' on record selectors.  They'll
        -- inline like crazy if they scrutinise a constructor
@@ -598,9 +598,9 @@ mkDictSelId name clas
        -- It's worth giving one, so that absence info etc is generated
        -- even if the selector isn't inlined
     strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] TopRes)
-    arg_dmd | isNewTyCon tycon = Eval
-           | otherwise        = Seq Drop [ if the_arg_id == id then Eval else Abs
-                                         | id <- arg_ids ]
+    arg_dmd | isNewTyCon tycon = evalDmd
+           | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+                                           | id <- arg_ids ])
 
     tyvars  = classTyVars clas
 
@@ -648,7 +648,7 @@ mkPrimOpId prim_op
     info = noCafNoTyGenIdInfo
           `setSpecInfo`        rules
           `setArityInfo`       arity
-          `setNewStrictnessInfo`       Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo)
+          `setAllStrictnessInfo`       Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
        -- Until we modify the primop generation code
 
     rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
@@ -678,7 +678,7 @@ mkFCallId uniq fcall ty
 
     info = noCafNoTyGenIdInfo
           `setArityInfo`               arity
-          `setNewStrictnessInfo`       Just strict_sig
+          `setAllStrictnessInfo`       Just strict_sig
 
     (_, tau)    = tcSplitForAllTys ty
     (arg_tys, _) = tcSplitFunTys tau
@@ -939,7 +939,7 @@ pc_bottoming_Id key mod name ty
  = pcMiscPrelId key mod name ty bottoming_info
  where
     strict_sig    = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-    bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig
+    bottoming_info = noCafNoTyGenIdInfo `setAllStrictnessInfo` Just strict_sig
        -- these "bottom" out, no matter what their arguments
 
 generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy