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

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
parent 54121fff
......@@ -240,3 +240,5 @@ _darcs/
/extra-gcc-opts
.tm_properties
......@@ -622,7 +622,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
mi_orphan = not ( null orph_rules
&& null orph_insts
&& null orph_fis
&& 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 }
......
......@@ -745,9 +745,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
......@@ -765,6 +765,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) $
......@@ -779,13 +792,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
......@@ -796,14 +813,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
......
......@@ -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 :: [IfaceClsInst], -- ^ 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
......@@ -1566,6 +1566,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?
......@@ -2009,6 +2011,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)
......
......@@ -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
......
......@@ -682,7 +682,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'"
......
......@@ -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
......
......@@ -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.
--
......
......@@ -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
......
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