From 6af4a4b3d9fdae7c8b796f925711539edea4e1eb Mon Sep 17 00:00:00 2001
From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Sun, 15 Jan 2012 22:10:28 +1100
Subject: [PATCH] Fix vectorisation of classes
- Make sure that we have no implicit names in ifaces
- Any vectorisation info makes a module an orphan module
- Allow 'Show' in vectorised code without vectorising it for the moment
---
.gitignore | 2 +
compiler/iface/MkIface.lhs | 2 +-
compiler/iface/TcIface.lhs | 42 +++++++++++++++----
compiler/main/HscTypes.lhs | 12 ++++--
compiler/main/TidyPgm.lhs | 1 +
compiler/rename/RnSource.lhs | 2 +-
compiler/vectorise/Vectorise/Monad.hs | 6 +--
compiler/vectorise/Vectorise/Type/Classify.hs | 10 ++++-
compiler/vectorise/Vectorise/Type/Env.hs | 31 ++++++++++----
9 files changed, 84 insertions(+), 24 deletions(-)
diff --git a/.gitignore b/.gitignore
index 2bfec1656b46..b7fe39c8f90e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -237,3 +237,5 @@ _darcs/
/extra-gcc-opts
+
+.tm_properties
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 3edf1d64e5ed..ea7bb0f1508a 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -620,7 +620,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
mi_orphan_hash = orphan_hash,
mi_flag_hash = flag_hash,
mi_orphan = not (null orph_rules && null orph_insts
- && null (ifaceVectInfoVar (mi_vect_info iface0))),
+ && isNoIfaceVectInfo (mi_vect_info iface0)),
mi_finsts = not . null $ mi_fam_insts iface0,
mi_decls = sorted_decls,
mi_hash_fn = lookupOccEnv local_env }
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 8a279ca3a1e9..69c1e9599da1 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -733,9 +733,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
; vScalarVars <- mapM vectVar scalarVars
- ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
+ ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
- { vectInfoVar = mkVarEnv vVars
+ { vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoScalarVars = mkVarSet vScalarVars
@@ -753,6 +753,19 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
tcIfaceExtId vName
; return (var, (var, vVar))
}
+ -- where
+ -- lookupLocalOrExternalId name
+ -- = do { let mb_id = lookupTypeEnv typeEnv name
+ -- ; case mb_id of
+ -- -- id is local
+ -- Just (AnId id) -> return id
+ -- -- name is not an Id => internal inconsistency
+ -- Just _ -> notAnIdErr
+ -- -- Id is external
+ -- Nothing -> tcIfaceExtId name
+ -- }
+ --
+ -- notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
vectVar name
= forkM (ptext (sLit "vect scalar var") <+> ppr name) $
@@ -767,13 +780,17 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
= vectTyConMapping vars name name
vectTyConMapping vars name vName
- = do { tycon <- lookupLocalOrExternal name
- ; vTycon <- lookupLocalOrExternal vName
+ = do { tycon <- lookupLocalOrExternalTyCon name
+ ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $
+ lookupLocalOrExternalTyCon vName
- -- map the data constructors of the original type constructor to those of the
+ -- Map the data constructors of the original type constructor to those of the
-- vectorised type constructor /unless/ the type constructor was vectorised
-- abstractly; if it was vectorised abstractly, the workers of its data constructors
- -- do not appear in the set of vectorised variables
+ -- do not appear in the set of vectorised variables.
+ --
+ -- NB: This is lazy! We don't pull at the type constructors before we actually use
+ -- the data constructor mapping.
; let isAbstract | isClassTyCon tycon = False
| datacon:_ <- tyConDataCons tycon
= not $ dataConWrapId datacon `elemVarSet` vars
@@ -784,14 +801,25 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
(tyConDataCons vTycon)
]
+ -- Map the (implicit) superclass and methods selectors as they don't occur in
+ -- the var map.
+ vScSels | Just cls <- tyConClass_maybe tycon
+ , Just vCls <- tyConClass_maybe vTycon
+ = [ (sel, (sel, vSel))
+ | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
+ ]
+ | otherwise
+ = []
+
; return ( (name, (tycon, vTycon)) -- (T, T_v)
, vDataCons -- list of (Ci, Ci_v)
+ , vScSels -- list of (seli, seli_v)
)
}
where
-- we need a fully defined version of the type constructor to be able to extract
-- its data constructors etc.
- lookupLocalOrExternal name
+ lookupLocalOrExternalTyCon name
= do { let mb_tycon = lookupTypeEnv typeEnv name
; case mb_tycon of
-- tycon is local
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 6b389fd1b295..a9f3f694b276 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -92,7 +92,7 @@ module HscTypes (
-- * Vectorisation information
VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
- noIfaceVectInfo,
+ noIfaceVectInfo, isNoIfaceVectInfo,
-- * Safe Haskell information
hscGetSafeInf, hscSetSafeInf,
@@ -696,8 +696,8 @@ data ModIface
mi_insts :: [IfaceInst], -- ^ Sorted class instance
mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances
mi_rules :: [IfaceRule], -- ^ Sorted rules
- mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules and class
- -- and family instances combined
+ mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family
+ -- instances, and vectorise pragmas combined
mi_vect_info :: !IfaceVectInfo, -- ^ Vectorisation information
@@ -1543,6 +1543,8 @@ lookupFixity env n = case lookupNameEnv env n of
--
-- * A transformation rule in a module other than the one defining
-- the function in the head of the rule
+--
+-- * A vectorisation pragma
type WhetherHasOrphans = Bool
-- | Does this module define family instances?
@@ -1986,6 +1988,10 @@ concatVectInfo = foldr plusVectInfo noVectInfo
noIfaceVectInfo :: IfaceVectInfo
noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
+isNoIfaceVectInfo :: IfaceVectInfo -> Bool
+isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
+ = null l1 && null l2 && null l3 && null l4 && null l5
+
instance Outputable VectInfo where
ppr info = vcat
[ ptext (sLit "variables :") <+> ppr (vectInfoVar info)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 830a352be203..17e676ab2e12 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -513,6 +513,7 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
tidy_var_v = lookup_var var_v
, isExportedId tidy_var
, isExportedId tidy_var_v
+ , not $ isImplicitId var
]
tidy_scalarVars = mkVarSet [ lookup_var var
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index d79dcb868ebd..7440a3beab0d 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -674,7 +674,7 @@ rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn instTy)
= do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
- ; return (HsVectInstIn instTy', emptyFVs)
+ ; return (HsVectInstIn instTy', extractHsTyNames instTy')
}
rnHsVectDecl (HsVectInstOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index a6bf6d973f31..426682cea8ed 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -54,12 +54,12 @@ initV :: HscEnv
-> VM a
-> IO (Maybe (VectInfo, a))
initV hsc_env guts info thing_inside
- = do {
- let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
+ = do { dumpIfVtTrace "Incoming VectInfo" (ppr info)
+
+ ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
; (_, Just res) <- initDs hsc_env (mg_module guts)
(mg_rdr_env guts) type_env go
- ; dumpIfVtTrace "Incoming VectInfo" (ppr info)
; case res of
Nothing
-> dumpIfVtTrace "Vectorisation FAILED!" empty
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 7122cb76640a..ead7f14ea7f4 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -23,6 +23,7 @@ import DataCon
import TyCon
import TypeRep
import Type
+import PrelNames
import Digraph
@@ -54,14 +55,21 @@ classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs)
where
refs = ds `delListFromUniqSet` tcs
- can_convert = isNullUFM (refs `minusUFM` cs) && all convertable tcs
+ can_convert = (isNullUFM (refs `minusUFM` cs) && all convertable tcs)
+ || isShowClass tcs
must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
+ && (not . isShowClass $ tcs)
-- We currently admit Haskell 2011-style data and newtype declarations as well as type
-- constructors representing classes.
convertable tc
= (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc)
|| isClassTyCon tc
+
+ -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a
+ -- vectorised definition (to be able to vectorise 'Num')
+ isShowClass [tc] = tyConName tc == showClassName
+ isShowClass _ = False
-- Used to group type constructors into mutually dependent groups.
--
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 5d2213ac26e1..b15805110733 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -147,14 +147,6 @@ vectTypeEnv :: [TyCon] -- Type constructors defined in this mod
vectTypeEnv tycons vectTypeDecls vectClassDecls
= do { traceVt "** vectTypeEnv" $ ppr tycons
- -- Build a map containing all vectorised type constructor. If they are scalar, they are
- -- mapped to 'False' (vectorised type constructor == original type constructor).
- ; allScalarTyConNames <- globalScalarTyCons -- covers both current and imported modules
- ; vectTyCons <- globalVectTyCons
- ; let vectTyConBase = mapNameEnv (const True) vectTyCons -- by default fully vectorised
- vectTyConFlavour = foldNameSet (\n env -> extendNameEnv env n False) vectTyConBase
- allScalarTyConNames
-
; let -- {-# VECTORISE SCALAR type T -#} (imported and local tycons)
localAbstractTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls]
@@ -172,6 +164,23 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
localAbstractTyCons ++ map fst3 vectTyConsWithRHS
notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
+ -- Build a map containing all vectorised type constructor. If they are scalar, they are
+ -- mapped to 'False' (vectorised type constructor == original type constructor).
+ ; allScalarTyConNames <- globalScalarTyCons -- covers both current and imported modules
+ ; vectTyCons <- globalVectTyCons
+ ; let vectTyConBase = mapNameEnv (const True) vectTyCons -- by default fully vectorised
+ vectTyConFlavour = vectTyConBase
+ `plusNameEnv`
+ mkNameEnv [ (tyConName tycon, True)
+ | (tycon, _, _) <- vectTyConsWithRHS]
+ `plusNameEnv`
+ mkNameEnv [ (tcName, False) -- original representation
+ | tcName <- nameSetToList allScalarTyConNames]
+ `plusNameEnv`
+ mkNameEnv [ (tyConName tycon, False) -- original representation
+ | tycon <- localAbstractTyCons]
+
+
-- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)
-- that we could, but don't need to vectorise. Type constructors that are not data
-- type constructors or use non-Haskell98 features are being dropped. They may not
@@ -219,6 +228,12 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
-- Vectorise all the data type declarations that we can and must vectorise (enter the
-- type and data constructors into the vectorisation map on-the-fly.)
; new_tcs <- vectTyConDecls conv_tcs
+
+ ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$
+ ppr vTc <+> text "::" <+> ppr (dataConSig vTc))
+ dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc
+ | otherwise = panic "dataConSig"
+ ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs)
-- We don't need new representation types for dictionary constructors. The constructors
-- are always fully applied, and we don't need to lift them to arrays as a dictionary
--
GitLab