Remove the (very) old strictness analyser

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

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 98425f1..1eacea9 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -65,7 +65,7 @@ import DataCon
 import Id
 import Var              ( Var, TyVar, mkCoVar, mkExportedLocalVar )
 import IdInfo
-import NewDemand
+import Demand
 import CoreSyn
 import Unique
 import PrelNames
@@ -265,7 +265,7 @@ mkDataConIds wrap_name wkr_name data_con
     wkr_arity = dataConRepArity data_con
     wkr_info  = noCafIdInfo
                 `setArityInfo`          wkr_arity
-                `setAllStrictnessInfo`  Just wkr_sig
+                `setStrictnessInfo`  Just wkr_sig
                 `setUnfoldingInfo`      evaldUnfolding  -- Record that it's evaluated,
                                                         -- even if arity = 0
 
@@ -329,7 +329,7 @@ mkDataConIds wrap_name wkr_name data_con
                         -- It's important to specify the arity, so that partial
                         -- applications are treated as values
                     `setUnfoldingInfo`     wrap_unf
-                    `setAllStrictnessInfo` Just wrap_sig
+                    `setStrictnessInfo` Just wrap_sig
 
     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
     wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
@@ -457,17 +457,25 @@ mkDictSelId no_unf name clas
         -- But it's type must expose the representation of the dictionary
         -- to get (say)         C a -> (a -> a)
 
-    info = noCafIdInfo
-                `setArityInfo`          1
-                `setAllStrictnessInfo`  Just strict_sig
-               `setSpecInfo`       mkSpecInfo [rule]
-               `setInlinePragInfo` neverInlinePragma
+    base_info = noCafIdInfo
+                `setArityInfo`      1
+                `setStrictnessInfo`  Just strict_sig
                 `setUnfoldingInfo`  (if no_unf then noUnfolding
-                                      else mkImplicitUnfolding rhs)
-       -- Experimental: NOINLINE, so that their rule matches
-
-        -- We no longer use 'must-inline' on record selectors.  They'll
-        -- inline like crazy if they scrutinise a constructor
+                                    else mkImplicitUnfolding rhs)
+                  -- In module where class op is defined, we must add
+                  -- the unfolding, even though it'll never be inlined
+                  -- becuase we use that to generate a top-level binding
+                  -- for the ClassOp
+
+    info | new_tycon = base_info  
+                        -- For newtype dictionaries, just inline the class op
+                         -- See Note [Single-method classes] in TcInstDcls
+         | otherwise = base_info
+                       `setSpecInfo`       mkSpecInfo [rule]
+                       `setInlinePragInfo` neverInlinePragma
+                       -- Otherwise add a magic BuiltinRule, and never inline it
+                       -- so that the rule is always available to fire.
+                       -- See Note [ClassOp/DFun selection] in TcInstDcls
 
     n_ty_args = length tyvars
 
@@ -484,11 +492,12 @@ mkDictSelId no_unf 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 = evalDmd
-            | otherwise        = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
-                                            | id <- arg_ids ])
+    arg_dmd | new_tycon = evalDmd
+            | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
+                                     | id <- arg_ids ])
 
     tycon      = classTyCon clas
+    new_tycon  = isNewTyCon tycon
     [data_con] = tyConDataCons tycon
     tyvars     = dataConUnivTyVars data_con
     arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
@@ -497,8 +506,8 @@ mkDictSelId no_unf name clas
     the_arg_id = arg_ids !! index
 
     pred       = mkClassPred clas (mkTyVarTys tyvars)
-    dict_id    = mkTemplateLocal     1 $ mkPredTy pred
-    (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta
+    dict_id    = mkTemplateLocal 1 $ mkPredTy pred
+    (eq_ids,n) = mkCoVarLocals   2 $ mkPredTys eq_theta
     arg_ids    = mkTemplateLocalsNum n arg_tys
 
     mkCoVarLocals i []     = ([],i)
@@ -507,9 +516,9 @@ mkDictSelId no_unf name clas
                              in (y:ys,j)
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
-    rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
-             | otherwise        = Case (Var dict_id) dict_id (idType the_arg_id)
-                                       [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+    rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
+             | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
+                                [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
 
 dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr
 -- Oh, very clever
@@ -754,7 +763,7 @@ mkPrimOpId prim_op
     info = noCafIdInfo
            `setSpecInfo`          mkSpecInfo (primOpRules prim_op name)
            `setArityInfo`         arity
-           `setAllStrictnessInfo` Just strict_sig
+           `setStrictnessInfo` Just strict_sig
 
 -- For each ccall we manufacture a separate CCallOpId, giving it
 -- a fresh unique, a type that is correct for this particular ccall,
@@ -780,7 +789,7 @@ mkFCallId uniq fcall ty
 
     info = noCafIdInfo
            `setArityInfo`         arity
-           `setAllStrictnessInfo` Just strict_sig
+           `setStrictnessInfo` Just strict_sig
 
     (_, tau)     = tcSplitForAllTys ty
     (arg_tys, _) = tcSplitFunTys tau
@@ -1149,7 +1158,7 @@ pc_bottoming_Id :: Name -> Type -> Id
 pc_bottoming_Id name ty
  = pcMiscPrelId name ty bottoming_info
  where
-    bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
+    bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
                                   `setArityInfo`         1
                        -- Make arity and strictness agree