Commit 686d8744 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Add data type information to VectInfo

parent 067d1b6c
......@@ -1222,10 +1222,14 @@ instance Binary IfaceRule where
return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
instance Binary IfaceVectInfo where
put_ bh (IfaceVectInfo a1) = do
put_ bh (IfaceVectInfo a1 a2 a3) = do
put_ bh a1
put_ bh a2
put_ bh a3
get bh = do
a1 <- get bh
return (IfaceVectInfo a1)
a2 <- get bh
a3 <- get bh
return (IfaceVectInfo a1 a2 a3)
......@@ -655,8 +655,15 @@ pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes
pprFix (occ,fix) = ppr fix <+> ppr occ
pprVectInfo :: IfaceVectInfo -> SDoc
pprVectInfo (IfaceVectInfo names) =
ptext SLIT("Closured converted:") <+> hsep (map ppr names)
pprVectInfo (IfaceVectInfo { ifaceVectInfoCCVar = vars
, ifaceVectInfoCCTyCon = tycons
, ifaceVectInfoCCTyConReuse = tyconsReuse
}) =
vcat
[ ptext SLIT("CC'ed variables:") <+> hsep (map ppr vars)
, ptext SLIT("CC'ed tycons:") <+> hsep (map ppr tycons)
, ptext SLIT("CC reused tycons:") <+> hsep (map ppr tyconsReuse)
]
pprDeprecs NoDeprecs = empty
pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt)
......
......@@ -339,8 +339,19 @@ mkIface hsc_env maybe_old_iface
deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
flattenVectInfo (VectInfo ccVar) =
IfaceVectInfo [Var.varName v | (v, _) <- varEnvElts ccVar]
flattenVectInfo (VectInfo { vectInfoCCVar = ccVar
, vectInfoCCTyCon = ccTyCon
}) =
IfaceVectInfo {
ifaceVectInfoCCVar = [ Var.varName v
| (v, _) <- varEnvElts ccVar],
ifaceVectInfoCCTyCon = [ tyConName t
| (t, t_CC) <- nameEnvElts ccTyCon
, t /= t_CC],
ifaceVectInfoCCTyConReuse = [ tyConName t
| (t, t_CC) <- nameEnvElts ccTyCon
, t == t_CC]
}
-----------------------------
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
......
......@@ -497,7 +497,7 @@ tcIfaceEqSpec spec
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
; ty <- tcIfaceType if_ty
; return (tv,ty) }
\end{code}
\end{code}
%************************************************************************
......@@ -590,24 +590,78 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
\begin{code}
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo names)
= do { ccVars <- mapM ccMapping names
; return $ VectInfo (mkVarEnv ccVars)
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
{ ifaceVectInfoCCVar = vars
, ifaceVectInfoCCTyCon = tycons
, ifaceVectInfoCCTyConReuse = tyconsReuse
})
= do { ccVars <- mapM ccVarMapping vars
; tyConRes1 <- mapM ccTyConMapping tycons
; tyConRes2 <- mapM ccTyConReuseMapping tycons
; let (ccTyCons, ccDataCons, ccIsos) = unzip3 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoCCVar = mkVarEnv ccVars
, vectInfoCCTyCon = mkNameEnv ccTyCons
, vectInfoCCDataCon = mkNameEnv (concat ccDataCons)
, vectInfoCCIso = mkNameEnv ccIsos
}
}
where
ccMapping name
ccVarMapping name
= do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name))
; let { var = lookup name
; ccVar = lookup ccName
; let { var = lookupVar name
; ccVar = lookupVar ccName
}
; return (var, (var, ccVar))
}
lookup name = case lookupTypeEnv typeEnv name of
Just (AnId var) -> var
Just _ ->
panic "TcIface.tcIfaceVectInfo: wrong TyThing"
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
ccTyConMapping name
= do { ccName <- lookupOrig mod (mkCloTyConOcc (nameOccName name))
; isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name))
; let { tycon = lookupTyCon name
; ccTycon = lookupTyCon ccName
; isoTycon = lookupVar isoName
}
; ccDataCons <- mapM ccDataConMapping (tyConDataCons tycon)
; return ((name, (tycon, ccTycon)), -- (T, T_CC)
ccDataCons, -- list of (Ci, Ci_CC)
(name, (tycon, isoTycon))) -- (T, isoT)
}
ccTyConReuseMapping name
= do { isoName <- lookupOrig mod (mkCloIsoOcc (nameOccName name))
; let { tycon = lookupTyCon name
; isoTycon = lookupVar isoName
; ccDataCons = [ (dataConName dc, (dc, dc))
| dc <- tyConDataCons tycon]
}
; return ((name, (tycon, tycon)), -- (T, T)
ccDataCons, -- list of (Ci, Ci)
(name, (tycon, isoTycon))) -- (T, isoT)
}
ccDataConMapping datacon
= do { let name = dataConName datacon
; ccName <- lookupOrig mod (mkCloDataConOcc (nameOccName name))
; let ccDataCon = lookupDataCon ccName
; return (name, (datacon, ccDataCon))
}
--
lookupVar name = case lookupTypeEnv typeEnv name of
Just (AnId var) -> var
Just _ ->
panic "TcIface.tcIfaceVectInfo: not an id"
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
lookupTyCon name = case lookupTypeEnv typeEnv name of
Just (ATyCon tc) -> tc
Just _ ->
panic "TcIface.tcIfaceVectInfo: not a tycon"
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
lookupDataCon name = case lookupTypeEnv typeEnv name of
Just (ADataCon dc) -> dc
Just _ ->
panic "TcIface.tcIfaceVectInfo: not a datacon"
Nothing ->
panic "TcIface.tcIfaceVectInfo: unknown name"
\end{code}
%************************************************************************
......
......@@ -1255,28 +1255,42 @@ on just the OccName easily in a Core pass.
-- ModGuts/ModDetails/EPS version
data VectInfo
= VectInfo {
vectInfoCCVar :: VarEnv (Var, Var) -- (f, f_CC) keyed on f
-- always tidy, even in ModGuts
vectInfoCCVar :: VarEnv (Var , Var ), -- (f, f_CC) keyed on f
vectInfoCCTyCon :: NameEnv (TyCon , TyCon), -- (T, T_CC) keyed on T
vectInfoCCDataCon :: NameEnv (DataCon, DataCon), -- (C, C_CC) keyed on C
vectInfoCCIso :: NameEnv (TyCon , Var) -- (T, isoT) keyed on T
}
-- all of this is always tidy, even in ModGuts
-- ModIface version
data IfaceVectInfo
= IfaceVectInfo {
ifaceVectInfoCCVar :: [Name] -- all variables in here have
-- a closure-converted variant
-- the name of the CC'ed variant
-- is determined by `mkCloOcc'
ifaceVectInfoCCVar :: [Name],
-- all variables in here have a closure-converted variant;
-- the name of the CC'ed variant is determined by `mkCloOcc'
ifaceVectInfoCCTyCon :: [Name],
-- all tycons in here have a closure-converted variant;
-- the name of the CC'ed variant and those of its data constructors are
-- determined by `mkCloTyConOcc' and `mkCloDataConOcc'; the names of
-- the isomorphisms is determined by `mkCloIsoOcc'
ifaceVectInfoCCTyConReuse :: [Name]
-- the closure-converted form of all the tycons in here coincids with
-- the unconverted from; the names of the isomorphisms is determined
-- by `mkCloIsoOcc'
}
noVectInfo :: VectInfo
noVectInfo = VectInfo emptyVarEnv
noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv
plusVectInfo :: VectInfo -> VectInfo -> VectInfo
plusVectInfo vi1 vi2 =
VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2)
VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2)
(vectInfoCCTyCon vi1 `plusNameEnv` vectInfoCCTyCon vi2)
(vectInfoCCDataCon vi1 `plusNameEnv` vectInfoCCDataCon vi2)
(vectInfoCCIso vi1 `plusNameEnv` vectInfoCCIso vi2)
noIfaceVectInfo :: IfaceVectInfo
noIfaceVectInfo = IfaceVectInfo []
noIfaceVectInfo = IfaceVectInfo [] [] []
\end{code}
%************************************************************************
......
Supports Markdown
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