X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=7bd99109ba5588f2a1a0db447b4f286e9b6a325d;hb=d93785d99261a433075dcbac8c388730a4dec64f;hp=198463333551404b17445ed82eaeab82f11b8212;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 1984633..7bd9910 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -13,8 +13,7 @@ have a standard form, namely:
 
 \begin{code}
 module MkId (
-        mkDictFunId, mkDefaultMethodId,
-        mkDictSelId, 
+        mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
 
         mkDataConIds,
         mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
@@ -26,10 +25,7 @@ module MkId (
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
         unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
-        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
-
-	-- Re-export error Ids
-	module PrelRules
+        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
     ) where
 
 #include "HsVersions.h"
@@ -107,24 +103,9 @@ is right here.
 \begin{code}
 wiredInIds :: [Id]
 wiredInIds
-  = [   
-
-    eRROR_ID,   -- This one isn't used anywhere else in the compiler
-                -- But we still need it in wiredInIds so that when GHC
-                -- compiles a program that mentions 'error' we don't
-                -- import its type from the interface file; we just get
-                -- the Id defined here.  Which has an 'open-tyvar' type.
-
-    rUNTIME_ERROR_ID,
-    iRREFUT_PAT_ERROR_ID,
-    nON_EXHAUSTIVE_GUARDS_ERROR_ID,
-    nO_METHOD_BINDING_ERROR_ID,
-    pAT_ERROR_ID,
-    rEC_CON_ERROR_ID,
-    rEC_SEL_ERROR_ID,
-
-    lazyId
-    ] ++ ghcPrimIds
+  =  [lazyId]
+  ++ errorIds		-- Defined in MkCore
+  ++ ghcPrimIds
 
 -- These Ids are exported from GHC.Prim
 ghcPrimIds :: [Id]
@@ -318,6 +299,7 @@ mkDataConIds wrap_name wkr_name data_con
                     `setArityInfo`         wrap_arity
                         -- It's important to specify the arity, so that partial
                         -- applications are treated as values
+		    `setInlinePragInfo`    alwaysInlinePragma
                     `setUnfoldingInfo`     wrap_unf
                     `setStrictnessInfo` Just wrap_sig
 
@@ -335,7 +317,7 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkInlineRule wrap_rhs (Just (length dict_args + length id_args))
+    wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
     wrap_rhs = mkLams wrap_tvs $ 
                mkLams eq_args $
                mkLams dict_args $ mkLams id_args $
@@ -451,19 +433,21 @@ mkDictSelId no_unf name clas
 
     base_info = noCafIdInfo
                 `setArityInfo`      1
-                `setStrictnessInfo`  Just strict_sig
+                `setStrictnessInfo` Just strict_sig
                 `setUnfoldingInfo`  (if no_unf then noUnfolding
-				     else mkImplicitUnfolding rhs)
+	                             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 = base_info    `setSpecInfo`       mkSpecInfo [rule]
-			`setInlinePragInfo` neverInlinePragma
-		-- Add a magic BuiltinRule, and never inline it
-		-- so that the rule is always available to fire.
-		-- See Note [ClassOp/DFun selection] in TcInstDcls
+    info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
+    	   	   -- See Note [Single-method classes] for why alwaysInlinePragma
+         | otherwise = base_info  `setSpecInfo`       mkSpecInfo [rule]
+		       		  `setInlinePragInfo` neverInlinePragma
+		   -- 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
 
@@ -509,15 +493,11 @@ mkDictSelId no_unf name clas
 
 dictSelRule :: Int -> Arity -> Arity 
             -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
--- Oh, very clever
---       sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+-- Tries to persuade the argument to look like a constructor
+-- application, using exprIsConApp_maybe, and then selects
+-- from it
 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
--- NB: the data constructor has the same number of type and 
---     coercion args as the selector
---
--- This only works for *value* superclasses
--- There are no selector functions for equality superclasses
 dictSelRule val_index n_ty_args n_eq_args id_unf args
   | (dict_arg : _) <- drop n_ty_args args
   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
@@ -856,12 +836,29 @@ mkDictFunId :: Name      -- Name to use for the dict fun;
             -> Class 
             -> [Type]
             -> Id
+-- Implements the DFun Superclass Invariant (see TcInstDcls)
 
-mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
-  = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo
+mkDictFunId dfun_name tvs theta clas tys
+  = mkExportedLocalVar (DFunId n_silent is_nt)
+                       dfun_name
+                       dfun_ty
+                       vanillaIdInfo
   where
     is_nt = isNewTyCon (classTyCon clas)
-    dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
+    (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
+
+mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
+mkDictFunTy tvs theta clas tys
+  = (length silent_theta, dfun_ty)
+  where
+    dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkDictTy clas tys)
+    silent_theta = filterOut discard $
+                   substTheta (zipTopTvSubst (classTyVars clas) tys)
+                              (classSCTheta clas)
+                   -- See Note [Silent Superclass Arguments]
+    discard pred = isEmptyVarSet (tyVarsOfPred pred)
+                 || any (`tcEqPred` pred) theta
+                 -- See the DFun Superclass Invariant in TcInstDcls
 \end{code}