Commit 5cf27e8f authored by partain's avatar partain

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

SLPJ changes through 960515
parent 68afb167
This diff is collapsed.
......@@ -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'
......
......@@ -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]
......
......@@ -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}
%************************************************************************
......
......@@ -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}
......
......@@ -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)
......
......@@ -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`
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
%
% (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
......
......@@ -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
......
......@@ -671,7 +671,7 @@ do_CoreBinding venv tenv (Rec binds)
let new_venv = growIdEnvList venv new_maps in
mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
where
(binders, rhss) = unzip binds
\end{code}
......
......@@ -35,7 +35,7 @@ import Literal ( Literal{-instances-} )
import Name ( isSymLexeme )
import Outputable -- quite a few things
import PprEnv
import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
import PprStyle ( PprStyle(..) )
import Pretty
import PrimOp ( PrimOp{-instances-} )
......@@ -91,7 +91,7 @@ init_ppr_env sty pbdr1 pbdr2 pocc
(Just (ppr sty)) -- tyvars
(Just (ppr sty)) -- usage vars
(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
(Just (ppr sty)) -- types
(Just (pprParendGenType sty)) -- types
(Just (ppr sty)) -- usages
--------------
......
......@@ -547,7 +547,7 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
-- we can just use the rhs directly
else
-}
pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
mkSelectorBinds tyvars pat
[(binder, binder_subst binder) | binder <- pat_binders]
......
......@@ -26,7 +26,7 @@ import PrelInfo ( byteArrayPrimTy, getStatePairingConInfo,
stringTy )
import Pretty
import PrimOp ( PrimOp(..) )
import Type ( isPrimType, maybeAppDataTyCon, eqTy )
import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy )
import Util ( pprPanic, pprError, panic )
maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType"
......@@ -187,7 +187,7 @@ we decide what's happening with enumerations. ADR
maybe_boxed_prim_arg_ty = maybeBoxedPrimType arg_ty
(Just (box_data_con, the_prim_arg_ty)) = maybe_boxed_prim_arg_ty
maybe_data_type = maybeAppDataTyCon arg_ty
maybe_data_type = maybeAppDataTyConExpandingDicts arg_ty
is_data_type = maybeToBool maybe_data_type
(Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
......@@ -288,7 +288,7 @@ boxResult result_ty
= pprPanic "boxResult: " (ppr PprDebug result_ty)
where
maybe_data_type = maybeAppDataTyCon result_ty
maybe_data_type = maybeAppDataTyConExpandingDicts result_ty
Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
(the_data_con : other_data_cons) = data_cons
......
......@@ -49,14 +49,13 @@ import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
import TyCon ( isDataTyCon, isNewTyCon )
import Type ( splitSigmaTy, splitFunTy, typePrimRep,
getAppDataTyCon, getAppTyCon, applyTy
getAppDataTyConExpandingDicts, getAppTyCon, applyTy
)
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType"
splitTyArgs = panic "DsExpr.splitTyArgs"
mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility...
\end{code}
......@@ -221,10 +220,9 @@ dsExpr (SectionL expr op)
-- for the type of x, we need the type of op's 2nd argument
let
x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
case (splitTyArgs tau_ty) of {
case (splitFunTy tau_ty) of {
((_:arg2_ty:_), _) -> arg2_ty;
_ -> panic "dsExpr:SectionL:arg 2 ty"
}}
_ -> panic "dsExpr:SectionL:arg 2 ty" }}
in
newSysLocalDs x_ty `thenDs` \ x_id ->
returnDs (mkValLam [x_id] (core_op `App` y_atom `App` VarArg x_id))
......@@ -238,10 +236,9 @@ dsExpr (SectionR op expr)
-- for the type of x, we need the type of op's 1st argument
let
x_ty = case (splitSigmaTy (coreExprType core_op)) of { (_, _, tau_ty) ->
case (splitTyArgs tau_ty) of {
case (splitFunTy tau_ty) of {
((arg1_ty:_), _) -> arg1_ty;
_ -> panic "dsExpr:SectionR:arg 1 ty"
}}
_ -> panic "dsExpr:SectionR:arg 1 ty" }}
in
newSysLocalDs x_ty `thenDs` \ x_id ->
returnDs (mkValLam [x_id] (core_op `App` VarArg x_id `App` y_atom))
......@@ -386,7 +383,7 @@ dsExpr (RecordCon con_expr rbinds)
dsExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl)
in
mapDs mk_arg (arg_tys `zipEqual` dataConFieldLabels con_id) `thenDs` \ con_args ->