[project @ 1999-11-29 17:34:14 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 d13463e..158cc3d 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -41,18 +41,18 @@ import TysWiredIn   ( boolTy, charTy, mkListTy )
 import PrelMods                ( pREL_ERR, pREL_GHC )
 import Type            ( Type, ThetaType,
                          mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
-                         isUnLiftedType, mkForAllTys, mkTyVarTy, 
+                         isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
                          splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
                          splitFunTys, splitForAllTys, unUsgTy,
                          mkUsgTy, UsageAnn(..)
                        )
 import Module          ( Module )
-import CoreUnfold      ( mkUnfolding )
+import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
 import Subst           ( mkTopTyVarSubst, substTheta )
 import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
-import Class           ( Class, classBigSig, classTyCon )
+import Class           ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
 import Var             ( Id, TyVar )
-import VarEnv          ( zipVarEnv )
+import VarSet          ( isEmptyVarSet )
 import Const           ( Con(..) )
 import Name            ( mkDerivedName, mkWiredInIdName, mkLocalName, 
                          mkWorkerOcc, mkSuperDictSelOcc,
@@ -199,7 +199,9 @@ dataConInfo data_con
     `setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args)
     `setUnfoldingInfo` unfolding
   where
-        unfolding = mkUnfolding (Note InlineMe con_rhs)
+        unfolding = mkTopUnfolding (Note InlineMe con_rhs)
+       -- The dictionary constructors of a class don't get a binding,
+       -- but they are always saturated, so they should always be inlined.
 
        (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) 
           = dataConSig data_con
@@ -290,7 +292,7 @@ mkRecordSelId field_label selector_ty
           
        -- ToDo: consider adding further IdInfo
 
-    unfolding = mkUnfolding sel_rhs
+    unfolding = mkTopUnfolding sel_rhs
 
     (tyvars, theta, tau)  = splitSigmaTy selector_ty
     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
@@ -343,7 +345,7 @@ mkNewTySelId field_label selector_ty = sel_id
           
        -- ToDo: consider adding further IdInfo
 
-    unfolding = mkUnfolding sel_rhs
+    unfolding = mkTopUnfolding sel_rhs
 
     (tyvars, theta, tau)  = splitSigmaTy selector_ty
     (data_ty,rhs_ty)      = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
@@ -353,7 +355,7 @@ mkNewTySelId field_label selector_ty = sel_id
        
     [data_id] = mkTemplateLocals [data_ty]
     sel_rhs   = mkLams tyvars $ Lam data_id $
-               Note (Coerce rhs_ty data_ty) (Var data_id)
+               Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id)
 \end{code}
 
 
@@ -372,7 +374,7 @@ mkDictSelId name clas ty
   where
     sel_id    = mkId name ty info
     field_lbl = mkFieldLabel name ty tag
-    tag       = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
+    tag       = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
 
     info      = mkIdInfo (RecordSelId field_lbl)
                `setUnfoldingInfo`  unfolding
@@ -380,9 +382,9 @@ mkDictSelId name clas ty
        -- We no longer use 'must-inline' on record selectors.  They'll
        -- inline like crazy if they scrutinise a constructor
 
-    unfolding = mkUnfolding rhs
+    unfolding = mkTopUnfolding rhs
 
-    (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+    tyvars  = classTyVars clas
 
     tycon      = classTyCon clas
     [data_con] = tyConDataCons tycon
@@ -419,13 +421,11 @@ mkPrimitiveId prim_op
                
     info = mkIdInfo (ConstantId (PrimOp prim_op))
           `setUnfoldingInfo`   unfolding
-          `setInlinePragInfo`  IMustBeINLINEd
-               -- The pragma @IMustBeINLINEd@ says that this Id absolutely 
+
+    unfolding = mkCompulsoryUnfolding rhs
+               -- The mkCompulsoryUnfolding says that this Id absolutely 
                -- must be inlined.  It's only used for primitives, 
                -- because we don't want to make a closure for each of them.
-          
-
-    unfolding = mkUnfolding rhs
 
     args = mkTemplateLocals arg_tys
     rhs =  mkLams tyvars $ mkLams args $
@@ -450,7 +450,7 @@ mkDictFunId :: Name         -- Name to use for the dict fun;
 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
   = mkVanillaId dfun_name dfun_ty
   where
-    (class_tyvars, sc_theta, _, _, _) = classBigSig clas
+    (class_tyvars, sc_theta, _, _) = classBigSig clas
     sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
 
     dfun_theta = case inst_decl_theta of
@@ -458,7 +458,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
                                -- want to have any dict arguments, so that we can
                                -- expose the constant methods.
 
-                  other -> nub (inst_decl_theta ++ sc_theta')
+                  other -> nub (inst_decl_theta ++ filter not_const sc_theta')
                                -- Otherwise we pass the superclass dictionaries to
                                -- the dictionary function; the Mark Jones optimisation.
                                --
@@ -467,8 +467,15 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
                                --   instance Monad m => MonadT (EnvT env) m where ...
                                -- Here, the inst_decl_theta has (Monad m); but so
                                -- does the sc_theta'!
+                               --
+                               -- NOTE the "not_const".  I got caught by this one too:
+                               --   class Foo a => Baz a b where ...
+                               --   instance Wob b => Baz T b where..
+                               -- Now sc_theta' has Foo T
 
     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
+
+    not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
 \end{code}
 
 
@@ -493,8 +500,7 @@ unsafeCoerceId
   = pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
   where
     info = vanillaIdInfo
-          `setUnfoldingInfo`   mkUnfolding rhs
-          `setInlinePragInfo`  IMustBeINLINEd 
+          `setUnfoldingInfo` mkCompulsoryUnfolding rhs
           
 
     ty  = mkForAllTys [openAlphaTyVar,openBetaTyVar]
@@ -513,8 +519,7 @@ getTagId
   = pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
   where
     info = vanillaIdInfo
-          `setUnfoldingInfo`   mkUnfolding rhs
-          `setInlinePragInfo`  IMustBeINLINEd 
+          `setUnfoldingInfo`   mkCompulsoryUnfolding rhs
        -- We don't provide a defn for this; you must inline it
 
     ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)