[project @ 1996-05-16 09:42:08 by partain]

SLPJ changes through 960515

ghc/compiler/basicTypes/IdInfo.lhs

@@ -81,11 +81,10 @@ import Outputable	( ifPprInterface, Outputable(..){-instances-} )
 import PprStyle		( PprStyle(..) )
 import Pretty
 import SrcLoc		( mkUnknownSrcLoc )
-import Type		( eqSimpleTy )
+import Type		( eqSimpleTy, splitFunTyExpandingDicts )
 import Util		( mapAccumL, panic, assertPanic, pprPanic )
 
 applySubstToTy = panic "IdInfo.applySubstToTy"
-splitTypeWithDictsAsArgs = panic "IdInfo.splitTypeWithDictsAsArgs"
 showTypeCategory = panic "IdInfo.showTypeCategory"
 mkFormSummary = panic "IdInfo.mkFormSummary"
 occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr"
@@ -583,9 +582,8 @@ mkWrapperArgTypeCategories
 	-> String	-- a string saying lots about the args
 
 mkWrapperArgTypeCategories wrapper_ty wrap_info
-  = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) ->
-    map do_one (wrap_info `zip` (map showTypeCategory arg_tys))
-    }
+  = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
+    map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
   where
     -- ToDo: this needs FIXING UP (it was a hack anyway...)
     do_one (WwPrim, _) = 'P'

ghc/compiler/basicTypes/Name.lhs

