[project @ 2001-11-19 16:34:12 by simonpj]

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

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 97adb94..c112a2a 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -22,7 +22,7 @@ module MkId (
 
        -- And some particular Ids; see below for why they are wired in
        wiredInIds,
-       unsafeCoerceId, realWorldPrimId, nullAddrId,
+       unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId,
        eRROR_ID, eRROR_CSTRING_ID, rEC_SEL_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID,
        rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID,
        nO_METHOD_BINDING_ERROR_ID, aBSENT_ERROR_ID, pAR_ERROR_ID
@@ -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
@@ -841,6 +841,13 @@ dataToTagId = mkPrimOpId DataToTagOp
 @realWorld#@ used to be a magic literal, \tr{void#}.  If things get
 nasty as-is, change it back to a literal (@Literal@).
 
+voidArgId is a Local Id used simply as an argument in functions
+where we just want an arg to avoid having a thunk of unlifted type.
+E.g.
+       x = \ void :: State# RealWorld -> (# p, q #)
+
+This comes up in strictness analysis
+
 \begin{code}
 realWorldPrimId        -- :: State# RealWorld
   = pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
@@ -850,6 +857,9 @@ realWorldPrimId     -- :: State# RealWorld
        -- which in turn makes Simplify.interestingArg return True,
        -- which in turn makes INLINE things applied to realWorld# likely
        -- to be inlined
+
+voidArgId      -- :: State# RealWorld
+  = mkSysLocal SLIT("void") voidArgIdKey realWorldStatePrimTy
 \end{code}
 
 
@@ -929,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