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)
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)
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 ()
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar (occNameFS occ)
; ty <- tcIfaceType if_ty
; return (tv,ty) }
-\end{code}
+\end{code}
%************************************************************************
\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}
%************************************************************************
-- 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}
%************************************************************************
projects / ghc-hetmet.git / commitdiff