diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 2 | ||||
| -rw-r--r-- | compiler/iface/TcIface.lhs | 42 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 12 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 1 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 2 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad.hs | 6 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/Classify.hs | 10 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/Env.hs | 31 |
9 files changed, 84 insertions, 24 deletions
diff --git a/.gitignore b/.gitignore index 4897988477..e65a4c26ec 100644 --- a/.gitignore +++ b/.gitignore @@ -240,3 +240,5 @@ _darcs/ /extra-gcc-opts + +.tm_properties diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 86a512469a..6e29165975 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 } diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 5894607f28..6946752158 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -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 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index db81bc43f0..3224acf0fe 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 :: [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) diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 5e2a9375a0..3107b794b3 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 197f2b2554..c676a9bff1 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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'" diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index a6bf6d973f..426682cea8 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 7122cb7664..ead7f14ea7 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 a6f77bb9db..0051d072a4 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 |