diff options
| author | David Waern <david.waern@gmail.com> | 2011-11-26 00:02:29 +0100 |
|---|---|---|
| committer | David Waern <david.waern@gmail.com> | 2011-11-26 00:02:29 +0100 |
| commit | fdf98d6255deba9582dd475e6953b1bb49fba660 (patch) | |
| tree | 839d39e5cdb3ec89868ed74705464b0674cd69b3 /compiler | |
| parent | ee2dad13f8a3cd484f25aa949895535d6eb0f15e (diff) | |
| parent | 381becf01a71654464a8c73ba8f4671337ebae9a (diff) | |
| download | haskell-fdf98d6255deba9582dd475e6953b1bb49fba660.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
Diffstat (limited to 'compiler')
44 files changed, 728 insertions, 877 deletions
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 2402a47e70..cbb3bd877f 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -333,7 +333,7 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet vectFreeVars (NoVect _) = noFVs vectFreeVars (VectType _ _ _) = noFVs vectFreeVars (VectClass _) = noFVs - vectFreeVars (VectInst _ _) = noFVs + vectFreeVars (VectInst _) = noFVs -- this function is only concerned with values, not types \end{code} diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 741c48eac9..09f00c70b2 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -754,7 +754,7 @@ substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst r substVect _subst vd@(NoVect _) = vd substVect _subst vd@(VectType _ _ _) = vd substVect _subst vd@(VectClass _) = vd -substVect _subst vd@(VectInst _ _) = vd +substVect _subst vd@(VectInst _) = vd ------------------ substVarSet :: Subst -> VarSet -> VarSet diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 3258d3da3a..78c733d830 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -538,7 +538,7 @@ data CoreVect = Vect Id (Maybe CoreExpr) | NoVect Id | VectType Bool TyCon (Maybe TyCon) | VectClass TyCon -- class tycon - | VectInst Bool Id -- (1) whether SCALAR & (2) instance dfun + | VectInst Id -- instance dfun (always SCALAR) \end{code} diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index c575b68857..9def8e8ca7 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -510,6 +510,5 @@ instance Outputable CoreVect where ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+> char '=' <+> ppr tc ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc - ppr (VectInst False var) = ptext (sLit "VECTORISE instance") <+> ppr var - ppr (VectInst True var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var + ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var \end{code} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index e88b57e835..d0713bcf99 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -23,6 +23,7 @@ import TcRnTypes import MkIface import Id import Name +import Type import InstEnv import Class import Avail @@ -415,15 +416,19 @@ dsVect (L loc (HsVect (L _ v) rhs)) dsVect (L _loc (HsNoVect (L _ v))) = return $ NoVect v dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) - = return $ VectType isScalar tycon rhs_tycon + = return $ VectType isScalar tycon' rhs_tycon + where + tycon' | Just ty <- coreView $ mkTyConTy tycon + , (tycon', []) <- splitTyConApp ty = tycon' + | otherwise = tycon dsVect vd@(L _ (HsVectTypeIn _ _ _)) = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd) dsVect (L _loc (HsVectClassOut cls)) = return $ VectClass (classTyCon cls) dsVect vc@(L _ (HsVectClassIn _)) = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc) -dsVect (L _loc (HsVectInstOut isScalar inst)) - = return $ VectInst isScalar (instanceDFunId inst) -dsVect vi@(L _ (HsVectInstIn _ _)) +dsVect (L _loc (HsVectInstOut inst)) + = return $ VectInst (instanceDFunId inst) +dsVect vi@(L _ (HsVectInstIn _)) = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi) \end{code} diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 46c93781f2..b6a5e3e507 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -512,17 +512,31 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; let spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf + id_inl = idInlinePragma poly_id + + -- See Note [Activation pragmas for SPECIALISE] inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl | not is_local_id -- See Note [Specialising imported functions] -- in OccurAnal , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma - | otherwise = idInlinePragma poly_id + | otherwise = id_inl -- Get the INLINE pragma from SPECIALISE declaration, or, -- failing that, from the original Id + spec_prag_act = inlinePragmaActivation spec_inl + + -- See Note [Activation pragmas for SPECIALISE] + -- no_act_spec is True if the user didn't write an explicit + -- phase specification in the SPECIALISE pragma + no_act_spec = case inlinePragmaSpec spec_inl of + NoInline -> isNeverActive spec_prag_act + _ -> isAlwaysActive spec_prag_act + rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit + | otherwise = spec_prag_act -- Specified by user + rule = mkRule False {- Not auto -} is_local_id (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) - AlwaysActive poly_name + rule_act poly_name final_bndrs args (mkVarApps (Var spec_id) bndrs) @@ -557,6 +571,48 @@ specUnfolding _ _ _ = return (noUnfolding, nilOL) \end{code} + +Note [Activation pragmas for SPECIALISE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From a user SPECIALISE pragma for f, we generate + a) A top-level binding spec_fn = rhs + b) A RULE f dOrd = spec_fn + +We need two pragma-like things: + +* spec_fn's inline pragma: inherited from f's inline pragma (ignoring + activation on SPEC), unless overriden by SPEC INLINE + +* Activation of RULE: from SPECIALISE pragma (if activation given) + otherwise from f's inline pragma + +This is not obvious (see Trac #5237)! + +Examples Rule activation Inline prag on spec'd fn +--------------------------------------------------------------------- +SPEC [n] f :: ty [n] Always, or NOINLINE [n] + copy f's prag + +NOINLINE f +SPEC [n] f :: ty [n] NOINLINE + copy f's prag + +NOINLINE [k] f +SPEC [n] f :: ty [n] NOINLINE [k] + copy f's prag + +INLINE [k] f +SPEC [n] f :: ty [n] INLINE [k] + copy f's prag + +SPEC INLINE [n] f :: ty [n] INLINE [n] + (ignore INLINE prag on f, + same activation for rule and spec'd fn) + +NOINLINE [k] f +SPEC f :: ty [n] INLINE [k] + + %************************************************************************ %* * \subsection{Adding inline pragmas} diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 9893a5e142..95cd45bd4e 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -129,12 +129,6 @@ endif @echo 'cGHC_SYSMAN_DIR = "$(GHC_SYSMAN_DIR)"' >> $@ @echo 'cDEFAULT_TMPDIR :: String' >> $@ @echo 'cDEFAULT_TMPDIR = "$(DEFAULT_TMPDIR)"' >> $@ - @echo 'cRelocatableBuild :: Bool' >> $@ -ifeq "$(RelocatableBuild)" "YES" - @echo 'cRelocatableBuild = True' >> $@ -else - @echo 'cRelocatableBuild = False' >> $@ -endif @echo 'cLibFFI :: Bool' >> $@ ifeq "$(UseLibFFIForAdjustors)" "YES" @echo 'cLibFFI = True' >> $@ diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 76d01dfc08..2dd1d11ea6 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -237,18 +237,21 @@ mkJumpToAddr a = undefined #endif - -byte0, byte1, byte2, byte3, byte4, byte5, byte6, byte7 - :: (Integral w, Bits w) => w -> Word8 +#if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) +byte0, byte1, byte2, byte3 :: (Integral w, Bits w) => w -> Word8 byte0 w = fromIntegral w byte1 w = fromIntegral (w `shiftR` 8) byte2 w = fromIntegral (w `shiftR` 16) byte3 w = fromIntegral (w `shiftR` 24) +#endif + +#if defined(x86_64_TARGET_ARCH) +byte4, byte5, byte6, byte7 :: (Integral w, Bits w) => w -> Word8 byte4 w = fromIntegral (w `shiftR` 32) byte5 w = fromIntegral (w `shiftR` 40) byte6 w = fromIntegral (w `shiftR` 48) byte7 w = fromIntegral (w `shiftR` 56) - +#endif #ifndef __HADDOCK__ -- entry point for direct returns for created constr itbls @@ -372,7 +375,7 @@ instance Storable StgInfoTable where return StgInfoTable { #ifndef GHCI_TABLES_NEXT_TO_CODE - entry = entry, + entry = entry', #endif ptrs = ptrs', nptrs = nptrs', diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index ea34e7991c..d4463632af 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -1093,11 +1093,9 @@ data VectDecl name (Located name) | HsVectClassOut -- post type-checking Class - | HsVectInstIn -- pre type-checking - Bool -- 'TRUE' => SCALAR declaration + | HsVectInstIn -- pre type-checking (always SCALAR) (LHsType name) - | HsVectInstOut -- post type-checking - Bool -- 'TRUE' => SCALAR declaration + | HsVectInstOut -- post type-checking (always SCALAR) Instance deriving (Data, Typeable) @@ -1108,15 +1106,13 @@ lvectDeclName (L _ (HsVectTypeIn _ (L _ name) _)) = getName name lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon lvectDeclName (L _ (HsVectClassIn (L _ name))) = getName name lvectDeclName (L _ (HsVectClassOut cls)) = getName cls -lvectDeclName (L _ (HsVectInstIn _ _)) = panic "HsDecls.lvectDeclName: HsVectInstIn" -lvectDeclName (L _ (HsVectInstOut _ _)) = panic "HsDecls.lvectDeclName: HsVectInstOut" --- lvectDeclName (L _ (HsVectInstIn _ (L _ name))) = getName name --- lvectDeclName (L _ (HsVectInstOut _ inst)) = getName inst +lvectDeclName (L _ (HsVectInstIn _)) = panic "HsDecls.lvectDeclName: HsVectInstIn" +lvectDeclName (L _ (HsVectInstOut _)) = panic "HsDecls.lvectDeclName: HsVectInstOut" lvectInstDecl :: LVectDecl name -> Bool -lvectInstDecl (L _ (HsVectInstIn _ _)) = True -lvectInstDecl (L _ (HsVectInstOut _ _)) = True -lvectInstDecl _ = False +lvectInstDecl (L _ (HsVectInstIn _)) = True +lvectInstDecl (L _ (HsVectInstOut _)) = True +lvectInstDecl _ = False instance OutputableBndr name => Outputable (VectDecl name) where ppr (HsVect v Nothing) @@ -1147,13 +1143,9 @@ instance OutputableBndr name => Outputable (VectDecl name) where = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] ppr (HsVectClassOut c) = sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ] - ppr (HsVectInstIn False ty) - = sep [text "{-# VECTORISE instance" <+> ppr ty <+> text "#-}" ] - ppr (HsVectInstIn True ty) + ppr (HsVectInstIn ty) = sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ] - ppr (HsVectInstOut False i) - = sep [text "{-# VECTORISE instance" <+> ppr i <+> text "#-}" ] - ppr (HsVectInstOut True i) + ppr (HsVectInstOut i) = sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ] \end{code} diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index f670437ffe..0ea1f3b0fc 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -14,7 +14,7 @@ import Name import Fingerprint -- import Outputable -import Data.List (sort) +import qualified Data.IntSet as IntSet import System.FilePath (normalise) -- | Produce a fingerprint of a @DynFlags@ value. We only base @@ -31,7 +31,7 @@ fingerprintDynFlags DynFlags{..} nameio = -- *all* the extension flags and the language lang = (fmap fromEnum language, - sort $ map fromEnum $ extensionFlags) + IntSet.toList $ extensionFlags) -- -I, -D and -U flags affect CPP cpp = (map normalise includePaths, sOpt_P settings) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3196614510..3edf1d64e5 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -102,6 +102,7 @@ import ListSetOps import Binary import Fingerprint import Bag +import Exception import Control.Monad import Data.List @@ -1324,10 +1325,19 @@ checkModUsage this_pkg UsageHomeModule{ else up_to_date (ptext (sLit " Great! The bits I use are up to date")) -checkModUsage _this_pkg UsageFile{ usg_file_path = file, usg_mtime = old_mtime } = do - new_mtime <- liftIO $ getModificationTime file - return $ old_mtime /= new_mtime - +checkModUsage _this_pkg UsageFile{ usg_file_path = file, + usg_mtime = old_mtime } = + liftIO $ + handleIO handle $ do + new_mtime <- getModificationTime file + return $ old_mtime /= new_mtime + where + handle = +#ifdef DEBUG + \e -> pprTrace "UsageFile" (text (show e)) $ return True +#else + \_ -> return True -- if we can't find the file, just recompile, don't fail +#endif ------------------------ checkModuleFingerprint :: Fingerprint -> Fingerprint -> IfG RecompileRequired diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index d17b90d7f3..8a279ca3a1 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -728,10 +728,11 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo , ifaceVectInfoScalarTyCons = scalarTyCons }) = do { let scalarTyConsSet = mkNameSet scalarTyCons - ; vVars <- mapM vectVarMapping vars - ; tyConRes1 <- mapM vectTyConMapping tycons - ; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse - ; vScalarVars <- mapM vectVar scalarVars + ; vVars <- mapM vectVarMapping vars + ; let varsSet = mkVarSet (map fst vVars) + ; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons + ; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse + ; vScalarVars <- mapM vectVar scalarVars ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2) ; return $ VectInfo { vectInfoVar = mkVarEnv vVars @@ -757,69 +758,51 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo = forkM (ptext (sLit "vect scalar var") <+> ppr name) $ tcIfaceExtId name - vectTyConMapping name + vectTyConVectMapping vars name = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name) + ; vectTyConMapping vars name vName + } + + vectTyConReuseMapping vars name + = vectTyConMapping vars name name + + vectTyConMapping vars name vName + = do { tycon <- lookupLocalOrExternal name + ; vTycon <- lookupLocalOrExternal vName + + -- 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 + ; let isAbstract | isClassTyCon tycon = False + | datacon:_ <- tyConDataCons tycon + = not $ dataConWrapId datacon `elemVarSet` vars + | otherwise = True + vDataCons | isAbstract = [] + | otherwise = [ (dataConName datacon, (datacon, vDatacon)) + | (datacon, vDatacon) <- zip (tyConDataCons tycon) + (tyConDataCons vTycon) + ] - -- we need a fully defined version of the type constructor to be able to extract - -- its data constructors etc. - ; tycon <- do { let mb_tycon = lookupTypeEnv typeEnv name - ; case mb_tycon of - -- tycon is local - Just (ATyCon tycon) -> return tycon - -- name is not a tycon => internal inconsistency - Just _ -> notATyConErr - -- tycon is external - Nothing -> tcIfaceTyCon (IfaceTc name) - } - ; vTycon <- forkM (text ("vect vTycon") <+> ppr vName) $ - tcIfaceTyCon (IfaceTc vName) - - -- we need to handle class type constructors differently due to the manner in which - -- the name for the dictionary data constructor is computed - ; vDataCons <- if isClassTyCon tycon - then vectClassDataConMapping vName (tyConSingleDataCon_maybe tycon) - else mapM vectDataConMapping (tyConDataCons tycon) ; return ( (name, (tycon, vTycon)) -- (T, T_v) , vDataCons -- list of (Ci, Ci_v) ) } where - notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name) - - vectTyConReuseMapping scalarNames name - = do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $ - tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok - ; if name `elemNameSet` scalarNames - then do - { return ( (name, (tycon, tycon)) -- scalar type constructors expose no data.. - , [] -- ..constructors see.. - ) -- .."Note [Pragmas to vectorise tycons]".. - -- ..in 'Vectorise.Type.Env' - } else do - { let { vDataCons = [ (dataConName dc, (dc, dc)) - | dc <- tyConDataCons tycon] - } - ; return ( (name, (tycon, tycon)) -- (T, T) - , vDataCons -- list of (Ci, Ci) - ) - }} - - vectClassDataConMapping _vTyconName Nothing = panic "tcIfaceVectInfo: vectClassDataConMapping" - vectClassDataConMapping vTyconName (Just datacon) - = do { let name = dataConName datacon - ; vName <- lookupOrig mod (mkClassDataConOcc . nameOccName $ vTyconName) - ; vDataCon <- forkM (text ("vect class datacon") <+> ppr name) $ - tcIfaceDataCon vName - ; return [(name, (datacon, vDataCon))] - } + -- we need a fully defined version of the type constructor to be able to extract + -- its data constructors etc. + lookupLocalOrExternal name + = do { let mb_tycon = lookupTypeEnv typeEnv name + ; case mb_tycon of + -- tycon is local + Just (ATyCon tycon) -> return tycon + -- name is not a tycon => internal inconsistency + Just _ -> notATyConErr + -- tycon is external + Nothing -> tcIfaceTyCon (IfaceTc name) + } - vectDataConMapping datacon - = do { let name = dataConName datacon - ; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name) - ; vDataCon <- forkM (text ("vect datacon") <+> ppr name) $ - tcIfaceDataCon vName - ; return (name, (datacon, vDataCon)) - } + notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name) \end{code} %************************************************************************ diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 9851ce1d75..2230f3fa40 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -745,9 +745,7 @@ runPhase (Unlit sf) input_fn dflags [ -- The -h option passes the file name for unlit to -- put in a #line directive SysTools.Option "-h" - -- cpp interprets \b etc as escape sequences, - -- so we use / for filenames in pragmas - , SysTools.Option $ reslash Forwards $ normalise input_fn + , SysTools.Option $ escape $ normalise input_fn , SysTools.FileOption "" input_fn , SysTools.FileOption "" output_fn ] @@ -755,6 +753,19 @@ runPhase (Unlit sf) input_fn dflags io $ SysTools.runUnlit dflags flags return (Cpp sf, output_fn) + where + -- escape the characters \, ", and ', but don't try to escape + -- Unicode or anything else (so we don't use Util.charToC + -- here). If we get this wrong, then in + -- Coverage.addTicksToBinds where we check that the filename in + -- a SrcLoc is the same as the source filenaame, the two will + -- look bogusly different. See test: + -- libraries/hpc/tests/function/subdir/tough2.lhs + escape ('\\':cs) = '\\':'\\': escape cs + escape ('\"':cs) = '\\':'\"': escape cs + escape ('\'':cs) = '\\':'\'': escape cs + escape (c:cs) = c : escape cs + escape [] = [] ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file @@ -1703,7 +1714,7 @@ linkBinary dflags o_files dep_packages = do let thread_opts | WayThreaded `elem` ways = [ -#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(haiku_TARGET_OS) +#if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(netbsd_TARGET_OS) && !defined(haiku_TARGET_OS) "-lpthread" #endif #if defined(osf3_TARGET_OS) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 4eb6dc9bcb..fce75b0bff 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -129,6 +129,9 @@ import qualified Data.Set as Set import System.FilePath import System.IO ( stderr, hPutChar ) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + -- ----------------------------------------------------------------------------- -- DynFlags @@ -304,7 +307,7 @@ data DynFlag | Opt_DistrustAllPackages | Opt_PackageTrust - deriving (Eq, Show) + deriving (Eq, Show, Enum) data WarningFlag = Opt_WarnDuplicateExports @@ -341,7 +344,7 @@ data WarningFlag = | Opt_WarnAlternativeLayoutRuleTransitional | Opt_WarnUnsafe | Opt_WarnSafe - deriving (Eq, Show) + deriving (Eq, Show, Enum) data Language = Haskell98 | Haskell2010 deriving Enum @@ -552,8 +555,8 @@ data DynFlags = DynFlags { generatedDumps :: IORef (Set FilePath), -- hsc dynamic flags - flags :: [DynFlag], - warningFlags :: [WarningFlag], + flags :: IntSet, + warningFlags :: IntSet, -- Don't change this without updating extensionFlags: language :: Maybe Language, -- | Safe Haskell mode @@ -569,7 +572,7 @@ data DynFlags = DynFlags { extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to -- flattenExtensionFlags language extensions - extensionFlags :: [ExtensionFlag], + extensionFlags :: IntSet, -- | Message output action: use "ErrUtils" instead of this if you can log_action :: LogAction, @@ -894,8 +897,8 @@ defaultDynFlags mySettings = dirsToClean = panic "defaultDynFlags: No dirsToClean", generatedDumps = panic "defaultDynFlags: No generatedDumps", haddockOptions = Nothing, - flags = defaultFlags, - warningFlags = standardWarnings, + flags = IntSet.fromList (map fromEnum defaultFlags), + warningFlags = IntSet.fromList (map fromEnum standardWarnings), language = Nothing, safeHaskell = Sf_SafeInfered, thOnLoc = noSrcSpan, @@ -938,12 +941,11 @@ data OnOff a = On a -- OnOffs accumulate in reverse order, so we use foldr in order to -- process them in the right order -flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] - -> [ExtensionFlag] +flattenExtensionFlags :: Maybe Language -> [OnOff ExtensionFlag] -> IntSet flattenExtensionFlags ml = foldr f defaultExtensionFlags - where f (On f) flags = f : delete f flags - f (Off f) flags = delete f flags - defaultExtensionFlags = languageExtensions ml + where f (On f) flags = IntSet.insert (fromEnum f) flags + f (Off f) flags = IntSet.delete (fromEnum f) flags + defaultExtensionFlags = IntSet.fromList (map fromEnum (languageExtensions ml)) languageExtensions :: Maybe Language -> [ExtensionFlag] @@ -985,31 +987,31 @@ languageExtensions (Just Haskell2010) -- | Test whether a 'DynFlag' is set dopt :: DynFlag -> DynFlags -> Bool -dopt f dflags = f `elem` (flags dflags) +dopt f dflags = fromEnum f `IntSet.member` flags dflags -- | Set a 'DynFlag' dopt_set :: DynFlags -> DynFlag -> DynFlags -dopt_set dfs f = dfs{ flags = f : flags dfs } +dopt_set dfs f = dfs{ flags = IntSet.insert (fromEnum f) (flags dfs) } -- | Unset a 'DynFlag' dopt_unset :: DynFlags -> DynFlag -> DynFlags -dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } +dopt_unset dfs f = dfs{ flags = IntSet.delete (fromEnum f) (flags dfs) } -- | Test whether a 'WarningFlag' is set wopt :: WarningFlag -> DynFlags -> Bool -wopt f dflags = f `elem` (warningFlags dflags) +wopt f dflags = fromEnum f `IntSet.member` warningFlags dflags -- | Set a 'WarningFlag' wopt_set :: DynFlags -> WarningFlag -> DynFlags -wopt_set dfs f = dfs{ warningFlags = f : warningFlags dfs } +wopt_set dfs f = dfs{ warningFlags = IntSet.insert (fromEnum f) (warningFlags dfs) } -- | Unset a 'WarningFlag' wopt_unset :: DynFlags -> WarningFlag -> DynFlags -wopt_unset dfs f = dfs{ warningFlags = filter (/= f) (warningFlags dfs) } +wopt_unset dfs f = dfs{ warningFlags = IntSet.delete (fromEnum f) (warningFlags dfs) } -- | Test whether a 'ExtensionFlag' is set xopt :: ExtensionFlag -> DynFlags -> Bool -xopt f dflags = f `elem` extensionFlags dflags +xopt f dflags = fromEnum f `IntSet.member` extensionFlags dflags -- | Set a 'ExtensionFlag' xopt_set :: DynFlags -> ExtensionFlag -> DynFlags @@ -1589,9 +1591,9 @@ dynamic_flags = [ , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) , Flag "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) - , Flag "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) + , Flag "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = IntSet.empty}) deprecate "Use -w instead")) - , Flag "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) + , Flag "w" (NoArg (upd (\dfs -> dfs {warningFlags = IntSet.empty}))) ------ Plugin flags ------------------------------------------------ , Flag "fplugin-opt" (hasArg addPluginModuleNameOption) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 2424ddc989..6b389fd1b2 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1948,6 +1948,9 @@ data VectInfo -- -- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as -- class selectors — i.e., their mappings are /not/ implicitly generated from the data types. +-- Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines +-- whether that data constructor was vectorised (or is part of an abstractly vectorised type +-- constructor). -- data IfaceVectInfo = IfaceVectInfo diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index dd00d3d6b3..e89d9b32a4 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -491,7 +491,7 @@ way_details = -- the problems are our fault or theirs, but it seems that using the -- alternative 1:1 threading library libthr works around it: "-optl-lthr" -#elif defined(openbsd_TARGET_OS) +#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) "-optc-pthread" , "-optl-pthread" #elif defined(solaris2_TARGET_OS) @@ -509,7 +509,7 @@ way_details = -- with -fPIC. Labels not in the current package are assumed to be in a DLL -- different from the current one. , "-fPIC" -#elif defined(openbsd_TARGET_OS) +#elif defined(openbsd_TARGET_OS) || defined(netbsd_TARGET_OS) -- Without this, linking the shared libHSffi fails because -- it uses pthread mutexes. , "-optl-pthread" diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 00311597d8..4a51b313e2 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -582,10 +582,22 @@ copyWithHeader dflags purpose maybe_header from to = do hout <- openBinaryFile to WriteMode hin <- openBinaryFile from ReadMode ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up - maybe (return ()) (hPutStr hout) maybe_header + maybe (return ()) (header hout) maybe_header hPutStr hout ls hClose hout hClose hin + where +#if __GLASGOW_HASKELL__ >= 702 + -- write the header string in UTF-8. The header is something like + -- {-# LINE "foo.hs" #-} + -- and we want to make sure a Unicode filename isn't mangled. + header h str = do + hSetEncoding h utf8 + hPutStr h str + hSetBinaryMode h True +#else + header h str = hPutStr h str +#endif -- | read the contents of the named section in an ELF object as a -- String. diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 607e05d66b..8c80ec40c1 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -853,6 +853,7 @@ genCCall target dest_regs argsAndHints OSMinGW32 -> panic "PPC.CodeGen.genCCall: not defined for this os" OSFreeBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" OSOpenBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSNetBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" OSUnknown -> panic "PPC.CodeGen.genCCall: not defined for this os" data GenCCallPlatform = GCPLinux | GCPDarwin diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 9f2083cf92..ea01070c94 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1126,7 +1126,19 @@ setLine code span buf len = do setFile :: Int -> Action setFile code span buf len = do - let file = lexemeToFastString (stepOn buf) (len-2) + let file = mkFastString (go (lexemeToString (stepOn buf) (len-2))) + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). setAlrLastLoc $ alrInitialLoc file setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) addSrcFile file diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 0701b9f7c9..de15f1cf2f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -589,11 +589,12 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}' { unitOL $ LL $ VectD (HsVectTypeIn False $3 (Just $5)) } + | '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}' + { unitOL $ LL $ + VectD (HsVectTypeIn True $3 (Just $5)) } | '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ LL $ VectD (HsVectClassIn $3) } - | '{-# VECTORISE' 'instance' type '#-}' - { unitOL $ LL $ VectD (HsVectInstIn False $3) } | '{-# VECTORISE_SCALAR' 'instance' type '#-}' - { unitOL $ LL $ VectD (HsVectInstIn True $3) } + { unitOL $ LL $ VectD (HsVectInstIn $3) } | annotation { unitOL $1 } | decl { unLoc $1 } @@ -1320,14 +1321,15 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } - | '{-# INLINE' activation qvar '#-}' + | '{-# INLINE' activation qvar '#-}' { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } - | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) - | t <- $4] } + | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' + { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2 + in LL $ toOL [ LL $ SigD (SpecSig $3 t inl_prag) + | t <- $5] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) - | t <- $5] } + | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 8ab71f3885..3b1a289fd2 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -885,7 +885,8 @@ mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } mkInlinePragma :: (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma --- The Maybe is because the user can omit the activation spec (and usually does) +-- The (Maybe Activation) is because the user can omit +-- the activation spec (and usually does) mkInlinePragma (inl, match_info) mb_act = InlinePragma { inl_inline = inl , inl_sat = Nothing diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 7d8d1d5a89..d79dcb868e 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -672,11 +672,11 @@ rnHsVectDecl (HsVectClassIn cls) } rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" -rnHsVectDecl (HsVectInstIn isScalar instTy) +rnHsVectDecl (HsVectInstIn instTy) = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy - ; return (HsVectInstIn isScalar instTy', emptyFVs) + ; return (HsVectInstIn instTy', emptyFVs) } -rnHsVectDecl (HsVectInstOut _ _) +rnHsVectDecl (HsVectInstOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'" \end{code} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index f12bad426d..072f77c2f2 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -694,7 +694,11 @@ tcVect (HsNoVect name) tcVect (HsVectTypeIn isScalar lname rhs_name) = addErrCtxt (vectCtxt lname) $ do { tycon <- tcLookupLocatedTyCon lname - ; checkTc (not isScalar || tyConArity tycon == 0) scalarTyConMustBeNullary + ; checkTc ( not isScalar -- either we have a non-SCALAR declaration + || isJust rhs_name -- or we explicitly provide a vectorised type + || tyConArity tycon == 0 -- otherwise the type constructor must be nullary + ) + scalarTyConMustBeNullary ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name ; return $ HsVectTypeOut isScalar tycon rhs_tycon @@ -708,13 +712,13 @@ tcVect (HsVectClassIn lname) } tcVect (HsVectClassOut _) = panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'" -tcVect (HsVectInstIn isScalar linstTy) +tcVect (HsVectInstIn linstTy) = addErrCtxt (vectCtxt linstTy) $ do { (cls, tys) <- tcHsVectInst linstTy ; inst <- tcLookupInstance cls tys - ; return $ HsVectInstOut isScalar inst + ; return $ HsVectInstOut inst } -tcVect (HsVectInstOut _ _) +tcVect (HsVectInstOut _) = panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'" vectCtxt :: Outputable thing => thing -> SDoc diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index d5e1f75b8d..09a5403508 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -579,48 +579,49 @@ flatten d fl (TyConApp tc tys) -- in which case the remaining arguments should -- be dealt with by AppTys fam_ty = mkTyConApp tc xi_args - ; (ret_co, rhs_var, ct) <- + ; (ret_co, rhs_xi, ct) <- do { is_cached <- getCachedFlatEq tc xi_args fl Any ; case is_cached of - Just (rhs_var,ret_eq) -> + Just (rhs_xi,ret_eq) -> do { traceTcS "is_cached!" $ ppr ret_eq - ; return (ret_eq, rhs_var, []) } + ; return (ret_eq, rhs_xi, []) } Nothing | isGivenOrSolved fl -> - do { rhs_var <- newFlattenSkolemTy fam_ty - ; eqv <- newGivenEqVar fl fam_ty rhs_var (mkReflCo fam_ty) + do { rhs_xi_var <- newFlattenSkolemTy fam_ty + ; eqv <- newGivenEqVar fl fam_ty rhs_xi_var (mkReflCo fam_ty) ; let ct = CFunEqCan { cc_id = eqv , cc_flavor = fl -- Given , cc_fun = tc , cc_tyargs = xi_args - , cc_rhs = rhs_var + , cc_rhs = rhs_xi_var , cc_depth = d } -- Update the flat cache: just an optimisation! - ; updateFlatCache eqv fl tc xi_args rhs_var WhileFlattening + ; updateFlatCache eqv fl tc xi_args rhs_xi_var WhileFlattening - ; return (mkEqVarLCo eqv, rhs_var, [ct]) } + ; return (mkEqVarLCo eqv, rhs_xi_var, [ct]) } | otherwise -> -- Derived or Wanted: make a new /unification/ flatten variable - do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) + do { rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) ; let wanted_flavor = mkWantedFlavor fl - ; evc <- newEqVar wanted_flavor fam_ty rhs_var + ; evc <- newEqVar wanted_flavor fam_ty rhs_xi_var ; let eqv = evc_the_evvar evc -- Not going to be cached ct = CFunEqCan { cc_id = eqv , cc_flavor = wanted_flavor -- Always Wanted, not Derived , cc_fun = tc , cc_tyargs = xi_args - , cc_rhs = rhs_var + , cc_rhs = rhs_xi_var , cc_depth = d } -- Update the flat cache: just an optimisation! - ; updateFlatCache eqv fl tc xi_args rhs_var WhileFlattening - ; return (mkEqVarLCo eqv, rhs_var, [ct]) } } + ; updateFlatCache eqv fl tc xi_args rhs_xi_var WhileFlattening + ; return (mkEqVarLCo eqv, rhs_xi_var, [ct]) } } -- Emit the flat constraints ; updWorkListTcS $ appendWorkListEqs ct ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos - ; return ( foldl AppTy rhs_var xi_rest + ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable + -- cf Trac #5655 , foldl AppCo (mkSymCo ret_co `mkTransCo` mkTyConAppCo tc cos_args) cos_rest) } diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 886b84d22e..5a4bf776fa 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -121,17 +121,29 @@ normaliseFfiType' env ty0 = go [] ty0 panic "normaliseFfiType': Got more GREs than expected" _ -> return False - if newtypeOK - then do let nt_co = mkAxInstCo (newTyConCo tc) tys - add_co nt_co rec_nts' nt_rhs - else children_only + when (not newtypeOK) $ + -- later: stop_here + addWarnTc (ptext (sLit "newtype") <+> quotes (ppr tc) <+> + ptext (sLit "is used in an FFI declaration,") $$ + ptext (sLit "but its constructor is not in scope.") $$ + ptext (sLit "This will become an error in GHC 7.6.1.")) + + let nt_co = mkAxInstCo (newTyConCo tc) tys + add_co nt_co rec_nts' nt_rhs + | isFamilyTyCon tc -- Expand open tycons , (co, ty) <- normaliseTcApp env tc tys , not (isReflCo co) = add_co co rec_nts ty + | otherwise - = children_only + = return (mkReflCo ty, ty) + -- If we have reached an ordinary (non-newtype) type constructor, + -- we are done. Note that we don't need to normalise the arguments, + -- because whether an FFI type is legal or not depends only on + -- the top-level type constructor (e.g. "Ptr a" is valid for all a). where + children_only = do xs <- mapM (go rec_nts) tys let (cos, tys') = unzip xs return (mkTyConAppCo tc cos, mkTyConApp tc tys') diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index d034a39b95..126575d45e 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -239,8 +239,8 @@ mkBindsRep tycon = `unionBags` unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) where - from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] + from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon @@ -267,7 +267,6 @@ tc_mkRepTyCon tycon metaDts mod = ; rep0Ty <- tc_mkRepTy tycon metaDts -- `rep_name` is a name we generate for the synonym --- ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR ; rep_name <- newGlobalBinder mod (mkGenR (nameOccName (tyConName tycon))) (nameSrcSpan (tyConName tycon)) ; let -- `tyvars` = [a,b] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index ce6b48c7fa..4f8cdb2a77 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1063,9 +1063,9 @@ zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn" zonkVect _env (HsVectClassOut c) = return $ HsVectClassOut c zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn" -zonkVect _env (HsVectInstOut s i) - = return $ HsVectInstOut s i -zonkVect _ (HsVectInstIn _ _) = panic "TcHsSyn.zonkVect: HsVectInstIn" +zonkVect _env (HsVectInstOut i) + = return $ HsVectInstOut i +zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn" \end{code} %************************************************************************ @@ -1206,9 +1206,7 @@ zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker -- Works on both types and kinds zonkTvCollecting unbound_tv_set tv = do { poly_kinds <- xoptM Opt_PolyKinds - ; if isKiVar tv && not poly_kinds then - do { defaultKindVarToStar tv - ; return liftedTypeKind } + ; if isKiVar tv && not poly_kinds then defaultKindVarToStar tv else do { tv' <- zonkQuantifiedTyVar tv ; tv_set <- readMutVar unbound_tv_set diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 425ad69390..b86321e82e 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -67,7 +67,7 @@ import NameSet import TysWiredIn import BasicTypes import SrcLoc -import DynFlags ( ExtensionFlag( Opt_ConstraintKinds, Opt_PolyKinds ) ) +import DynFlags ( ExtensionFlag( Opt_PolyKinds ) ) import Util import UniqSupply import Outputable @@ -375,31 +375,60 @@ kc_hs_type (HsKindSig ty sig_k) exp_kind = do return (HsKindSig ty' sig_k) -- See Note [Distinguishing tuple kinds] in HsTypes -kc_hs_type (HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) - = do { fact_tup_ok <- xoptM Opt_ConstraintKinds - ; let (k, tupleType) = if fact_tup_ok && isConstraintKind exp_k - then (constraintKind, HsConstraintTuple) - -- If it's not a constraint, then it has to be * - -- Unboxed tuples are a separate case - else (liftedTypeKind, HsBoxedTuple) - ; kc_hs_tuple_type tys tupleType k exp_kind } - -kc_hs_type (HsTupleTy HsBoxedTuple tys) exp_kind - = kc_hs_tuple_type tys HsBoxedTuple liftedTypeKind exp_kind - -kc_hs_type (HsTupleTy HsConstraintTuple tys) exp_kind - = kc_hs_tuple_type tys HsConstraintTuple constraintKind exp_kind - --- JPM merge with kc_hs_tuple_type ? -kc_hs_type ty@(HsTupleTy HsUnboxedTuple tys) exp_kind - = do { tys' <- kcArgs (ptext (sLit "an unboxed tuple")) tys argTypeKind - ; checkExpectedKindS ty ubxTupleKind exp_kind - ; return (HsTupleTy HsUnboxedTuple tys') } +kc_hs_type ty@(HsTupleTy HsBoxedOrConstraintTuple tys) exp_kind@(EK exp_k _ctxt) + | isConstraintOrLiftedKind exp_k -- (NB: not zonking, to avoid left-right bias) + = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys exp_k + ; return $ if isConstraintKind exp_k + then HsTupleTy HsConstraintTuple tys' + else HsTupleTy HsBoxedTuple tys' } + | otherwise + -- It is not clear from the context if it's * or Constraint, + -- so we infer the kind from the arguments + = do { k <- newMetaKindVar + ; tys' <- kcArgs (ptext (sLit "a tuple")) tys k + ; k' <- zonkTcKind k + ; if isConstraintKind k' + then do { checkExpectedKind ty k' exp_kind + ; return (HsTupleTy HsConstraintTuple tys') } + -- If it's not clear from the arguments that it's Constraint, then + -- it must be *. Check the arguments again to give good error messages + -- in eg. `(Maybe, Maybe)` + else do { tys'' <- kcArgs (ptext (sLit "a tuple")) tys liftedTypeKind + ; checkExpectedKind ty liftedTypeKind exp_kind + ; return (HsTupleTy HsBoxedTuple tys'') } } +{- +Note that we will still fail to infer the correct kind in this case: + + type T a = ((a,a), D a) + type family D :: Constraint -> Constraint + +While kind checking T, we do not yet know the kind of D, so we will default the +kind of T to * -> *. It works if we annotate `a` with kind `Constraint`. +-} + +kc_hs_type ty@(HsTupleTy tup_sort tys) exp_kind + = do { tys' <- kcArgs cxt_doc tys arg_kind + ; checkExpectedKind ty out_kind exp_kind + ; return (HsTupleTy tup_sort tys') } + where + arg_kind = case tup_sort of + HsBoxedTuple -> liftedTypeKind + HsUnboxedTuple -> argTypeKind + HsConstraintTuple -> constraintKind + _ -> panic "kc_hs_type arg_kind" + out_kind = case tup_sort of + HsUnboxedTuple -> ubxTupleKind + _ -> arg_kind + cxt_doc = case tup_sort of + HsBoxedTuple -> ptext (sLit "a tuple") + HsUnboxedTuple -> ptext (sLit "an unboxed tuple") + HsConstraintTuple -> ptext (sLit "a constraint tuple") + _ -> panic "kc_hs_type tup_sort" kc_hs_type ty@(HsFunTy ty1 ty2) exp_kind@(EK _ ctxt) = do ty1' <- kc_lhs_type ty1 (EK argTypeKind ctxt) ty2' <- kc_lhs_type ty2 (EK openTypeKind ctxt) - checkExpectedKindS ty liftedTypeKind exp_kind + checkExpectedKind ty liftedTypeKind exp_kind return (HsFunTy ty1' ty2') kc_hs_type ty@(HsOpTy ty1 (_, l_op@(L loc op)) ty2) exp_kind = do @@ -421,7 +450,7 @@ kc_hs_type ipTy@(HsIParamTy n ty) exp_kind = do ty' <- kc_lhs_type ty (EK liftedTypeKind (ptext (sLit "The type argument of the implicit parameter had"))) - checkExpectedKindS ipTy constraintKind exp_kind + checkExpectedKind ipTy constraintKind exp_kind return (HsIParamTy n ty') kc_hs_type ty@(HsEqTy ty1 ty2) exp_kind = do @@ -429,7 +458,7 @@ kc_hs_type ty@(HsEqTy ty1 ty2) exp_kind = do (ty2', kind2) <- kc_lhs_type_fresh ty2 checkExpectedKind ty2 kind2 (EK kind1 (ptext (sLit "The left argument of the equality predicate had"))) - checkExpectedKindS ty constraintKind exp_kind + checkExpectedKind ty constraintKind exp_kind return (HsEqTy ty1' ty2') kc_hs_type (HsCoreTy ty) exp_kind = do @@ -467,7 +496,7 @@ kc_hs_type ty@(HsRecTy _) _exp_kind #ifdef GHCI /* Only if bootstrapped */ kc_hs_type (HsSpliceTy sp fvs _) exp_kind = do (ty, k) <- kcSpliceType sp fvs - checkExpectedKindS ty k exp_kind + checkExpectedKind ty k exp_kind return ty #else kc_hs_type ty@(HsSpliceTy {}) _exp_kind = @@ -485,27 +514,19 @@ kc_hs_type (HsDocTy ty _) exp_kind kc_hs_type ty@(HsExplicitListTy _k tys) exp_kind = do { ty_k_s <- mapM kc_lhs_type_fresh tys ; kind <- unifyKinds (ptext (sLit "In a promoted list")) ty_k_s - ; checkExpectedKindS ty (mkListTy kind) exp_kind + ; checkExpectedKind ty (mkListTy kind) exp_kind ; return (HsExplicitListTy kind (map fst ty_k_s)) } kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do ty_k_s <- mapM kc_lhs_type_fresh tys let tupleKi = mkTyConApp (tupleTyCon BoxedTuple (length tys)) (map snd ty_k_s) - checkExpectedKindS ty tupleKi exp_kind + checkExpectedKind ty tupleKi exp_kind return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s)) kc_hs_type (HsWrapTy {}) _exp_kind = panic "kc_hs_type HsWrapTy" -- We kind checked something twice --------------------------- -kc_hs_tuple_type :: [LHsType Name] -> HsTupleSort -> Kind -> ExpKind - -> TcM (HsType Name) -kc_hs_tuple_type tys tuple_type kind exp_kind - = do { tys' <- kcArgs (ptext (sLit "a tuple")) tys kind - ; let hsTupleTy = HsTupleTy tuple_type tys' - ; checkExpectedKindS hsTupleTy kind exp_kind - ; return hsTupleTy } - kcApps :: Outputable a => a -> TcKind -- Function kind @@ -523,7 +544,7 @@ kcCheckApps :: Outputable a => a -> TcKind -> [LHsType Name] kcCheckApps the_fun fun_kind args ty exp_kind = do { (args_w_kinds, res_kind) <- splitFunKind (ppr the_fun) 1 fun_kind args ; args_w_kinds' <- kc_lhs_types args_w_kinds - ; checkExpectedKindS ty res_kind exp_kind + ; checkExpectedKind ty res_kind exp_kind ; return args_w_kinds' } @@ -1208,14 +1229,18 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do env0 <- tcInitTidyEnv let (exp_as, _) = splitKindFunTys exp_kind (act_as, _) = splitKindFunTys act_kind - n_exp_as = length exp_as - n_act_as = length act_as + n_exp_as = length exp_as + n_act_as = length act_as + n_diff_as = n_act_as - n_exp_as (env1, tidy_exp_kind) = tidyOpenKind env0 exp_kind (env2, tidy_act_kind) = tidyOpenKind env1 act_kind err | n_exp_as < n_act_as -- E.g. [Maybe] - = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments") + = ptext (sLit "Expecting") <+> + speakN n_diff_as <+> ptext (sLit "more argument") <> + (if n_diff_as > 1 then char 's' else empty) <+> + ptext (sLit "to") <+> quotes (ppr ty) -- Now n_exp_as >= n_act_as. In the next two cases, -- n_exp_as == 0, and hence so is n_act_as @@ -1223,7 +1248,7 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do = text "Predicate" <+> quotes (ppr ty) <+> text "used as a type" | isConstraintKind tidy_exp_kind - = text "Type of kind " <+> ppr tidy_act_kind <+> text "used as a constraint" + = text "Type of kind" <+> ppr tidy_act_kind <+> text "used as a constraint" | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty) @@ -1234,26 +1259,14 @@ checkExpectedKind ty act_kind ek@(EK exp_kind ek_ctxt) = do <+> ptext (sLit "is lifted") | otherwise -- E.g. Monad [Int] - = ptext (sLit "Kind mis-match") + = ptext (sLit "Kind mis-match") $$ more_info more_info = sep [ ek_ctxt <+> ptext (sLit "kind") <+> quotes (pprKind tidy_exp_kind) <> comma, ptext (sLit "but") <+> quotes (ppr ty) <+> ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)] - failWithTcM (env2, err $$ more_info) - --- We infer the kind of the type, and then complain if it's not right. --- But we don't want to complain about --- (ty) or !(ty) or forall a. ty --- when the real difficulty is with the 'ty' part. -checkExpectedKindS :: HsType Name -> TcKind -> ExpKind -> TcM () -checkExpectedKindS ty = checkExpectedKind (strip ty) - where - strip (HsParTy (L _ ty)) = strip ty - strip (HsBangTy _ (L _ ty)) = strip ty - strip (HsForAllTy _ _ _ (L _ ty)) = strip ty - strip ty = ty + failWithTcM (env2, err) \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 19bf384275..409dd722e7 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -576,11 +576,12 @@ zonkTcPredType = zonkTcType are used at the end of type checking \begin{code} -defaultKindVarToStar :: TcTyVar -> TcM () +defaultKindVarToStar :: TcTyVar -> TcM Kind -- We have a meta-kind: unify it with '*' defaultKindVarToStar kv - = ASSERT ( isKiVar kv && isMetaTyVar kv ) - writeMetaTyVar kv liftedTypeKind + = do { ASSERT ( isKiVar kv && isMetaTyVar kv ) + writeMetaTyVar kv liftedTypeKind + ; return liftedTypeKind } zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar] -- Precondition: a kind variable occurs before a type @@ -907,11 +908,12 @@ expectedKindInCtxt _ = Just argTypeKind checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that the type is valid for the given context checkValidType ctxt ty = do - traceTc "checkValidType" (ppr ty) - unboxed <- xoptM Opt_UnboxedTuples - rank2 <- xoptM Opt_Rank2Types - rankn <- xoptM Opt_RankNTypes - polycomp <- xoptM Opt_PolymorphicComponents + traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) + unboxed <- xoptM Opt_UnboxedTuples + rank2 <- xoptM Opt_Rank2Types + rankn <- xoptM Opt_RankNTypes + polycomp <- xoptM Opt_PolymorphicComponents + constraintKinds <- xoptM Opt_ConstraintKinds let gen_rank n | rankn = ArbitraryRank | rank2 = Rank 2 @@ -960,10 +962,12 @@ checkValidType ctxt ty = do -- Check that the thing has kind Type, and is lifted if necessary -- Do this second, because we can't usefully take the kind of an -- ill-formed type such as (a~Int) - traceTc "checkValidType kind_ok ctxt" (ppr kind_ok $$ pprUserTypeCtxt ctxt) checkTc kind_ok (kindErr actual_kind) - traceTc "checkValidType done" (ppr ty) + -- Check that the thing does not have kind Constraint, + -- if -XConstraintKinds isn't enabled + unless constraintKinds + $ checkTc (not (isConstraintKind actual_kind)) (predTupleErr ty) checkValidMonoType :: Type -> TcM () checkValidMonoType ty = check_mono_type MustBeMonoType ty diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index b19e2b3c06..fa467a7f27 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -35,7 +35,8 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, - isUbxTupleKind, isArgTypeKind, isConstraintKind, isKind, + isUbxTupleKind, isArgTypeKind, isConstraintKind, + isConstraintOrLiftedKind, isKind, isSuperKind, noHashInKind, isLiftedTypeKindCon, isConstraintKindCon, isAnyKind, isAnyKindCon, @@ -138,7 +139,7 @@ synTyConResKind tycon = kindAppResult (tyConKind tycon) (map mkTyVarTy (tyConTyV -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind, - isConstraintKind, isAnyKind :: Kind -> Bool + isConstraintKind, isAnyKind, isConstraintOrLiftedKind :: Kind -> Bool isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, isUnliftedTypeKindCon, isSubArgTypeKindCon, tcIsSubArgTypeKindCon, @@ -175,6 +176,9 @@ isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False +isConstraintOrLiftedKind (TyConApp tc _) + = isConstraintKindCon tc || isLiftedTypeKindCon tc +isConstraintOrLiftedKind _ = False -- Subkinding -- The tc variants are used during type-checking, where we don't want the @@ -288,8 +292,8 @@ defaultKind :: Kind -> Kind -- and the calling conventions differ. -- This defaulting is done in TcMType.zonkTcTyVarBndr. defaultKind k - | isSubOpenTypeKind k = liftedTypeKind - | otherwise = k + | tcIsSubOpenTypeKind k = liftedTypeKind + | otherwise = k splitKiTyVars :: [TyVar] -> ([KindVar], [TyVar]) -- Precondition: kind variables should precede type variables diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index e09d94e630..579ae754a6 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -824,14 +824,18 @@ Make PredTypes mkEqPred :: (Type, Type) -> PredType mkEqPred (ty1, ty2) -- IA0_TODO: The caller should give the kind. - = TyConApp eqTyCon [k, ty1, ty2] + = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) + TyConApp eqTyCon [k, ty1, ty2] where k = defaultKind (typeKind ty1) +-- where k = typeKind ty1 mkPrimEqType :: (Type, Type) -> Type mkPrimEqType (ty1, ty2) -- IA0_TODO: The caller should give the kind. - = TyConApp eqPrimTyCon [k, ty1, ty2] + = WARN ( not (k `eqKind` defaultKind k), ppr (k, ty1, ty2) ) + TyConApp eqPrimTyCon [k, ty1, ty2] where k = defaultKind (typeKind ty1) +-- where k = typeKind ty1 \end{code} --------------------- Implicit parameters --------------------------------- diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index e99d70600f..027c510546 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -55,6 +55,7 @@ data OS | OSMinGW32 | OSFreeBSD | OSOpenBSD + | OSNetBSD deriving (Read, Show, Eq) -- | ARM Instruction Set Architecture and Extensions @@ -90,6 +91,7 @@ osElfTarget :: OS -> Bool osElfTarget OSLinux = True osElfTarget OSFreeBSD = True osElfTarget OSOpenBSD = True +osElfTarget OSNetBSD = True osElfTarget OSSolaris2 = True osElfTarget OSDarwin = False osElfTarget OSMinGW32 = False diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index dc467f5187..cd87868081 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -87,8 +87,8 @@ vectModule guts@(ModGuts { mg_tcs = tycons -- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers -- NB: Need to vectorise the imported bindings first (local bindings may depend on them). - ; let impBinds = [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] ++ - [imp_id | VectInst True imp_id <- vect_decls, isGlobalId imp_id] + ; let impBinds = [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] ++ + [imp_id | VectInst imp_id <- vect_decls, isGlobalId imp_id] ; binds_imp <- mapM vectImpBind impBinds ; binds_top <- mapM vectTopBind binds @@ -150,7 +150,7 @@ vectTopBind b@(NonRec var expr) ; (inline, isScalar, expr') <- vectTopRhs [] var expr ; var' <- vectTopBinder var inline expr' ; when isScalar $ - addGlobalScalar var + addGlobalScalarVar var -- We replace the original top-level binding by a value projected from the vectorised -- closure and add any newly created hoisted top-level bindings. @@ -182,7 +182,7 @@ vectTopBind b@(Rec bs) ; if and areScalars then -- (1) Entire recursive group is scalar -- => add all variables to the global set of scalars - do { mapM_ addGlobalScalar vars + do { mapM_ addGlobalScalarVar vars ; return (vars', inlines, exprs', hs) } else -- (2) At least one binding is not scalar @@ -226,7 +226,7 @@ vectImpBind var ; (inline, isScalar, expr') <- vectTopRhs [] var (Var var) ; var' <- vectTopBinder var inline expr' ; when isScalar $ - addGlobalScalar var + addGlobalScalarVar var -- We add any newly created hoisted top-level bindings. ; hs <- takeHoisted @@ -340,7 +340,7 @@ vectTopRhs :: [Var] -- ^ Names of all functions in the rec block , CoreExpr) -- (3) the vectorised right-hand side vectTopRhs recFs var expr = closedV - $ do { globalScalar <- isGlobalScalar var + $ do { globalScalar <- isGlobalScalarVar var ; vectDecl <- lookupVectDecl var ; let isDFun = isDFunId var @@ -385,7 +385,7 @@ tryConvert :: Var -- ^ Name of the original binding (eg @foo@) -> CoreExpr -- ^ The original body of the binding. -> VM CoreExpr tryConvert var vect_var rhs - = do { globalScalar <- isGlobalScalar var + = do { globalScalar <- isGlobalScalarVar var ; if globalScalar then return rhs diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 56ae67f40b..e2fddefacd 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -199,7 +199,8 @@ initBuiltinVars (Builtins { }) -- |Get a list of names to `TyCon`s in the mock prelude. -- initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)] --- FIXME: must be replaced by VECTORISE pragmas!!! +-- FIXME: * must be replaced by VECTORISE pragmas!!! +-- * then we can remove 'parrayTyCon' from the Builtins as well initBuiltinTyCons bi = do return $ (tyConName funTyCon, closureTyCon bi) diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 64ab075cef..ffaf388b31 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -129,6 +129,10 @@ data GlobalEnv -- |Create an initial global environment. -- +-- We add scalar variables and type constructors identified by vectorisation pragmas already here +-- to the global table, so that we can query scalarness during vectorisation, and especially, when +-- vectorising the scalar entities' definitions themselves. +-- initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv initGlobalEnv info vectDecls instEnvs famInstEnvs = GlobalEnv @@ -151,10 +155,16 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs -- FIXME: we currently only allow RHSes consisting of a -- single variable to be able to obtain the type without -- inference — see also 'TcBinds.tcVect' - scalar_vars = [var | Vect var Nothing <- vectDecls] ++ - [var | VectInst True var <- vectDecls] - novects = [var | NoVect var <- vectDecls] - scalar_tycons = [tyConName tycon | VectType True tycon _ <- vectDecls] + scalar_vars = [var | Vect var Nothing <- vectDecls] ++ + [var | VectInst var <- vectDecls] + novects = [var | NoVect var <- vectDecls] + scalar_tycons = [tyConName tycon | VectType True tycon Nothing <- vectDecls] ++ + [tyConName tycon | VectType _ tycon (Just tycon') <- vectDecls + , tycon == tycon'] + -- - for 'VectType True tycon Nothing', we checked that the type does not + -- contain arrays (or type variables that could be instatiated to arrays) + -- - for 'VectType _ tycon (Just tycon')', where the two tycons are the same, + -- we also know that there can be no embedded arrays -- Operators on Global Environments ------------------------------------------- @@ -207,7 +217,7 @@ modVectInfo env mg_ids mg_tyCons vectDecls info } where vectIds = [id | Vect id _ <- vectDecls] ++ - [id | VectInst _ id <- vectDecls] + [id | VectInst id <- vectDecls] vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++ [tycon | VectClass tycon <- vectDecls] vectDataCons = concatMap tyConDataCons vectTypeTyCons diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 8afe149496..d695fcbf80 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -625,9 +625,8 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)] . vectBndrsIn bndrs $ vectExpr body let (vect_bndrs, lift_bndrs) = unzip vbndrs - (vscrut, lscrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr) + (vscrut, lscrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) vect_dc <- maybeV dataConErr (lookupDataCon dc) - let [pdata_dc] = tyConDataCons pdata_tc let vcase = mk_wild_case vscrut vty vect_dc vect_bndrs vect_body lcase = mk_wild_case lscrut lty pdata_dc lift_bndrs lift_body @@ -657,8 +656,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts vexpr <- vectExpr scrut - (vect_scrut, lift_scrut, pdata_tc, _arg_tys) <- mkVScrut (vVar vbndr) - let [pdata_dc] = tyConDataCons pdata_tc + (vect_scrut, lift_scrut, pdata_dc) <- pdataUnwrapScrut (vVar vbndr) let (vect_bodies, lift_bodies) = unzip vbodies diff --git a/compiler/vectorise/Vectorise/Generic/Description.hs b/compiler/vectorise/Vectorise/Generic/Description.hs index d0d4469023..eed01b0818 100644 --- a/compiler/vectorise/Vectorise/Generic/Description.hs +++ b/compiler/vectorise/Vectorise/Generic/Description.hs @@ -1,16 +1,20 @@ - --- | Compute a description of the generic representation that we use for --- a user defined data type. +-- |Compute a description of the generic representation that we use for a user defined data type. -- --- During vectorisation, we generate a PRepr and PA instance for each user defined --- data type. The PA dictionary contains methods to convert the user type to and --- from our generic representation. This module computes a description of what --- that generic representation is. +-- During vectorisation, we generate a PRepr and PA instance for each user defined +-- data type. The PA dictionary contains methods to convert the user type to and +-- from our generic representation. This module computes a description of what +-- that generic representation is. -- -module Vectorise.Generic.Description ( - CompRepr (..), ProdRepr (..), ConRepr (..), SumRepr (..), - tyConRepr, sumReprType, conReprType, prodReprType, compReprType, compOrigType -) where +module Vectorise.Generic.Description + ( CompRepr(..) + , ProdRepr(..) + , ConRepr(..) + , SumRepr(..) + , tyConRepr + , sumReprType + , compOrigType + ) +where import Vectorise.Utils import Vectorise.Monad @@ -108,8 +112,8 @@ data CompRepr ------------------------------------------------------------------------------- --- | Determine the generic representation of a data type, given its tycon. --- The `TyCon` contains a description of the whole data type. +-- |Determine the generic representation of a data type, given its tycon. +-- tyConRepr :: TyCon -> VM SumRepr tyConRepr tc = sum_repr (tyConDataCons tc) @@ -129,9 +133,8 @@ tyConRepr tc sum_tc <- builtin (sumTyCon arity) -- Get the 'PData' and 'PDatas' tycons for the sum. - let sumapp = mkTyConApp sum_tc tys - psum_tc <- liftM fst $ pdataReprTyCon sumapp - psums_tc <- liftM fst $ pdatasReprTyCon sumapp + psum_tc <- pdataReprTyConExact sum_tc + psums_tc <- pdatasReprTyConExact sum_tc sel_ty <- builtin (selTy arity) sels_ty <- builtin (selsTy arity) @@ -165,9 +168,8 @@ tyConRepr tc tup_tc <- builtin (prodTyCon arity) -- Get the 'PData' and 'PDatas' tycons for the product. - let prodapp = mkTyConApp tup_tc tys' - ptup_tc <- liftM fst $ pdataReprTyCon prodapp - ptups_tc <- liftM fst $ pdatasReprTyCon prodapp + ptup_tc <- pdataReprTyConExact tup_tc + ptups_tc <- pdatasReprTyConExact tup_tc return $ Prod { repr_tup_tc = tup_tc @@ -181,37 +183,35 @@ tyConRepr tc comp_repr ty = liftM (Keep ty) (prDictOfReprType ty) `orElseV` return (Wrap ty) - --- | Yield the type of this sum representation. +-- |Yield the type of this sum representation. +-- sumReprType :: SumRepr -> VM Type sumReprType EmptySum = voidType sumReprType (UnarySum r) = conReprType r sumReprType (Sum { repr_sum_tc = sum_tc, repr_con_tys = tys }) = return $ mkTyConApp sum_tc tys - --- | Yield the type of this constructor representation. +-- Yield the type of this constructor representation. +-- conReprType :: ConRepr -> VM Type conReprType (ConRepr _ r) = prodReprType r - --- | Yield the type of of this product representation. +-- Yield the type of of this product representation. +-- prodReprType :: ProdRepr -> VM Type prodReprType EmptyProd = voidType prodReprType (UnaryProd r) = compReprType r prodReprType (Prod { repr_tup_tc = tup_tc, repr_comp_tys = tys }) = return $ mkTyConApp tup_tc tys - --- | Yield the type of this data constructor field \/ component representation. +-- Yield the type of this data constructor field \/ component representation. +-- compReprType :: CompRepr -> VM Type compReprType (Keep ty _) = return ty -compReprType (Wrap ty) - = do wrap_tc <- builtin wrapTyCon - return $ mkTyConApp wrap_tc [ty] - +compReprType (Wrap ty) = mkWrapType ty --- Yield the original component type of a data constructor component representation. +-- |Yield the original component type of a data constructor component representation. +-- compOrigType :: CompRepr -> Type compOrigType (Keep ty _) = ty compOrigType (Wrap ty) = ty diff --git a/compiler/vectorise/Vectorise/Generic/PAMethods.hs b/compiler/vectorise/Vectorise/Generic/PAMethods.hs index c02dedad54..85e33367d7 100644 --- a/compiler/vectorise/Vectorise/Generic/PAMethods.hs +++ b/compiler/vectorise/Vectorise/Generic/PAMethods.hs @@ -164,13 +164,13 @@ buildToPRepr vect_tc repr_tc _ _ repr -- CoreExp to convert a data constructor component to the generic representation. to_comp :: CoreExpr -> CompRepr -> VM CoreExpr to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) - = do wrap_tc <- builtin wrapTyCon - return $ wrapNewTypeBody wrap_tc [ty] expr + to_comp expr (Wrap ty) = wrapNewTypeBodyOfWrap expr ty -- buildFromPRepr ------------------------------------------------------------- --- | Build the 'fromPRepr' method of the PA class. + +-- |Build the 'fromPRepr' method of the PA class. +-- buildFromPRepr :: PAInstanceBuilder buildFromPRepr vect_tc repr_tc _ _ repr = do @@ -217,14 +217,13 @@ buildFromPRepr vect_tc repr_tc _ _ repr [(DataAlt tup_con, vars, con `mkApps` es)] from_comp expr (Keep _ _) = return expr - from_comp expr (Wrap ty) - = do - wrap <- builtin wrapTyCon - return $ unwrapNewTypeBody wrap [ty] expr + from_comp expr (Wrap ty) = unwrapNewTypeBodyOfWrap expr ty -- buildToArrRepr ------------------------------------------------------------- --- | Build the 'toArrRepr' method of the PA class. + +-- |Build the 'toArrRepr' method of the PA class. +-- buildToArrPRepr :: PAInstanceBuilder buildToArrPRepr vect_tc prepr_tc pdata_tc _ r = do arg_ty <- mkPDataType el_ty @@ -283,17 +282,14 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc _ r to_con (ConRepr _ r) = to_prod r - -- FIXME: this is bound to be wrong! to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) - = do - wrap_tc <- builtin wrapTyCon - pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty]) - return $ wrapNewTypeBody pwrap_tc [ty] expr + to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDataWrap expr ty -- buildFromArrPRepr ---------------------------------------------------------- --- | Build the 'fromArrPRepr' method for the PA class. + +-- |Build the 'fromArrPRepr' method for the PA class. +-- buildFromArrPRepr :: PAInstanceBuilder buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r = do arg_ty <- mkPDataType =<< mkPReprType el_ty @@ -355,11 +351,9 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc _ r from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) - = do wrap_tc <- builtin wrapTyCon - pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty]) - return (res, [unwrapNewTypeBody pwrap_tc [ty] - $ unwrapFamInstScrut pwrap_tc [ty] expr]) + from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDataWrap expr ty + ; return (res, [expr']) + } fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) @@ -457,12 +451,8 @@ buildToArrPReprs vect_tc prepr_tc _ pdatas_tc r to_con xSums (ConRepr _ r) = to_prod xSums r - -- FIXME: this is bound to be wrong! to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) - = do wrap_tc <- builtin wrapTyCon - (pwrap_tc, _) <- pdatasReprTyCon (mkTyConApp wrap_tc [ty]) - return $ wrapNewTypeBody pwrap_tc [ty] expr + to_comp expr (Wrap ty) = wrapNewTypeBodyOfPDatasWrap expr ty -- buildFromArrPReprs --------------------------------------------------------- @@ -545,11 +535,9 @@ buildFromArrPReprs vect_tc prepr_tc _ pdatas_tc r = from_prod res_ty res expr r from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) - = do wrap_tc <- builtin wrapTyCon - (pwraps_tc, _) <- pdatasReprTyCon (mkTyConApp wrap_tc [ty]) - return (res, [unwrapNewTypeBody pwraps_tc [ty] - $ unwrapFamInstScrut pwraps_tc [ty] expr]) + from_comp _ res expr (Wrap ty) = do { expr' <- unwrapNewTypeBodyOfPDatasWrap expr ty + ; return (res, [expr']) + } fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index b9a1fdf046..0706e25f4f 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -14,7 +14,8 @@ module Vectorise.Monad ( -- * Variables lookupVar, lookupVar_maybe, - addGlobalScalar, + addGlobalScalarVar, + addGlobalScalarTyCon, ) where import Vectorise.Monad.Base @@ -32,6 +33,8 @@ import DynFlags import MonadUtils (liftIO) import InstEnv import Class +import TyCon +import NameSet import VarSet import VarEnv import Var @@ -174,8 +177,17 @@ dumpVar var -- |Mark the given variable as scalar — i.e., executing the associated code does not involve any -- parallel array computations. -- -addGlobalScalar :: Var -> VM () -addGlobalScalar var - = do { traceVt "addGlobalScalar" (ppr var) +addGlobalScalarVar :: Var -> VM () +addGlobalScalarVar var + = do { traceVt "addGlobalScalarVar" (ppr var) ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var} } + +-- |Mark the given type constructor as scalar — i.e., its values cannot embed parallel arrays. +-- +addGlobalScalarTyCon :: TyCon -> VM () +addGlobalScalarTyCon tycon + = do { traceVt "addGlobalScalarTyCon" (ppr tycon) + ; updGEnv $ \env -> + env{global_scalar_tycons = addOneToNameSet (global_scalar_tycons env) (tyConName tycon)} + } diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index bc68a5012f..f393f01e92 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -12,7 +12,7 @@ module Vectorise.Monad.Global ( lookupVectDecl, noVectDecl, -- * Scalars - globalScalarVars, isGlobalScalar, globalScalarTyCons, + globalScalarVars, isGlobalScalarVar, globalScalarTyCons, -- * TyCons lookupTyCon, @@ -96,8 +96,8 @@ globalScalarVars = readGEnv global_scalar_vars -- |Check whether a given variable is in the set of global scalar variables. -- -isGlobalScalar :: Var -> VM Bool -isGlobalScalar var = readGEnv $ \env -> var `elemVarSet` global_scalar_vars env +isGlobalScalarVar :: Var -> VM Bool +isGlobalScalarVar var = readGEnv $ \env -> var `elemVarSet` global_scalar_vars env -- |Get the set of global scalar type constructors including both those scalar type constructors -- declared in an imported module and those declared in the current module. diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 1b806c3138..5d2213ac26 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -32,14 +32,18 @@ import Id import MkId import NameEnv import NameSet +import OccName import Util import Outputable import FastString import MonadUtils + import Control.Monad +import Data.Maybe import Data.List + -- Note [Pragmas to vectorise tycons] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -60,7 +64,20 @@ import Data.List -- Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner. -- (The vectoriser never treats a type constructor automatically in this manner.) -- --- (2) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised +-- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an +-- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code. +-- +-- An example is the treatment of '[::]'. '[::]'s can be used in vectorised code and is +-- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised +-- code. Instead, computations involving the representation need to be confined to scalar code. +-- +-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated +-- by the vectoriser). +-- +-- Type constructors declared with {-# VECTORISE SCALAR type T = T' #-} are treated in this +-- manner. (The vectoriser never treats a type constructor automatically in this manner.) +-- +-- (3) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised -- code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types -- declared in a vectorised module. This includes the case where the vectoriser determines that -- the original representation of 'T' may be used in vectorised code (as it does not embed any @@ -74,13 +91,13 @@ import Data.List -- -- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner. -- --- (3) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised +-- (4) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised -- code, where 'T' is represented by an explicitly given 'Tv' whose constructors 'Cvn' represent -- the original constructors in vectorised code. As a special case, we can have 'Tv = T' -- -- An example is the treatment of 'Bool', which is represented by itself in vectorised code -- (as it cannot embed any parallel arrays). However, we do not want any automatic generation --- of class and family instances, which is why Case (2) does not apply. +-- of class and family instances, which is why Case (3) does not apply. -- -- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated -- by the vectoriser). @@ -139,64 +156,65 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls allScalarTyConNames ; let -- {-# VECTORISE SCALAR type T -#} (imported and local tycons) - localScalarTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls] + localAbstractTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls] -- {-# VECTORISE type T -#} (ONLY the imported tycons) impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls] ++ [tycon | VectClass tycon <- vectClassDecls]) \\ tycons - -- {-# VECTORISE type T = ty -#} (imported and local tycons) - vectTyConsWithRHS = [ (tycon, rhs) - | VectType False tycon (Just rhs) <- vectTypeDecls] + -- {-# VECTORISE [SCALAR] type T = T' -#} (imported and local tycons) + vectTyConsWithRHS = [ (tycon, rhs, isAbstract) + | VectType isAbstract tycon (Just rhs) <- vectTypeDecls] -- filter VECTORISE SCALAR tycons and VECTORISE tycons with explicit rhses vectSpecialTyConNames = mkNameSet . map tyConName $ - localScalarTyCons ++ map fst vectTyConsWithRHS - notLocalScalarTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames + localAbstractTyCons ++ map fst3 vectTyConsWithRHS + notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames -- 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 -- appear in vectorised code. (We also drop the local type constructors appearing in a -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as - -- these are being handled separately.) + -- these are being handled separately. NB: Some type constructors may be marked SCALAR + -- /and/ have an explicit right-hand side.) + -- -- Furthermore, 'drop_tcs' are those type constructors that we cannot vectorise. - ; let maybeVectoriseTyCons = filter notLocalScalarTyCon tycons ++ impVectTyCons + ; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons (conv_tcs, keep_tcs, drop_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons - ; traceVt " VECT SCALAR : " $ ppr localScalarTyCons + ; traceVt " VECT SCALAR : " $ ppr localAbstractTyCons ; traceVt " VECT [class] : " $ ppr impVectTyCons - ; traceVt " VECT with rhs : " $ ppr (map fst vectTyConsWithRHS) + ; traceVt " VECT with rhs : " $ ppr (map fst3 vectTyConsWithRHS) ; traceVt " -- after classification (local and VECT [class] tycons) --" empty ; traceVt " reuse : " $ ppr keep_tcs ; traceVt " convert : " $ ppr conv_tcs -- warn the user about unvectorised type constructors - ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ - ptext (sLit "or depend on type constructors that are not vectorised)") - ; unless (null drop_tcs) $ + ; let explanation = ptext (sLit "(They use unsupported language extensions") $$ + ptext (sLit "or depend on type constructors that are not vectorised)") + drop_tcs_nosyn = filter (not . isSynTyCon) drop_tcs + ; unless (null drop_tcs_nosyn) $ emitVt "Warning: cannot vectorise these type constructors:" $ - pprQuotedList drop_tcs $$ explanation - - ; let defTyConDataCons origTyCon vectTyCon - = do { defTyCon origTyCon vectTyCon - ; MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon)) - ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) - } - - -- For the type constructors that we don't need to vectorise, we use the original - -- representation in both unvectorised and vectorised code. - ; zipWithM_ defTyConDataCons keep_tcs keep_tcs - - -- We do the same for type constructors declared VECTORISE SCALAR, while ignoring their - -- representation (data constructors) — see "Note [Pragmas to vectorise tycons]". - ; zipWithM_ defTyCon localScalarTyCons localScalarTyCons - - -- For type constructors declared VECTORISE with an explicit vectorised type, we use the - -- explicitly given type in vectorised code and map data constructors one for one — see - -- "Note [Pragmas to vectorise tycons]". - ; mapM_ (uncurry defTyConDataCons) vectTyConsWithRHS + pprQuotedList drop_tcs_nosyn $$ explanation + + ; mapM_ addGlobalScalarTyCon keep_tcs + + ; let mapping = + -- Type constructors that we don't need to vectorise, use the same + -- representation in both unvectorised and vectorised code; they are not + -- abstract. + [(tycon, tycon, False) | tycon <- keep_tcs] + -- We do the same for type constructors declared VECTORISE SCALAR /without/ + -- an explicit right-hand side, but ignore their representation (data + -- constructors) as they are abstract. + ++ [(tycon, tycon, True) | tycon <- localAbstractTyCons] + -- Type constructors declared VECTORISE /with/ an explicit vectorised type, + -- we map from the original to the given type; whether they are abstract depends + -- on whether the vectorisation declaration was SCALAR. + ++ vectTyConsWithRHS + ; syn_tcs <- catMaybes <$> mapM defTyConDataCons mapping -- 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.) @@ -226,22 +244,20 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ; (_, binds) <- fixV $ \ ~(dfuns, _) -> do { defTyConPAs (zipLazy vect_tcs dfuns) - -- query the 'PData' instance type constructors for type constructors that have a - -- VECTORISE pragma with an explicit right-hand side (this is Item (3) of - -- "Note [Pragmas to vectorise tycons]" above) - ; pdata_withRHS_tcs <- mapM pdataReprTyConExact - [ mkTyConApp tycon tys - | (tycon, _) <- vectTyConsWithRHS - , let tys = mkTyVarTys (tyConTyVars tycon) - ] + -- Query the 'PData' instance type constructors for type constructors that have a + -- VECTORISE pragma with an explicit right-hand side (this is Item (4) of + -- "Note [Pragmas to vectorise tycons]" above). + ; let (withRHS_non_abstract, vwithRHS_non_abstract) + = unzip [(tycon, vtycon) | (tycon, vtycon, False) <- vectTyConsWithRHS] + ; pdata_withRHS_tcs <- mapM pdataReprTyConExact withRHS_non_abstract - -- build workers for all vectorised data constructors (except scalar ones) + -- Build workers for all vectorised data constructors (except abstract ones) ; sequence_ $ - zipWith3 vectDataConWorkers (orig_tcs ++ map fst vectTyConsWithRHS) - (vect_tcs ++ map snd vectTyConsWithRHS) + zipWith3 vectDataConWorkers (orig_tcs ++ withRHS_non_abstract) + (vect_tcs ++ vwithRHS_non_abstract) (pdata_tcs ++ pdata_withRHS_tcs) - -- build a 'PA' dictionary for all type constructors (except scalar ones and those + -- Build a 'PA' dictionary for all type constructors (except abstract ones & those -- defined with an explicit right-hand side where the dictionary is user-supplied) ; dfuns <- sequence $ zipWith4 buildTyConPADict @@ -256,8 +272,49 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls -- Return the vectorised variants of type constructors as well as the generated instance -- type constructors, family instances, and dfun bindings. - ; return (new_tcs ++ inst_tcs, fam_insts, binds) + ; return (new_tcs ++ inst_tcs ++ syn_tcs, fam_insts, binds) } + where + fst3 (a, _, _) = a + + -- Add a mapping from the original to vectorised type constructor to the vectorisation map. + -- Unless the type constructor is abstract, also mappings from the orignal's data constructors + -- to the vectorised type's data constructors. + -- + -- We have three cases: (1) original and vectorised type constructor are the same, (2) the + -- name of the vectorised type constructor is canonical (as prescribed by 'mkVectTyConOcc'), or + -- (3) the name is not canonical. In the third case, we additionally introduce a type synonym + -- with the canonical name that is set equal to the non-canonical name (so that we find the + -- right type constructor when reading vectorisation information from interface files). + -- + defTyConDataCons (origTyCon, vectTyCon, isAbstract) + = do { canonName <- mkLocalisedName mkVectTyConOcc origName + ; if origName == vectName -- Case (1) + || vectName == canonName -- Case (2) + then do + { defTyCon origTyCon vectTyCon -- T --> vT + ; defDataCons -- Ci --> vCi + ; return Nothing + } + else do -- Case (3) + { let synTyCon = mkSyn canonName (mkTyConTy vectTyCon) -- type S = vT + ; defTyCon origTyCon synTyCon -- T --> S + ; defDataCons -- Ci --> vCi + ; return $ Just synTyCon + } + } + where + origName = tyConName origTyCon + vectName = tyConName vectTyCon + + mkSyn canonName ty = mkSynTyCon canonName (typeKind ty) [] (SynonymTyCon ty) NoParentTyCon + + defDataCons + | isAbstract = return () + | otherwise + = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon)) + ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon) + } -- Helpers -------------------------------------------------------------------- diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs deleted file mode 100644 index 6e427ccec4..0000000000 --- a/compiler/vectorise/Vectorise/Type/PRepr.hs +++ /dev/null @@ -1,369 +0,0 @@ - -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Vectorise.Type.PRepr - ( buildPReprTyCon - , buildPAScAndMethods - ) where - -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Type.Repr -import CoreSyn -import CoreUtils -import MkCore ( mkWildCase ) -import TyCon -import Type -import BuildTyCl -import OccName -import Coercion -import MkId - -import FastString -import MonadUtils -import Control.Monad - - -mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) -mk_fam_inst fam_tc arg_tc - = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) - - -buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon -buildPReprTyCon orig_tc vect_tc repr - = do - name <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc) - -- rhs_ty <- buildPReprType vect_tc - rhs_ty <- sumReprType repr - prepr_tc <- builtin preprTyCon - liftDs $ buildSynTyCon name - tyvars - (SynonymTyCon rhs_ty) - (typeKind rhs_ty) - NoParentTyCon - (Just $ mk_fam_inst prepr_tc vect_tc) - where - tyvars = tyConTyVars vect_tc - - ------------------------------------------------------ -buildPAScAndMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)] --- buildPAScandmethods says how to build the PR superclass and methods of PA --- class class PR (PRepr a) => PA a where --- toPRepr :: a -> PRepr a --- fromPRepr :: PRepr a -> a --- toArrPRepr :: PData a -> PData (PRepr a) --- fromArrPRepr :: PData (PRepr a) -> PData a - -buildPAScAndMethods = [("PR", buildPRDict), - ("toPRepr", buildToPRepr), - ("fromPRepr", buildFromPRepr), - ("toArrPRepr", buildToArrPRepr), - ("fromArrPRepr", buildFromArrPRepr)] - -buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr -buildPRDict vect_tc prepr_tc _ _ - = prDictOfPReprInstTyCon inst_ty prepr_tc arg_tys - where - arg_tys = mkTyVarTys (tyConTyVars vect_tc) - inst_ty = mkTyConApp vect_tc arg_tys - -buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr -buildToPRepr vect_tc repr_tc _ repr - = do - let arg_ty = mkTyConApp vect_tc ty_args - res_ty <- mkPReprType arg_ty - arg <- newLocalVar (fsLit "x") arg_ty - result <- to_sum (Var arg) arg_ty res_ty repr - return $ Lam arg result - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - - wrap_repr_inst = wrapFamInstBody repr_tc ty_args - - to_sum _ _ _ EmptySum - = do - void <- builtin voidVar - return $ wrap_repr_inst $ Var void - - to_sum arg arg_ty res_ty (UnarySum r) - = do - (pat, vars, body) <- con_alt r - return $ mkWildCase arg arg_ty res_ty - [(pat, vars, wrap_repr_inst body)] - - to_sum arg arg_ty res_ty (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons }) - = do - alts <- mapM con_alt cons - let alts' = [(pat, vars, wrap_repr_inst - $ mkConApp sum_con (map Type tys ++ [body])) - | ((pat, vars, body), sum_con) - <- zip alts (tyConDataCons sum_tc)] - return $ mkWildCase arg arg_ty res_ty alts' - - con_alt (ConRepr con r) - = do - (vars, body) <- to_prod r - return (DataAlt con, vars, body) - - to_prod EmptyProd - = do - void <- builtin voidVar - return ([], Var void) - - to_prod (UnaryProd comp) - = do - var <- newLocalVar (fsLit "x") (compOrigType comp) - body <- to_comp (Var var) comp - return ([var], body) - - to_prod(Prod { repr_tup_tc = tup_tc - , repr_comp_tys = tys - , repr_comps = comps }) - = do - vars <- newLocalVars (fsLit "x") (map compOrigType comps) - exprs <- zipWithM to_comp (map Var vars) comps - return (vars, mkConApp tup_con (map Type tys ++ exprs)) - where - [tup_con] = tyConDataCons tup_tc - - to_comp expr (Keep _ _) = return expr - to_comp expr (Wrap ty) = do - wrap_tc <- builtin wrapTyCon - return $ wrapNewTypeBody wrap_tc [ty] expr - - -buildFromPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr -buildFromPRepr vect_tc repr_tc _ repr - = do - arg_ty <- mkPReprType res_ty - arg <- newLocalVar (fsLit "x") arg_ty - - result <- from_sum (unwrapFamInstScrut repr_tc ty_args (Var arg)) - repr - return $ Lam arg result - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - res_ty = mkTyConApp vect_tc ty_args - - from_sum _ EmptySum - = do - dummy <- builtin fromVoidVar - return $ Var dummy `App` Type res_ty - - from_sum expr (UnarySum r) = from_con expr r - from_sum expr (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons }) - = do - vars <- newLocalVars (fsLit "x") tys - es <- zipWithM from_con (map Var vars) cons - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt con, [var], e) - | (con, var, e) <- zip3 (tyConDataCons sum_tc) vars es] - - from_con expr (ConRepr con r) - = from_prod expr (mkConApp con $ map Type ty_args) r - - from_prod _ con EmptyProd = return con - from_prod expr con (UnaryProd r) - = do - e <- from_comp expr r - return $ con `App` e - - from_prod expr con (Prod { repr_tup_tc = tup_tc - , repr_comp_tys = tys - , repr_comps = comps - }) - = do - vars <- newLocalVars (fsLit "y") tys - es <- zipWithM from_comp (map Var vars) comps - return $ mkWildCase expr (exprType expr) res_ty - [(DataAlt tup_con, vars, con `mkApps` es)] - where - [tup_con] = tyConDataCons tup_tc - - from_comp expr (Keep _ _) = return expr - from_comp expr (Wrap ty) - = do - wrap <- builtin wrapTyCon - return $ unwrapNewTypeBody wrap [ty] expr - - -buildToArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr -buildToArrPRepr vect_tc prepr_tc pdata_tc r - = do - arg_ty <- mkPDataType el_ty - res_ty <- mkPDataType =<< mkPReprType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - pdata_co <- mkBuiltinCo pdataTyCon - let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCo pdata_co - . mkSymCo - $ mkAxInstCo repr_co ty_args - - scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) - - (vars, result) <- to_sum r - - return . Lam arg - $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty - [(DataAlt pdata_dc, vars, mkCast result co)] - where - ty_args = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc ty_args - - [pdata_dc] = tyConDataCons pdata_tc - - - to_sum EmptySum = do - pvoid <- builtin pvoidVar - return ([], Var pvoid) - to_sum (UnarySum r) = to_con r - to_sum (Sum { repr_psum_tc = psum_tc - , repr_sel_ty = sel_ty - , repr_con_tys = tys - , repr_cons = cons - }) - = do - (vars, exprs) <- mapAndUnzipM to_con cons - sel <- newLocalVar (fsLit "sel") sel_ty - return (sel : concat vars, mk_result (Var sel) exprs) - where - [psum_con] = tyConDataCons psum_tc - mk_result sel exprs = wrapFamInstBody psum_tc tys - $ mkConApp psum_con - $ map Type tys ++ (sel : exprs) - - to_con (ConRepr _ r) = to_prod r - - to_prod EmptyProd = do - pvoid <- builtin pvoidVar - return ([], Var pvoid) - to_prod (UnaryProd r) - = do - pty <- mkPDataType (compOrigType r) - var <- newLocalVar (fsLit "x") pty - expr <- to_comp (Var var) r - return ([var], expr) - - to_prod (Prod { repr_ptup_tc = ptup_tc - , repr_comp_tys = tys - , repr_comps = comps }) - = do - ptys <- mapM (mkPDataType . compOrigType) comps - vars <- newLocalVars (fsLit "x") ptys - es <- zipWithM to_comp (map Var vars) comps - return (vars, mk_result es) - where - [ptup_con] = tyConDataCons ptup_tc - mk_result exprs = wrapFamInstBody ptup_tc tys - $ mkConApp ptup_con - $ map Type tys ++ exprs - - to_comp expr (Keep _ _) = return expr - - -- FIXME: this is bound to be wrong! - to_comp expr (Wrap ty) - = do - wrap_tc <- builtin wrapTyCon - pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty]) - return $ wrapNewTypeBody pwrap_tc [ty] expr - - -buildFromArrPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr -buildFromArrPRepr vect_tc prepr_tc pdata_tc r - = do - arg_ty <- mkPDataType =<< mkPReprType el_ty - res_ty <- mkPDataType el_ty - arg <- newLocalVar (fsLit "xs") arg_ty - - pdata_co <- mkBuiltinCo pdataTyCon - let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCo pdata_co - $ mkAxInstCo repr_co var_tys - - scrut = mkCast (Var arg) co - - mk_result args = wrapFamInstBody pdata_tc var_tys - $ mkConApp pdata_con - $ map Type var_tys ++ args - - (expr, _) <- fixV $ \ ~(_, args) -> - from_sum res_ty (mk_result args) scrut r - - return $ Lam arg expr - - -- (args, mk) <- from_sum res_ty scrut r - - -- let result = wrapFamInstBody pdata_tc var_tys - -- . mkConApp pdata_dc - -- $ map Type var_tys ++ args - - -- return $ Lam arg (mk result) - where - var_tys = mkTyVarTys $ tyConTyVars vect_tc - el_ty = mkTyConApp vect_tc var_tys - - [pdata_con] = tyConDataCons pdata_tc - - from_sum _ res _ EmptySum = return (res, []) - from_sum res_ty res expr (UnarySum r) = from_con res_ty res expr r - from_sum res_ty res expr (Sum { repr_psum_tc = psum_tc - , repr_sel_ty = sel_ty - , repr_con_tys = tys - , repr_cons = cons }) - = do - sel <- newLocalVar (fsLit "sel") sel_ty - ptys <- mapM mkPDataType tys - vars <- newLocalVars (fsLit "xs") ptys - (res', args) <- fold from_con res_ty res (map Var vars) cons - let scrut = unwrapFamInstScrut psum_tc tys expr - body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt psum_con, sel : vars, res')] - return (body, Var sel : args) - where - [psum_con] = tyConDataCons psum_tc - - - from_con res_ty res expr (ConRepr _ r) = from_prod res_ty res expr r - - from_prod _ res _ EmptyProd = return (res, []) - from_prod res_ty res expr (UnaryProd r) - = from_comp res_ty res expr r - from_prod res_ty res expr (Prod { repr_ptup_tc = ptup_tc - , repr_comp_tys = tys - , repr_comps = comps }) - = do - ptys <- mapM mkPDataType tys - vars <- newLocalVars (fsLit "ys") ptys - (res', args) <- fold from_comp res_ty res (map Var vars) comps - let scrut = unwrapFamInstScrut ptup_tc tys expr - body = mkWildCase scrut (exprType scrut) res_ty - [(DataAlt ptup_con, vars, res')] - return (body, args) - where - [ptup_con] = tyConDataCons ptup_tc - - from_comp _ res expr (Keep _ _) = return (res, [expr]) - from_comp _ res expr (Wrap ty) - = do - wrap_tc <- builtin wrapTyCon - pwrap_tc <- pdataReprTyConExact (mkTyConApp wrap_tc [ty]) - return (res, [unwrapNewTypeBody pwrap_tc [ty] - $ unwrapFamInstScrut pwrap_tc [ty] expr]) - - fold f res_ty res exprs rs = foldrM f' (res, []) (zip exprs rs) - where - f' (expr, r) (res, args) = do - (res', args') <- f res_ty res expr r - return (res', args' ++ args) diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs index a08174d513..0c111f49c7 100644 --- a/compiler/vectorise/Vectorise/Utils/Base.hs +++ b/compiler/vectorise/Vectorise/Utils/Base.hs @@ -1,23 +1,26 @@ -module Vectorise.Utils.Base ( - voidType, - newLocalVVar, - - mkDataConTagLit, - mkDataConTag, dataConTagZ, - mkBuiltinTyConApp, - mkBuiltinTyConApps, - mkWrapType, - mkClosureTypes, - mkPReprType, - mkPArrayType, splitPrimTyCon, - mkPArray, - mkPDataType, mkPDatasType, - mkBuiltinCo, - mkVScrut, - - pdataReprTyCon, pdataReprTyConExact, pdatasReprTyCon, - pdataReprDataCon, pdatasReprDataCon, - prDFunOfTyCon +module Vectorise.Utils.Base + ( voidType + , newLocalVVar + + , mkDataConTag, dataConTagZ + , mkWrapType + , mkClosureTypes + , mkPReprType + , mkPDataType, mkPDatasType + , splitPrimTyCon + , mkBuiltinCo + + , wrapNewTypeBodyOfWrap + , unwrapNewTypeBodyOfWrap + , wrapNewTypeBodyOfPDataWrap + , unwrapNewTypeBodyOfPDataWrap + , wrapNewTypeBodyOfPDatasWrap + , unwrapNewTypeBodyOfPDatasWrap + + , pdataReprTyCon + , pdataReprTyConExact + , pdatasReprTyConExact + , pdataUnwrapScrut ) where import Vectorise.Monad @@ -28,24 +31,20 @@ import CoreSyn import CoreUtils import Coercion import Type -import TypeRep import TyCon import DataCon import MkId -import Literal -import Outputable import FastString -import ListSetOps - -import Control.Monad (liftM) -- Simple Types --------------------------------------------------------------- + voidType :: VM Type voidType = mkBuiltinTyConApp voidTyCon [] -- Name Generation ------------------------------------------------------------ + newLocalVVar :: FastString -> Type -> VM VVar newLocalVVar fs vty = do @@ -56,70 +55,64 @@ newLocalVVar fs vty -- Constructors --------------------------------------------------------------- -mkDataConTagLit :: DataCon -> Literal -mkDataConTagLit = mkMachInt . toInteger . dataConTagZ - mkDataConTag :: DataCon -> CoreExpr mkDataConTag = mkIntLitInt . dataConTagZ - dataConTagZ :: DataCon -> Int dataConTagZ con = dataConTag con - fIRST_TAG -- Type Construction ---------------------------------------------------------- --- | Make an application of a builtin type constructor to some arguments. -mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type -mkBuiltinTyConApp get_tc tys - = do tc <- builtin get_tc - return $ mkTyConApp tc tys - -mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type -mkBuiltinTyConApps get_tc tys ty - = do tc <- builtin get_tc - return $ foldr (mk tc) ty tys - where - mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] - - --- | Make an application of the 'Wrap' type constructor. +-- |Make an application of the 'Wrap' type constructor. +-- mkWrapType :: Type -> VM Type -mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] - +mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty] --- | Make an application of the closure type constructor. +-- |Make an application of the closure type constructor. +-- mkClosureTypes :: [Type] -> Type -> VM Type mkClosureTypes = mkBuiltinTyConApps closureTyCon - --- | Make an application of the 'PRepr' type constructor. +-- |Make an application of the 'PRepr' type constructor. +-- mkPReprType :: Type -> VM Type mkPReprType ty = mkBuiltinTyConApp preprTyCon [ty] - --- | Wrap a type into 'PArray', treating unboxed types specially. -mkPArrayType :: Type -> VM Type -mkPArrayType ty - | Just tycon <- splitPrimTyCon ty - = do { arr <- builtin (parray_PrimTyCon tycon) - ; return $ mkTyConApp arr [] - } -mkPArrayType ty = mkBuiltinTyConApp parrayTyCon [ty] - - -- | Make an appliction of the 'PData' tycon to some argument. +-- mkPDataType :: Type -> VM Type -mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty] - +mkPDataType ty = mkBuiltinTyConApp pdataTyCon [ty] -- | Make an application of the 'PDatas' tycon to some argument. +-- mkPDatasType :: Type -> VM Type mkPDatasType ty = mkBuiltinTyConApp pdatasTyCon [ty] +-- Make an application of a builtin type constructor to some arguments. +-- +mkBuiltinTyConApp :: (Builtins -> TyCon) -> [Type] -> VM Type +mkBuiltinTyConApp get_tc tys + = do { tc <- builtin get_tc + ; return $ mkTyConApp tc tys + } + +-- Make a cascading application of a builtin type constructor. +-- +mkBuiltinTyConApps :: (Builtins -> TyCon) -> [Type] -> Type -> VM Type +mkBuiltinTyConApps get_tc tys ty + = do { tc <- builtin get_tc + ; return $ foldr (mk tc) ty tys + } + where + mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2] + + +-- Type decomposition --------------------------------------------------------- -- |Checks if a type constructor is defined in 'GHC.Prim' (e.g., 'Int#'); if so, returns it. +-- splitPrimTyCon :: Type -> Maybe TyCon splitPrimTyCon ty | Just (tycon, []) <- splitTyConApp_maybe ty @@ -128,38 +121,73 @@ splitPrimTyCon ty | otherwise = Nothing +-- Coercion Construction ----------------------------------------------------- --- CoreExpr Construction ------------------------------------------------------ --- | Make an application of the 'PArray' data constructor. -mkPArray - :: Type -- ^ Element type - -> CoreExpr -- ^ 'Int' for the array length. - -> CoreExpr -- ^ 'PData' for the array data. - -> VM CoreExpr +-- |Make a coersion to some builtin type. +-- +mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion +mkBuiltinCo get_tc + = do { tc <- builtin get_tc + ; return $ mkTyConAppCo tc [] + } -mkPArray ty len dat - = do tc <- builtin parrayTyCon - let [dc] = tyConDataCons tc - return $ mkConApp dc [Type ty, len, dat] +-- Wrapping and unwrapping the 'Wrap' newtype --------------------------------- --- Coercion Construction ----------------------------------------------------- --- | Make a coersion to some builtin type. -mkBuiltinCo :: (Builtins -> TyCon) -> VM Coercion -mkBuiltinCo get_tc - = do tc <- builtin get_tc - return $ mkTyConAppCo tc [] +-- |Apply the constructor wrapper of the 'Wrap' /newtype/. +-- +wrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr +wrapNewTypeBodyOfWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; return $ wrapNewTypeBody wrap_tc [ty] e + } + +-- |Strip the constructor wrapper of the 'Wrap' /newtype/. +-- +unwrapNewTypeBodyOfWrap :: CoreExpr -> Type -> VM CoreExpr +unwrapNewTypeBodyOfWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; return $ unwrapNewTypeBody wrap_tc [ty] e + } +-- |Apply the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. +-- +wrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr +wrapNewTypeBodyOfPDataWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdataReprTyConExact wrap_tc + ; return $ wrapNewTypeBody pwrap_tc [ty] e + } -------------------------------------------------------------------------------- +-- |Strip the constructor wrapper of the 'PData' /newtype/ instance of 'Wrap'. +-- +unwrapNewTypeBodyOfPDataWrap :: CoreExpr -> Type -> VM CoreExpr +unwrapNewTypeBodyOfPDataWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdataReprTyConExact wrap_tc + ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) + } -mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type]) -mkVScrut (ve, le) - = do - (tc, arg_tys) <- pdataReprTyCon ty - return (ve, unwrapFamInstScrut tc arg_tys le, tc, arg_tys) - where - ty = exprType ve +-- |Apply the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. +-- +wrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr +wrapNewTypeBodyOfPDatasWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdatasReprTyConExact wrap_tc + ; return $ wrapNewTypeBody pwrap_tc [ty] e + } + +-- |Strip the constructor wrapper of the 'PDatas' /newtype/ instance of 'Wrap'. +-- +unwrapNewTypeBodyOfPDatasWrap :: CoreExpr -> Type -> VM CoreExpr +unwrapNewTypeBodyOfPDatasWrap e ty + = do { wrap_tc <- builtin wrapTyCon + ; pwrap_tc <- pdatasReprTyConExact wrap_tc + ; return $ unwrapNewTypeBody pwrap_tc [ty] (unwrapFamInstScrut pwrap_tc [ty] e) + } + + +-- 'PData' representation types ---------------------------------------------- -- |Get the representation tycon of the 'PData' data family for a given type. -- @@ -175,43 +203,41 @@ mkVScrut (ve, le) pdataReprTyCon :: Type -> VM (TyCon, [Type]) pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty]) --- |Get the representation tycon of the 'PData' data family for a given type which must match the --- type index in the looked up 'PData' instance exactly. --- -pdataReprTyConExact :: Type -> VM TyCon -pdataReprTyConExact ty - = do { (tycon, tys) <- pdataReprTyCon ty - ; if uniqueTyVars tys - then - return tycon - else - cantVectorise "No exact 'PData' family instance for" (ppr ty) - } - where - uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys) - where - extractTyVar (TyVarTy tv) = tv - extractTyVar _ = panic "Vectorise.Utils.Base: extractTyVar" - -pdataReprDataCon :: Type -> VM (DataCon, [Type]) -pdataReprDataCon ty - = do { (tc, arg_tys) <- pdataReprTyCon ty - ; let [dc] = tyConDataCons tc - ; return (dc, arg_tys) +-- |Get the representation tycon of the 'PData' data family for a given type constructor. +-- +-- For example, for a binary type constructor 'T', we determine the representation type constructor +-- for 'PData (T a b)'. +-- +pdataReprTyConExact :: TyCon -> VM TyCon +pdataReprTyConExact tycon + = do { -- look up the representation tycon; if there is a match at all, it will be be exact + ; -- (i.e.,' _tys' will be distinct type variables) + ; (ptycon, _tys) <- pdataReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) + ; return ptycon } -pdatasReprTyCon :: Type -> VM (TyCon, [Type]) -pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty]) +-- |Get the representation tycon of the 'PDatas' data family for a given type constructor. +-- +-- For example, for a binary type constructor 'T', we determine the representation type constructor +-- for 'PDatas (T a b)'. +-- +pdatasReprTyConExact :: TyCon -> VM TyCon +pdatasReprTyConExact tycon + = do { -- look up the representation tycon; if there is a match at all, it will be be exact + ; -- (i.e.,' _tys' will be distinct type variables) + ; (ptycon, _tys) <- pdatasReprTyCon (tycon `mkTyConApp` mkTyVarTys (tyConTyVars tycon)) + ; return ptycon + } + where + pdatasReprTyCon ty = builtin pdatasTyCon >>= (`lookupFamInst` [ty]) -pdatasReprDataCon :: Type -> VM (DataCon, [Type]) -pdatasReprDataCon ty - = do { (tc, arg_tys) <- pdatasReprTyCon ty +-- |Unwrap a 'PData' representation scrutinee. +-- +pdataUnwrapScrut :: VExpr -> VM (CoreExpr, CoreExpr, DataCon) +pdataUnwrapScrut (ve, le) + = do { (tc, arg_tys) <- pdataReprTyCon ty ; let [dc] = tyConDataCons tc - ; return (dc, arg_tys) + ; return (ve, unwrapFamInstScrut tc arg_tys le, dc) } - -prDFunOfTyCon :: TyCon -> VM CoreExpr -prDFunOfTyCon tycon - = liftM Var - . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon) - $ lookupTyConPR tycon + where + ty = exprType ve diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 5a38ecd557..164ebae229 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -75,11 +75,12 @@ paDictOfType ty -- the representation type if the tycon is polymorphic paDictOfTyApp (TyConApp tc []) ty_args = do - dfun <- maybeCantVectoriseM "No PA dictionary for type constructor" - (ppr tc <+> text "in" <+> ppr ty) + dfun <- maybeCantVectoriseM noPADictErr (ppr tc <+> text "in" <+> ppr ty) $ lookupTyConPA tc dicts <- mapM paDictOfType ty_args return $ Var dfun `mkTyApps` ty_args `mkApps` dicts + where + noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)" paDictOfTyApp _ _ = failure |