Commit 32836fa7 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-10-08 13:58:49 by simonpj]

------------------------------------------------------
	Fix an interaction between zonking of Insts and GADTs
	------------------------------------------------------

Insts float outwards, perhaps out of the scope of a type-refining GADT case.
So we have to make sure they are fully zonked wrt the type refinement.

tcSimplifyCheck does this, but there were two omissions
a) the tcInstStupidTheta in TcPat.tcConPat didn't get zonked
b) a Dict and Lit Inst contained an Id that wasn't zonked, to save work

To fix (b), Insts have a little less cached info; the Name is held instead
of the Id, so that the Id doesn't need to be zonked.

One test in typecheck/should_compile/tc182
parent 982f3f1b
......@@ -72,9 +72,10 @@ import Kind ( isSubKind )
import HscTypes ( ExternalPackageState(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import PrelInfo ( isStandardClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, isInternalName )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName,
isInternalName, setNameUnique, mkSystemNameEncoded )
import NameSet ( addOneToNameSet )
import Literal ( inIntRange )
import Var ( TyVar, tyVarKind )
......@@ -98,9 +99,9 @@ instName :: Inst -> Name
instName inst = idName (instToId inst)
instToId :: Inst -> TcId
instToId (Dict id _ _) = id
instToId (LitInst nm _ ty _) = mkLocalId nm ty
instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
instToId (Method id _ _ _ _ _) = id
instToId (LitInst id _ _ _) = id
instLoc (Dict _ _ loc) = loc
instLoc (Method _ _ _ _ _ loc) = loc
......@@ -222,8 +223,8 @@ newDicts orig theta
newDictsAtLoc loc theta
cloneDict :: Inst -> TcM Inst
cloneDict (Dict id ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setIdUnique id uniq) ty loc)
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc)
newDictsFromOld :: Inst -> TcThetaType -> TcM [Inst]
newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
......@@ -237,7 +238,7 @@ newDictsAtLoc inst_loc theta
= newUniqueSupply `thenM` \ us ->
returnM (zipWith mk_dict (uniqsFromSupply us) theta)
where
mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred))
mk_dict uniq pred = Dict (mkPredName uniq loc pred)
pred inst_loc
loc = instLocSrcLoc inst_loc
......@@ -253,9 +254,9 @@ newIPDict orig ip_name ty
let
pred = IParam ip_name ty
name = mkPredName uniq (instLocSrcLoc inst_loc) pred
id = mkLocalId name (mkPredTy pred)
dict = Dict name pred inst_loc
in
returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
returnM (mapIPName (\n -> instToId dict) ip_name, dict)
\end{code}
......@@ -397,8 +398,10 @@ newLitInst orig lit expected_ty
= getInstLoc orig `thenM` \ loc ->
newUnique `thenM` \ new_uniq ->
let
lit_inst = LitInst lit_id lit expected_ty loc
lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty
lit_nm = mkSystemNameEncoded new_uniq FSLIT("lit")
-- The "encoded" bit means that we don't need to z-encode
-- the string every time we call this!
lit_inst = LitInst lit_nm lit expected_ty loc
in
extendLIE lit_inst `thenM_`
returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst)))
......@@ -439,15 +442,13 @@ mkRatLit r
%* *
%************************************************************************
Zonking makes sure that the instance types are fully zonked,
but doesn't do the same for any of the Ids in an Inst. There's no
need, and it's a lot of extra work.
Zonking makes sure that the instance types are fully zonked.
\begin{code}
zonkInst :: Inst -> TcM Inst
zonkInst (Dict id pred loc)
zonkInst (Dict name pred loc)
= zonkTcPredType pred `thenM` \ new_pred ->
returnM (Dict id new_pred loc)
returnM (Dict name new_pred loc)
zonkInst (Method m id tys theta tau loc)
= zonkId id `thenM` \ new_id ->
......@@ -460,9 +461,9 @@ zonkInst (Method m id tys theta tau loc)
zonkTcType tau `thenM` \ new_tau ->
returnM (Method m new_id new_tys new_theta new_tau loc)
zonkInst (LitInst id lit ty loc)
zonkInst (LitInst nm lit ty loc)
= zonkTcType ty `thenM` \ new_ty ->
returnM (LitInst id lit new_ty loc)
returnM (LitInst nm lit new_ty loc)
zonkInsts insts = mappM zonkInst insts
\end{code}
......@@ -498,8 +499,8 @@ pprInsts insts = brackets (interpp'SP insts)
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
pprInst (LitInst id lit ty loc) = ppr id <+> dcolon <+> ppr ty
pprInst (Dict id pred loc) = ppr id <+> dcolon <+> pprPred pred
pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
pprInst m@(Method inst_id id tys theta tau loc)
= ppr inst_id <+> dcolon <+>
......@@ -519,8 +520,8 @@ pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon)
-- Print without the for-all, which the programmer doesn't write
tidyInst :: TidyEnv -> Inst -> Inst
tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
......@@ -647,7 +648,7 @@ lookupInst inst@(Method _ id tys theta _ loc)
-- may have done some unification by now]
lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
| Just expr <- shortCutIntLit i ty
= returnM (GenInst [] expr) -- GenInst, not SimpleInst, because
-- expr may be a constructor application
......@@ -660,7 +661,7 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
(mkHsApp (L (instLocSrcSpan loc)
(HsVar (instToId method_inst))) integer_lit))
lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
| Just expr <- shortCutFracLit f ty
= returnM (GenInst [] expr)
......
......@@ -522,9 +522,8 @@ zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for an unbound mutable variabl
-> Bool -- Consult the type refinement?
-> TcTyVar -> TcM TcType
zonkTyVar unbound_var_fn rflag tyvar
| not (isTcTyVar tyvar) -- This can happen when
-- zonking a forall type, when the bound type variable
-- needn't be mutable
| not (isTcTyVar tyvar) -- When zonking (forall a. ...a...), the occurrences of
-- the quantified variable a are TyVars not TcTyVars
= returnM (TyVarTy tyvar)
| otherwise
......
......@@ -385,15 +385,18 @@ tcConPat ctxt data_con tycon ty_args arg_pats thing_inside
arg_tys' = substTys tenv arg_tys
res_tys' = substTys tenv res_tys
; dicts <- newDicts (SigOrigin rigid_info) theta'
; tcInstStupidTheta data_con tv_tys'
-- Do type refinement!
; traceTc (text "tcGadtPat" <+> vcat [ppr data_con, ppr tvs', ppr arg_tys', ppr res_tys',
text "ty-args:" <+> ppr ty_args ])
; refineAlt ctxt data_con tvs' ty_args res_tys' $ do
{ ((arg_pats', inner_tvs, res), lie_req)
<- getLIE (tcConArgs ctxt data_con arg_pats arg_tys' thing_inside)
{ ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
do { tcInstStupidTheta data_con tv_tys'
-- The stupid-theta mentions the newly-bound tyvars, so
-- it must live inside the getLIE, so that the
-- tcSimplifyCheck will apply the type refinement to it
; tcConArgs ctxt data_con arg_pats arg_tys' thing_inside }
; dict_binds <- tcSimplifyCheck doc tvs' dicts lie_req
......
......@@ -633,7 +633,7 @@ type Int, represented by
\begin{code}
data Inst
= Dict
Id
Name
TcPredType
InstLoc
......@@ -668,7 +668,7 @@ data Inst
-- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
| LitInst
Id
Name
HsOverLit -- The literal from the occurrence site
-- INVARIANT: never a rebindable-syntax literal
-- Reason: tcSyntaxName does unification, and we
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment