X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=e3b40b843224afcda4674bea5e3618ace3355704;hb=4bd1e966ffb4985f180e9728328ff7e3e7b37bb1;hp=d927e16a71aa5699c3c82b41301474ff39376034;hpb=ed51bb0f84523769612c9c05807f879e1985c59b;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index d927e16..e3b40b8 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -1,7 +1,7 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1998
 %
-\section[StdIdInfo]{Standard unfoldings}
 
 This module contains definitions for the IdInfo for things that
 have a standard form, namely:
@@ -38,71 +38,40 @@ module MkId (
 
 #include "HsVersions.h"
 
-
-import BasicTypes	( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
-import Rules		( mkSpecInfo )
-import TysPrim		( openAlphaTyVars, alphaTyVar, alphaTy, 
-			  realWorldStatePrimTy, addrPrimTy
-			)
-import TysWiredIn	( charTy, mkListTy )
-import PrelRules	( primOpRules )
-import Type		( TyThing(..), mkForAllTy, tyVarsOfTypes, 
- 			  newTyConInstRhs, mkTopTvSubst, substTyVar, 
- 			  substTys, zipTopTvSubst )
-import TcGadt           ( gadtRefine, refineType, emptyRefinement )
-import HsBinds          ( HsWrapper(..), isIdHsWrapper )
-import Coercion         ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
-import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
-			  mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
-			  mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType,
-			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
-			  tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
-			)
-import CoreUtils	( exprType, dataConOrigInstPat, mkCoerce )
-import CoreUnfold 	( mkTopUnfolding, mkCompulsoryUnfolding )
-import Literal		( nullAddrLit, mkStringLit )
-import TyCon		( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
-			  FieldLabel,
-                          tyConStupidTheta, isProductTyCon, isDataTyCon,
-                          isRecursiveTyCon, isFamInstTyCon,
-                          tyConFamInst_maybe, tyConFamilyCoercion_maybe,
-                          newTyConCo_maybe )
-import Class		( Class, classTyCon, classSelIds )
-import Var		( Id, TyVar, Var, setIdType )
-import VarSet		( isEmptyVarSet, subVarSet, varSetElems )
-import Name		( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..))
-import OccName		( mkOccNameFS, varName )
-import PrimOp		( PrimOp, primOpSig, primOpOcc, primOpTag )
-import ForeignCall	( ForeignCall )
-import DataCon		( DataCon, DataConIds(..), dataConTyCon,
-			  dataConUnivTyVars, 
-			  dataConFieldLabels, dataConRepArity, dataConResTys,
-			  dataConRepArgTys, dataConRepType, dataConFullSig,
-			  dataConStrictMarks, dataConExStricts, 
-			  splitProductType, isVanillaDataCon, dataConFieldType,
-			  deepSplitProductType, 
-			)
-import Id		( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, 
-			  mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
-			  mkTemplateLocal, idName
-			)
-import IdInfo		( IdInfo, noCafIdInfo,  setUnfoldingInfo, 
-			  setArityInfo, setSpecInfo, setCafInfo,
-			  setAllStrictnessInfo, vanillaIdInfo,
-			  GlobalIdDetails(..), CafInfo(..)
-			)
-import NewDemand	( mkStrictSig, DmdResult(..),
-			  mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
-			  Demand(..), Demands(..) )
-import DmdAnal		( dmdAnalTopRhs )
+import Rules
+import TysPrim
+import TysWiredIn
+import PrelRules
+import Type
+import TcGadt
+import HsBinds
+import Coercion
+import TcType
+import CoreUtils
+import CoreUnfold
+import Literal
+import TyCon
+import Class
+import VarSet
+import Name
+import OccName
+import PrimOp
+import ForeignCall
+import DataCon
+import Id
+import Var              ( Var, TyVar)
+import IdInfo
+import NewDemand
+import DmdAnal
 import CoreSyn
-import Unique		( mkBuiltinUnique, mkPrimOpIdUnique )
+import Unique
 import Maybes
 import PrelNames
-import Util             ( dropList, isSingleton )
+import BasicTypes       hiding ( SuccessFlag(..) )
+import Util
 import Outputable
 import FastString
-import ListSetOps	( assoc, minusList )
+import ListSetOps
 \end{code}		
 
 %************************************************************************
@@ -277,6 +246,7 @@ mkDataConIds wrap_name wkr_name data_con
 							-- even if arity = 0
 
     wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
+	--	Note [Data-con worker strictness]
 	-- Notice that we do *not* say the worker is strict
 	-- even if the data constructor is declared strict
 	--	e.g. 	data T = MkT !(Int,Int)
@@ -623,14 +593,14 @@ mkRecordSelId tycon field_label
 	--		T1 b' (c : [b]=[b']) (x:Maybe b') 
 	--			-> x `cast` Maybe (sym (right c))
 
-        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
-        (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+
 		-- Generate the refinement for b'=b, 
 		-- and apply to (Maybe b'), to get (Maybe b)
-
-        rhs = case co_fn of
-		WpCo co -> Cast (Var the_arg_id) co
-		id_co	    -> ASSERT(isIdHsWrapper id_co) Var the_arg_id
+        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+	the_arg_id_ty = idType the_arg_id
+        (rhs, res_ty) = case refineType refinement the_arg_id_ty of
+			  Just (co, res_ty) -> (Cast (Var the_arg_id) co, res_ty)
+			  Nothing	    -> (Var the_arg_id, the_arg_id_ty)
 
 	field_vs    = filter (not . isPredTy . idType) arg_vs 
     	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
@@ -895,7 +865,7 @@ mkPrimOpId prim_op
     ty   = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
     name = mkWiredInName gHC_PRIM (primOpOcc prim_op) 
 			 (mkPrimOpIdUnique (primOpTag prim_op))
-			 Nothing (AnId id) UserSyntax
+			 (AnId id) UserSyntax
     id   = mkGlobalId (PrimOpId prim_op) name ty info
 		
     info = noCafIdInfo
@@ -1034,7 +1004,7 @@ another gun with which to shoot yourself in the foot.
 
 \begin{code}
 mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
 
 unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#")	   nullAddrIdKey      nullAddrId
@@ -1226,9 +1196,5 @@ pc_bottoming_Id name ty
 
     strict_sig	   = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
 	-- These "bottom" out, no matter what their arguments
-
-(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
-openAlphaTy  = mkTyVarTy openAlphaTyVar
-openBetaTy   = mkTyVarTy openBetaTyVar
 \end{code}