@@ -12,7 +12,7 @@ module Name (
 	RdrName(..),
 	isUnqual,
 	isQual,
-	isRdrLexCon,
+	isRdrLexCon, isRdrLexConOrSpecial,
 	appendRdr,
 	showRdr,
 	cmpRdr,
@@ -22,7 +22,7 @@ module Name (
 	mkLocalName, isLocalName, 
 	mkTopLevName, mkImportedName,
 	mkImplicitName,	isImplicitName,
-	mkBuiltinName, mkCompoundName,
+	mkBuiltinName, mkCompoundName, mkCompoundName2,
 
 	mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
 	mkTupNameStr,
@@ -31,7 +31,7 @@ module Name (
 	ExportFlag(..),
 	isExported{-overloaded-}, exportFlagOn{-not-},
 
-	nameUnique,
+	nameUnique, changeUnique,
 	nameOccName,
 	nameOrigName,
 	nameExportFlag,
@@ -88,6 +88,9 @@ isQual (Qual _ _) = True
 isRdrLexCon (Unqual n) = isLexCon n
 isRdrLexCon (Qual m n) = isLexCon n
 
+isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
+isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
+
 appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
 appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
 			   Qual m (n _APPEND_ str)
@@ -95,7 +98,7 @@ appendRdr (Qual m n) str = ASSERT(not (fromPrelude m))
 cmpRdr (Unqual n1)  (Unqual n2)  = _CMP_STRING_ n1 n2
 cmpRdr (Unqual n1)  (Qual m2 n2) = LT_
 cmpRdr (Qual m1 n1) (Unqual n2)  = GT_
-cmpRdr (Qual m1 n1) (Qual m2 n2) = thenCmp (_CMP_STRING_ m1 m2) (_CMP_STRING_ n1 n2) 
+cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ m1 m2 `thenCmp` _CMP_STRING_ n1 n2
 
 instance Eq RdrName where
     a == b = case (a `cmp` b) of { EQ_ -> True;  _ -> False }
@@ -174,15 +177,36 @@ mkImplicitName :: Unique -> RdrName -> Name
 mkImplicitName u o = Global u o Implicit NotExported []
 
 mkBuiltinName :: Unique -> Module -> FAST_STRING -> Name
-mkBuiltinName u m n = Global u (Unqual n) Builtin NotExported []
-
-mkCompoundName :: Unique -> [FAST_STRING] -> Name
-mkCompoundName u ns
-  = Global u (Unqual{-???-} (_CONCAT_ (dotify ns))) Builtin{--} NotExported []
-  where
-    dotify []  = []
-    dotify [n] = [n]
-    dotify (n:ns) = n : (map (_CONS_ '.') ns)
+mkBuiltinName u m{-NB: unused(?)-} n = Global u (Unqual n) Builtin NotExported []
+
+mkCompoundName :: Unique
+	       -> FAST_STRING	-- indicates what kind of compound thing it is (e.g., "sdsel")
+	       -> [RdrName]	-- "dot" these names together
+	       -> Name		-- from which we get provenance, etc....
+	       -> Name		-- result!
+
+mkCompoundName u str ns (Local _ _ _) = panic "mkCompoundName:Local?"
+mkCompoundName u str ns (Global _ _ prov exp _)
+  = Global u (Unqual{-???-} (_CONCAT_ (glue ns [str]))) prov exp []
+
+glue []            acc = reverse acc
+glue (Unqual n:ns) acc = glue ns (_CONS_ '.' n : acc)
+glue (Qual m n:ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc)
+
+-- this ugly one is used for instance-y things
+mkCompoundName2 :: Unique
+	       -> FAST_STRING	-- indicates what kind of compound thing it is (e.g., "sdsel")
+	       -> [RdrName]	-- "dot" these names together
+	       -> [FAST_STRING] -- type-name strings
+	       -> Bool		-- True <=> defined in this module
+	       -> SrcLoc	
+	       -> Name		-- result!
+
+mkCompoundName2 u str ns ty_strs from_here locn
+  = Global u (Unqual{-???-} ((_CONCAT_ (glue ns [str])) _APPEND_ (_CONS_ '.' (_CONCAT_ ty_strs))))
+	     (if from_here then LocalDef locn else Imported ExportAll locn [])
+	     ExportAll{-instances-}
+	     []
 
 mkFunTyConName
   = mkBuiltinName funTyConKey		       pRELUDE_BUILTIN SLIT("->")
@@ -261,6 +285,13 @@ instance NamedThing Name where
 nameUnique (Local    u _ _)     = u
 nameUnique (Global   u _ _ _ _) = u
 
+-- when we renumber/rename things, we need to be
+-- able to change a Name's Unique to match the cached
+-- one in the thing it's the name of.  If you know what I mean.
+changeUnique (Local      _ n l)      u = Local u n l
+changeUnique n@(Global   _ o p e os) u = ASSERT(not (isBuiltinName n))
+					 Global u o p e os
+
 nameOrigName (Local    _ n _)	     = Unqual n
 nameOrigName (Global   _ orig _ _ _) = orig
 
@@ -302,19 +333,16 @@ isPreludeDefinedName (Global   _ orig _ _ _) = isUnqual orig
 
 \begin{code}
 instance Outputable Name where
-#ifdef DEBUG
-    ppr PprDebug (Local    u n _)     = pp_debug u (ppPStr n)
-    ppr PprDebug (Global   u o _ _ _) = pp_debug u (ppr PprDebug o)
-#endif
-    ppr sty        (Local    u n _)             = pp_name sty n
+    ppr sty (Local u n _)
+      | codeStyle sty = pprUnique u
+      | otherwise     = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
+
+    ppr PprDebug   (Global   u o _ _ _)		= ppBesides [ppr PprDebug o, ppStr "{-", pprUnique u, ppStr "-}"]
     ppr PprForUser (Global   u o _ _ []  )      = ppr PprForUser o
     ppr PprForUser (Global   u o _ _ occs)      = ppr PprForUser (head occs)
     ppr PprShowAll (Global   u o prov exp occs) = pp_all o prov exp occs
     ppr sty        (Global   u o _ _ _)         = ppr sty o
 
-pp_debug uniq thing
-  = ppBesides [thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
-
 pp_all orig prov exp occs
   = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp]
 

ghc/compiler/basicTypes/Unique.lhs

@@ -49,7 +49,6 @@ module Unique (
 	appendIdKey,
 	arrayPrimTyConKey,
 	augmentIdKey,
-	binaryClassKey,
 	boolTyConKey,
 	boundedClassKey,
 	buildDataConKey,
@@ -57,6 +56,7 @@ module Unique (
 	byteArrayPrimTyConKey,
 	cCallableClassKey,
 	cReturnableClassKey,
+	voidTyConKey,
 	charDataConKey,
 	charPrimTyConKey,
 	charTyConKey,
@@ -112,6 +112,8 @@ module Unique (
 	mallocPtrTyConKey,
 	monadClassKey,
 	monadZeroClassKey,
+	monadPlusClassKey,
+	functorClassKey,
 	mutableArrayPrimTyConKey,
 	mutableByteArrayPrimTyConKey,
 	nilDataConKey,
@@ -416,26 +418,29 @@ getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
 %************************************************************************
 
 \begin{code}
-eqClassKey		= mkPreludeClassUnique 1
-ordClassKey		= mkPreludeClassUnique 2
-numClassKey		= mkPreludeClassUnique 3
-integralClassKey	= mkPreludeClassUnique 4
-fractionalClassKey	= mkPreludeClassUnique 5
-floatingClassKey	= mkPreludeClassUnique 6
-realClassKey		= mkPreludeClassUnique 7
-realFracClassKey	= mkPreludeClassUnique 8
-realFloatClassKey	= mkPreludeClassUnique 9
-ixClassKey		= mkPreludeClassUnique 10
-enumClassKey		= mkPreludeClassUnique 11
-showClassKey		= mkPreludeClassUnique 12
-readClassKey		= mkPreludeClassUnique 13
-monadClassKey		= mkPreludeClassUnique 14
-monadZeroClassKey	= mkPreludeClassUnique 15
-binaryClassKey		= mkPreludeClassUnique 16
-cCallableClassKey	= mkPreludeClassUnique 17	
-cReturnableClassKey	= mkPreludeClassUnique 18
-evalClassKey		= mkPreludeClassUnique 19
-boundedClassKey		= mkPreludeClassUnique 20
+boundedClassKey		= mkPreludeClassUnique 1 
+enumClassKey		= mkPreludeClassUnique 2 
+eqClassKey		= mkPreludeClassUnique 3 
+evalClassKey		= mkPreludeClassUnique 4 
+floatingClassKey	= mkPreludeClassUnique 5 
+fractionalClassKey	= mkPreludeClassUnique 6 
+integralClassKey	= mkPreludeClassUnique 7 
+monadClassKey		= mkPreludeClassUnique 8 
+monadZeroClassKey	= mkPreludeClassUnique 9 
+monadPlusClassKey	= mkPreludeClassUnique 10
+functorClassKey		= mkPreludeClassUnique 11
+numClassKey		= mkPreludeClassUnique 12
+ordClassKey		= mkPreludeClassUnique 13
+readClassKey		= mkPreludeClassUnique 14
+realClassKey		= mkPreludeClassUnique 15
+realFloatClassKey	= mkPreludeClassUnique 16
+realFracClassKey	= mkPreludeClassUnique 17
+showClassKey		= mkPreludeClassUnique 18
+					       
+cCallableClassKey	= mkPreludeClassUnique 19
+cReturnableClassKey	= mkPreludeClassUnique 20
+
+ixClassKey		= mkPreludeClassUnique 21
 \end{code}
 
 %************************************************************************
@@ -498,6 +503,7 @@ primIoTyConKey				= mkPreludeTyConUnique 51
 voidPrimTyConKey			= mkPreludeTyConUnique 52
 wordPrimTyConKey			= mkPreludeTyConUnique 53
 wordTyConKey				= mkPreludeTyConUnique 54
+voidTyConKey				= mkPreludeTyConUnique 55
 \end{code}
 
 %************************************************************************

ghc/compiler/codeGen/CgBindery.lhs

@@ -340,7 +340,7 @@ bindNewToLit name lit
 
 bindArgsToRegs :: [Id] -> [MagicId] -> Code
 bindArgsToRegs args regs
-  = listCs (zipWithEqual bind args regs)
+  = listCs (zipWithEqual "bindArgsToRegs" bind args regs)
   where
     arg `bind` reg = bindNewToReg arg reg mkLFArgument
 \end{code}

ghc/compiler/codeGen/CgCase.lhs

@@ -61,15 +61,12 @@ import PrimRep		( getPrimRepSize, isFollowableRep, retPrimRepSize,
 			)
 import TyCon		( isEnumerationTyCon )
 import Type		( typePrimRep,
-			  getDataSpecTyCon, getDataSpecTyCon_maybe,
+			  getAppSpecDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
 			  isEnumerationTyCon
 			)
 import Util		( sortLt, isIn, isn'tIn, zipEqual,
 			  pprError, panic, assertPanic
 			)
-
-getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)"
-getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)"
 \end{code}
 
 \begin{code}
@@ -385,7 +382,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -
     -- A temporary variable to hold the tag; this is unaffected by GC because
     -- the heap-checks in the branches occur after the switch
     tag_amode     = CTemp uniq IntRep
-    (spec_tycon, _, _) = getDataSpecTyCon ty
+    (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
 
 getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
 	-- Default is either StgNoDefault or StgBindDefault with unused binder
@@ -451,7 +448,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
 	-- which is worse than having the alt code in the switch statement
 
     let
-	(spec_tycon, _, _) = getDataSpecTyCon ty
+	(spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
 
 	use_labelled_alts
 	  = case ctrlReturnConvAlg spec_tycon of
@@ -588,7 +585,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
     default_join_lbl = mkDefaultLabel uniq
     jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
 
-    (spec_tycon, _, spec_cons) = getDataSpecTyCon ty
+    (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
 
     alt_cons = [ con | (con,_,_,_) <- alts ]
 
@@ -714,7 +711,7 @@ cgAlgAltRhs gc_flag con args use_mask rhs
       (live_regs, node_reqd)
 	= case (dataReturnConvAlg con) of
 	    ReturnInHeap      -> ([],						  True)
-	    ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
+	    ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
 				-- Pick the live registers using the use_mask
 				-- Doing so is IMPORTANT, because with semi-tagging
 				-- enabled only the live registers will have valid
@@ -1053,7 +1050,7 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC
     -- )
   where
 
-    (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
+    (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
 	      Just xx -> xx
 	      Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty)
 

ghc/compiler/codeGen/CgCon.lhs

@@ -50,11 +50,10 @@ import Id		( idPrimRep, dataConTag, dataConTyCon,
 			)
 import Literal		( Literal(..) )
 import Maybes		( maybeToBool )
+import PrelInfo		( maybeCharLikeTyCon, maybeIntLikeTyCon )
 import PrimRep		( isFloatingRep, PrimRep(..) )
+import TyCon		( TyCon{-instance Uniquable-} )
 import Util		( isIn, zipWithEqual, panic, assertPanic )
-
-maybeCharLikeTyCon = panic "CgCon.maybeCharLikeTyCon (ToDo)"
-maybeIntLikeTyCon  = panic "CgCon.maybeIntLikeTyCon  (ToDo)"
 \end{code}
 
 %************************************************************************
@@ -438,7 +437,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
 
 	      ReturnInRegs regs  ->
 	    	  let
-		      reg_assts = mkAbstractCs (zipWithEqual move_to_reg amodes regs)
+		      reg_assts = mkAbstractCs (zipWithEqual "move_to_reg" move_to_reg amodes regs)
 		      info_lbl  = mkPhantomInfoTableLabel con
 		  in
 		  profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`

ghc/compiler/codeGen/CgConTbls.lhs

@@ -41,12 +41,12 @@ import Id		( dataConTag, dataConSig,
 			  GenId{-instance NamedThing-}
 			)
 import Name		( getLocalName )
+import PrelInfo		( maybeIntLikeTyCon )
 import PrimRep		( getPrimRepSize, PrimRep(..) )
 import TyCon		( tyConDataCons, mkSpecTyCon )
 import Type		( typePrimRep )
 import Util		( panic )
 
-maybeIntLikeTyCon = panic "CgConTbls.maybeIntLikeTyCon (ToDo)"
 mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)"
 \end{code}
 

ghc/compiler/codeGen/CgRetConv.lhs

@@ -235,7 +235,7 @@ makePrimOpArgsRobust op arg_amodes
 			   other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op)
 
 	arg_assts
-	  = mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes)
+	  = mkAbstractCs (zipWithEqual "assign_to_reg" assign_to_reg final_arg_regs non_robust_amodes)
 
 	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
 

ghc/compiler/codeGen/CgTailCall.lhs

@@ -353,10 +353,11 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
 
 	no_of_args = length arg_amodes
 
-	(reg_arg_assts, stk_arg_amodes)
-	    = (mkAbstractCs (zipWithEqual assign_to_reg arg_regs arg_amodes),
-			drop (length arg_regs) arg_amodes) -- No regs, or
-							   -- args beyond arity
+	(reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
+	    -- We get some stk_arg_amodes if (a) no regs, or (b) args beyond arity
+
+	reg_arg_assts
+	  = mkAbstractCs (zipWithEqual "assign_to_reg2" assign_to_reg arg_regs reg_arg_amodes)
 
 	assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
     in

ghc/compiler/codeGen/ClosureInfo.lhs

@@ -89,15 +89,15 @@ import Maybes		( assocMaybe, maybeToBool )
 import Name		( isLocallyDefined, getLocalName )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
+import PrelInfo		( maybeCharLikeTyCon, maybeIntLikeTyCon )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness )
 import SMRep		-- all of it
 import TyCon		( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type		( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys )
+import Type		( isPrimType, splitForAllTy, splitFunTyExpandingDicts,
+			  mkFunTys, maybeAppSpecDataTyConExpandingDicts
+			)
 import Util		( isIn, mapAccumL, panic, pprPanic, assertPanic )
 
-maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
-maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)"
-getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)"
 getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
 \end{code}
 
@@ -1136,9 +1136,9 @@ closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
 -- rather than take it from the Id. The Id is probably just "f"!
 
 closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
-  = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id)
+  = maybeAppSpecDataTyConExpandingDicts (fun_result_ty (length args) fun_id)
 
-closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id)
+closureType (MkClosureInfo id lf _) = maybeAppSpecDataTyConExpandingDicts (idType id)
 \end{code}
 
 @closureReturnsUnboxedType@ is used to check whether a closure, {\em
@@ -1163,7 +1163,7 @@ closureReturnsUnboxedType other_closure = False
 fun_result_ty arity id
   = let
 	(_, de_foralld_ty) = splitForAllTy (idType id)
-	(arg_tys, res_ty)  = splitFunTyWithDictsAsArgs de_foralld_ty
+	(arg_tys, res_ty)  = splitFunTyExpandingDicts de_foralld_ty
     in
     ASSERT(arity >= 0 && length arg_tys >= arity)
     mkFunTys (drop arity arg_tys) res_ty

ghc/compiler/coreSyn/CoreLift.lhs

@@ -28,7 +28,7 @@ import Id		( idType, mkSysLocal,
 import Name		( isLocallyDefined, getSrcLoc )
 import PrelInfo		( liftDataCon, mkLiftTy, statePrimTyCon )
 import TyCon		( isBoxedTyCon, TyCon{-instance-} )
-import Type		( maybeAppDataTyCon, eqTy )
+import Type		( maybeAppDataTyConExpandingDicts, eqTy )
 import UniqSupply	( getUnique, getUniques, splitUniqSupply, UniqSupply )
 import Util		( zipEqual, zipWithEqual, assertPanic, panic )
 
@@ -261,7 +261,7 @@ liftBinders top_lev bind liftM idenv s0
     (s1, s2)   = splitUniqSupply s0
     lift_ids   = [ id | id <- bindersOf bind, isUnboxedButNotState (idType id) ]
     lift_uniqs = getUniques (length lift_ids) s1
-    lift_map   = zipEqual lift_ids (zipWithEqual mkLiftedId lift_ids lift_uniqs)
+    lift_map   = zipEqual "liftBinders" lift_ids (zipWithEqual "liftBinders" mkLiftedId lift_ids lift_uniqs)
 
     -- ToDo: Give warning for recursive bindings involving unboxed values ???
 
@@ -312,7 +312,7 @@ applyBindUnlifts []     expr = expr
 applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr)
 
 isUnboxedButNotState ty
-  = case (maybeAppDataTyCon ty) of
+  = case (maybeAppDataTyConExpandingDicts ty) of
       Nothing -> False
       Just (tycon, _, _) ->
 	not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon)

ghc/compiler/coreSyn/CoreLint.lhs

 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
 %
 \section[CoreLint]{A ``lint'' pass to check for Core correctness}
 
@@ -31,10 +31,12 @@ import Pretty
 import PrimOp		( primOpType, PrimOp(..) )
 import PrimRep		( PrimRep(..) )
 import SrcLoc		( SrcLoc )
-import Type		( mkFunTy,getFunTy_maybe,mkForAllTy,getForAllTy_maybe,
-			  isPrimType,typeKind,instantiateTy,
+import Type		( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe,
+			  getFunTyExpandingDicts_maybe,
+			  isPrimType,typeKind,instantiateTy,splitSigmaTy,
 			  mkForAllUsageTy,getForAllUsageTy,instantiateUsage,
-			  maybeAppDataTyCon, eqTy
+			  maybeAppDataTyConExpandingDicts, eqTy
+--			  ,expandTy -- ToDo:rm
 			)
 import TyCon		( isPrimTyCon, tyConFamilySize )
 import TyVar		( tyVarKind, GenTyVar{-instances-} )
@@ -197,19 +199,25 @@ lintCoreExpr (Let binds body)
 	(addInScopeVars binders (lintCoreExpr body))
 
 lintCoreExpr e@(Con con args)
-  = lintCoreArgs False e (idType con) args
+  = lintCoreArgs {-False-} e unoverloaded_ty args
     -- Note: we don't check for primitive types in these arguments
+  where
+	-- Constructors are special in that they aren't passed their
+	-- dictionary arguments, so we swizzle them out of the
+	-- constructor type before handing over to lintCorArgs
+    unoverloaded_ty = mkForAllTys tyvars tau
+    (tyvars, theta, tau) = splitSigmaTy (idType con)
 
 lintCoreExpr e@(Prim op args)
-  = lintCoreArgs True e (primOpType op) args
+  = lintCoreArgs {-True-} e (primOpType op) args
     -- Note: we do check for primitive types in these arguments
 
 lintCoreExpr e@(App fun@(Var v) arg) | isBottomingId v
-  = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg False e ty arg
+  = lintCoreExpr fun `thenMaybeL` \ ty -> lintCoreArg {-False-} e ty arg
     -- Note: we don't check for primitive types in argument to 'error'
 
 lintCoreExpr e@(App fun arg)
-  = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg True e ty arg
+  = lintCoreExpr fun `thenMaybeL` \ty -> lintCoreArg {-True-} e ty arg
     -- Note: we do check for primitive types in this argument
 
 lintCoreExpr (Lam (ValBinder var) expr)
@@ -238,12 +246,12 @@ The boolean argument indicates whether we should flag type
 applications to primitive types as being errors.
 
 \begin{code}
-lintCoreArgs :: Bool -> CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
+lintCoreArgs :: {-Bool ->-} CoreExpr -> Type -> [CoreArg] -> LintM (Maybe Type)
 
-lintCoreArgs _          _ ty [] = returnL (Just ty)
-lintCoreArgs checkTyApp e ty (a : args)
-  = lintCoreArg  checkTyApp e ty  a `thenMaybeL` \ res ->
-    lintCoreArgs checkTyApp e res args
+lintCoreArgs _ ty [] = returnL (Just ty)
+lintCoreArgs e ty (a : args)
+  = lintCoreArg  e ty  a `thenMaybeL` \ res ->
+    lintCoreArgs e res args
 \end{code}
 
 %************************************************************************
@@ -253,23 +261,27 @@ lintCoreArgs checkTyApp e ty (a : args)
 %************************************************************************
 
 \begin{code}
-lintCoreArg :: Bool -> CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
+lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type)
 
-lintCoreArg _ e ty (LitArg lit)
+lintCoreArg e ty (LitArg lit)
   = -- Make sure function type matches argument
-    case (getFunTy_maybe ty) of
-      Just (arg,res) | (literalType lit `eqTy` arg) -> returnL(Just res)
-      _ -> addErrL (mkAppMsg ty (literalType lit) e) `seqL` returnL Nothing
+    case (getFunTyExpandingDicts_maybe ty) of
+      Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res)
+      _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing
+  where
+    lit_ty = literalType lit
 
-lintCoreArg _ e ty (VarArg v)
+lintCoreArg e ty (VarArg v)
   = -- Make sure variable is bound
     checkInScope v `seqL`
     -- Make sure function type matches argument
-    case (getFunTy_maybe ty) of
-      Just (arg,res) | (idType v `eqTy` arg) -> returnL(Just res)
-      _ -> addErrL (mkAppMsg ty (idType v) e) `seqL` returnL Nothing
+    case (getFunTyExpandingDicts_maybe ty) of
+      Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res)
+      _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing
+  where
+    var_ty = idType v
 
-lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
+lintCoreArg e ty a@(TyArg arg_ty)
   = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
     checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a)
     `seqL`
@@ -290,7 +302,7 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
 	    pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
 	    addErrL (mkTyAppMsg SLIT("Kinds not right in") ty arg_ty e) `seqL` returnL Nothing
 	
-lintCoreArg _ e ty (UsageArg u)
+lintCoreArg e ty (UsageArg u)
   = -- ToDo: Check that usage has no unbound usage variables
     case (getForAllUsageTy ty) of
       Just (uvar,bounds,body) ->
@@ -350,7 +362,7 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
 	  check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
 
 lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
-  = (case maybeAppDataTyCon scrut_ty of
+  = (case maybeAppDataTyConExpandingDicts scrut_ty of
       Nothing ->
 	 addErrL (mkAlgAltMsg1 scrut_ty)
       Just (tycon, tys_applied, cons) ->
@@ -360,7 +372,7 @@ lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
 	 checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
 								 `seqL`
-	 mapL check (arg_tys `zipEqual` args)			 `seqL`
+	 mapL check (zipEqual "lintAlgAlt" arg_tys args)	 `seqL`
 	 returnL ()
     )								 `seqL`
     addInScopeVars args 	(
@@ -575,7 +587,7 @@ mkDefltMsg deflt sty
 
 mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
 mkAppMsg fun arg expr sty
-  = ppAboves [ppStr "Argument values doesn't match argument type:",
+  = ppAboves [ppStr "Argument value doesn't match argument type:",
 	      ppHang (ppStr "Fun type:") 4 (ppr sty fun),
 	      ppHang (ppStr "Arg type:") 4 (ppr sty arg),
 	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
@@ -598,6 +610,7 @@ mkAlgAltMsg1 :: Type -> ErrMsg
 mkAlgAltMsg1 ty sty
   = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
 	    (ppr sty ty)
+--	    (ppAbove (ppr sty ty) (ppr sty (expandTy ty))) -- ToDo: rm
 
 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 mkAlgAltMsg2 ty con sty

ghc/compiler/coreSyn/CoreUnfold.lhs

@@ -47,7 +47,7 @@ import Literal		( isNoRepLit, isLitLitLit )
 import Pretty
 import PrimOp		( primOpCanTriggerGC, PrimOp(..) )
 import TyCon		( tyConFamilySize )
-import Type		( getAppDataTyCon )
+import Type		( getAppDataTyConExpandingDicts )
 import UniqSet		( emptyUniqSet, unitUniqSet, mkUniqSet,
 			  addOneToUniqSet, unionUniqSets
 			)
@@ -342,7 +342,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
 	size_alg_alt (con,args,rhs) = size_up rhs
 	    -- Don't charge for args, so that wrappers look cheap
 
-	(tycon, _, _) = _trace "getAppDataTyCon.CoreUnfold" $ getAppDataTyCon scrut_ty
+	(tycon, _, _) = _trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty
 
     size_up_alts _ (PrimAlts alts deflt)
       = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts

ghc/compiler/coreSyn/CoreUtils.lhs

@@ -671,7 +671,7 @@ do_CoreBinding venv tenv (Rec binds)