[project @ 2000-02-04 17:02:11 by lewie]

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

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 9da068a..6cd2af3 100644 (file)
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -39,8 +39,10 @@ import TysPrim               ( openAlphaTyVars, alphaTyVar, alphaTy,
                        )
 import TysWiredIn      ( boolTy, charTy, mkListTy )
 import PrelMods                ( pREL_ERR, pREL_GHC )
-import Type            ( Type, ThetaType,
-                         mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
+import PrelRules       ( primOpRule )
+import Rules           ( addRule )
+import Type            ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
+                         mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
                          splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
                          splitFunTys, splitForAllTys, unUsgTy,
@@ -48,9 +50,9 @@ import Type           ( Type, ThetaType,
                        )
 import Module          ( Module )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
-import Subst           ( mkTopTyVarSubst, substTheta )
+import Subst           ( mkTopTyVarSubst, substClasses )
 import TyCon           ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
-import Class           ( Class, classBigSig, classTyCon )
+import Class           ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
 import Var             ( Id, TyVar )
 import VarSet          ( isEmptyVarSet )
 import Const           ( Con(..) )
@@ -59,7 +61,7 @@ import Name           ( mkDerivedName, mkWiredInIdName, mkLocalName,
                          Name, NamedThing(..),
                        )
 import OccName         ( mkSrcVarOcc )
-import PrimOp          ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
+import PrimOp          ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness )
 import Demand          ( wwStrict )
 import DataCon         ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels, 
                          dataConArgTys, dataConSig, dataConRawArgTys
@@ -70,7 +72,7 @@ import Id             ( idType, mkId,
                        )
 import IdInfo          ( vanillaIdInfo, mkIdInfo,
                          exactArity, setUnfoldingInfo, setCafInfo,
-                         setArityInfo, setInlinePragInfo,
+                         setArityInfo, setInlinePragInfo, setSpecInfo,
                          mkStrictnessInfo, setStrictnessInfo,
                          IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
                        )
@@ -154,7 +156,7 @@ mkDataConId data_con
   where
     (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
     id_ty = mkSigmaTy (tyvars ++ ex_tyvars) 
-                     (theta ++ ex_theta)
+                     (classesToPreds (theta ++ ex_theta))
                      (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
 \end{code}
 
@@ -374,7 +376,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
@@ -384,7 +386,7 @@ mkDictSelId name clas ty
 
     unfolding = mkTopUnfolding rhs
 
-    (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+    tyvars  = classTyVars clas
 
     tycon      = classTyCon clas
     [data_con] = tyConDataCons tycon
@@ -422,6 +424,20 @@ mkPrimitiveId prim_op
     info = mkIdInfo (ConstantId (PrimOp prim_op))
           `setUnfoldingInfo`   unfolding
 
+-- Not yet... 
+--        `setSpecInfo`        rules
+--        `setArityInfo`       exactArity arity
+--        `setStrictnessInfo`  strict_info
+
+    arity              = primOpArity prim_op
+    (dmds, result_bot) = primOpStrictness prim_op
+    strict_info                = mkStrictnessInfo (take arity dmds, result_bot)
+       -- primOpStrictness can return an infinite list of demands
+       -- (cheap hack) but Ids mustn't have such things.
+       -- What a mess.
+
+    rules = addRule id emptyCoreRules (primOpRule prim_op)
+
     unfolding = mkCompulsoryUnfolding rhs
                -- The mkCompulsoryUnfolding says that this Id absolutely 
                -- must be inlined.  It's only used for primitives, 
@@ -444,14 +460,20 @@ mkDictFunId :: Name               -- Name to use for the dict fun;
            -> Class 
            -> [TyVar]
            -> [Type]
-           -> ThetaType
+           -> ClassContext
            -> Id
 
 mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
   = mkVanillaId dfun_name dfun_ty
   where
-    (class_tyvars, sc_theta, _, _, _) = classBigSig clas
-    sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+    (class_tyvars, sc_theta, _, _) = classBigSig clas
+    sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+
+    dfun_theta = classesToPreds inst_decl_theta
+
+{-  1 dec 99: disable the Mark Jones optimisation for the sake
+    of compatibility with Hugs.
+    See `types/InstEnv' for a discussion related to this.
 
     dfun_theta = case inst_decl_theta of
                   []    -> []  -- If inst_decl_theta is empty, then we don't
@@ -472,7 +494,7 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
                                --   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))