diff options
81 files changed, 1439 insertions, 1376 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 590a1250d5..2bba7b7586 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -224,7 +224,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS], openbsd) test -z "[$]2" || eval "[$]2=OSOpenBSD" ;; - netbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) + netbsd) + test -z "[$]2" || eval "[$]2=OSNetBSD" + ;; + dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) test -z "[$]2" || eval "[$]2=OSUnknown" ;; *) 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 diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 0c35c850c3..3112ef2796 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -809,6 +809,13 @@ <entry><option>-XNoConstraintKinds</option></entry> </row> <row> + <entry><option>-XPolyKinds</option></entry> + <entry>Enable <link linkend="kind-polymorphism">kind polymorphism</link>. + Implies <option>-XKindSignatures</option>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoPolyKinds</option></entry> + </row> + <row> <entry><option>-XScopedTypeVariables</option></entry> <entry>Enable <link linkend="scoped-type-variables">lexically-scoped type variables</link>. Implied by <option>-fglasgow-exts</option>.</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 7779b0dcc7..9f8337d953 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -933,7 +933,7 @@ rec { b <- f a c ===> (b,c) <- mfix (\~(b,c) -> do { b <- f a c ; c <- f b a } ; c <- f b a ; return (b,c) }) </programlisting> -In general, the statment <literal>rec <replaceable>ss</replaceable></literal> +In general, the statement <literal>rec <replaceable>ss</replaceable></literal> is desugared to the statement <programlisting> <replaceable>vs</replaceable> <- mfix (\~<replaceable>vs</replaceable> -> do { <replaceable>ss</replaceable>; return <replaceable>vs</replaceable> }) @@ -1028,7 +1028,7 @@ This name is not supported by GHC. [ (x, y) | x <- xs | y <- ys ] </programlisting> - <para>The behavior of parallel list comprehensions follows that of + <para>The behaviour of parallel list comprehensions follows that of zip, in that the resulting list will have the same length as the shortest branch.</para> @@ -1790,7 +1790,7 @@ the same as the omitted field names. <listitem><para> The "<literal>..</literal>" expands to the missing -<emphasis>in-scope</emphasis> record fields. +<emphasis>in-scope</emphasis> record fields. Specifically the expansion of "<literal>C {..}</literal>" includes <literal>f</literal> if and only if: <itemizedlist> @@ -1801,8 +1801,8 @@ Specifically the expansion of "<literal>C {..}</literal>" includes The record field <literal>f</literal> is in scope somehow (either qualified or unqualified). </para></listitem> <listitem><para> -In the case of expressions (but not patterns), -the variable <literal>f</literal> is in scope unqualified, +In the case of expressions (but not patterns), +the variable <literal>f</literal> is in scope unqualified, apart from the binding of the record selector itself. </para></listitem> </itemizedlist> @@ -1817,7 +1817,7 @@ module X where The <literal>R{..}</literal> expands to <literal>R{M.a=a}</literal>, omitting <literal>b</literal> since the record field is not in scope, and omitting <literal>c</literal> since the variable <literal>c</literal> -is not in scope (apart from the binding of the +is not in scope (apart from the binding of the record selector <literal>c</literal>, of course). </para></listitem> </itemizedlist> @@ -1970,7 +1970,7 @@ The following syntax is stolen: <indexterm><primary><literal>mdo</literal></primary></indexterm> </term> <listitem><para> - Stolen by: <option>-XRecursiveDo</option>, + Stolen by: <option>-XRecursiveDo</option> </para></listitem> </varlistentry> @@ -1980,7 +1980,7 @@ The following syntax is stolen: <indexterm><primary><literal>foreign</literal></primary></indexterm> </term> <listitem><para> - Stolen by: <option>-XForeignFunctionInterface</option>, + Stolen by: <option>-XForeignFunctionInterface</option> </para></listitem> </varlistentry> @@ -1994,7 +1994,7 @@ The following syntax is stolen: <indexterm><primary><literal>proc</literal></primary></indexterm> </term> <listitem><para> - Stolen by: <option>-XArrows</option>, + Stolen by: <option>-XArrows</option> </para></listitem> </varlistentry> @@ -2005,7 +2005,7 @@ The following syntax is stolen: <indexterm><primary>implicit parameters</primary></indexterm> </term> <listitem><para> - Stolen by: <option>-XImplicitParams</option>, + Stolen by: <option>-XImplicitParams</option> </para></listitem> </varlistentry> @@ -2019,7 +2019,17 @@ The following syntax is stolen: <indexterm><primary>Template Haskell</primary></indexterm> </term> <listitem><para> - Stolen by: <option>-XTemplateHaskell</option>, + Stolen by: <option>-XTemplateHaskell</option> + </para></listitem> + </varlistentry> + + <varlistentry> + <term> + <literal>'<replaceable>varid</replaceable></literal> + </term> + <listitem><para> + Stolen by: <option>-XTemplateHaskell</option>and + <option>-XPolyKinds</option> </para></listitem> </varlistentry> @@ -2029,7 +2039,7 @@ The following syntax is stolen: <indexterm><primary>quasi-quotation</primary></indexterm> </term> <listitem><para> - Stolen by: <option>-XQuasiQuotes</option>, + Stolen by: <option>-XQuasiQuotes</option> </para></listitem> </varlistentry> @@ -2041,10 +2051,10 @@ The following syntax is stolen: <replaceable>integer</replaceable><literal>#</literal>, <replaceable>float</replaceable><literal>#</literal>, <replaceable>float</replaceable><literal>##</literal>, - <literal>(#</literal>, <literal>#)</literal>, + <literal>(#</literal>, <literal>#)</literal> </term> <listitem><para> - Stolen by: <option>-XMagicHash</option>, + Stolen by: <option>-XMagicHash</option> </para></listitem> </varlistentry> </variablelist> @@ -2060,7 +2070,7 @@ The following syntax is stolen: <sect2 id="nullary-types"> <title>Data types with no constructors</title> -<para>With the <option>-XEmptyDataDecls</option> flag (or equivalent LANGUAGE pragma), +<para>With the <option>-XEmptyDataDecls</option> flag (or equivalent LANGUAGE pragma), GHC lets you declare a data type with no constructors. For example:</para> <programlisting> @@ -3535,7 +3545,7 @@ liberal in these case. For example, this is OK: <programlisting> class A cls c where meth :: cls c => c -> c - + class A B c => B c where </programlisting> @@ -4260,7 +4270,7 @@ of the instance declaration, thus: </para> <para> Warning: overlapping instances must be used with care. They -can give rise to incoherence (ie different instance choices are made +can give rise to incoherence (i.e. different instance choices are made in different parts of the program) even without <option>-XIncoherentInstances</option>. Consider: <programlisting> {-# LANGUAGE OverlappingInstances #-} @@ -4839,7 +4849,7 @@ instance (Eq (Elem [e])) => Collects ([e]) where type indexes corresponding to class parameters must be identical to the type given in the instance head; here this is the first argument of <literal>GMap</literal>, namely <literal>Either a b</literal>, - which coincides with the only class parameter. + which coincides with the only class parameter. </para> <para> Instances for an associated family can only appear as part of @@ -4873,7 +4883,7 @@ instance GMapKey Flob where <sect3 id="assoc-decl-defs"> <title>Associated type synonym defaults</title> <para> - It is possible for the class defining the associated type to specify a + It is possible for the class defining the associated type to specify a default for associated type instances. So for example, this is OK: <programlisting> class IsBoolMap v where @@ -4905,7 +4915,7 @@ A default declaration is not permitted for an associated <para> The visibility of class parameters in the right-hand side of associated family instances - depends <emphasis>solely</emphasis> on the parameters of the + depends <emphasis>solely</emphasis> on the parameters of the family. As an example, consider the simple class declaration <programlisting> class C a b where @@ -4929,19 +4939,19 @@ instance C [c] d where <title>Import and export</title> <para> -The rules for export lists -(Haskell Report +The rules for export lists +(Haskell Report <ulink url="http://www.haskell.org/onlinereport/modules.html#sect5.2">Section 5.2</ulink>) needs adjustment for type families: <itemizedlist> <listitem><para> The form <literal>T(..)</literal>, where <literal>T</literal> - is a data family, names the family <literal>T</literal> and all the in-scope - constructors (whether in scope qualified or unqualified) that are data + is a data family, names the family <literal>T</literal> and all the in-scope + constructors (whether in scope qualified or unqualified) that are data instances of <literal>T</literal>. </para></listitem> <listitem><para> - The form <literal>T(.., ci, .., fj, ..)</literal>, where <literal>T</literal> is + The form <literal>T(.., ci, .., fj, ..)</literal>, where <literal>T</literal> is a data family, names <literal>T</literal> and the specified constructors <literal>ci</literal> and fields <literal>fj</literal> as usual. The constructors and field names must belong to some data instance of <literal>T</literal>, but are not required to belong @@ -4974,7 +4984,7 @@ class GMapKey k where instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) - ...method declartions... + ...method declarations... </programlisting> Here are some export lists and their meaning: <itemizedlist> @@ -4991,21 +5001,21 @@ Here are some export lists and their meaning: (in this case <literal>GMapEither</literal>) are not exported.</para> </listitem> <listitem> - <para><literal>module GMap( GMapKey( type GMap, empty, lookup, insert ) )</literal>: - Same as the pevious item. Note the "<literal>type</literal>" keyword.</para> + <para><literal>module GMap( GMapKey( type GMap, empty, lookup, insert ) )</literal>: + Same as the previous item. Note the "<literal>type</literal>" keyword.</para> </listitem> <listitem> - <para><literal>module GMap( GMapKey(..), GMap(..) )</literal>: + <para><literal>module GMap( GMapKey(..), GMap(..) )</literal>: Same as previous item, but also exports all the data constructors for <literal>GMap</literal>, namely <literal>GMapEither</literal>. </para> </listitem> <listitem> - <para><literal>module GMap ( GMapKey( empty, lookup, insert), GMap(..) )</literal>: + <para><literal>module GMap ( GMapKey( empty, lookup, insert), GMap(..) )</literal>: Same as previous item.</para> </listitem> <listitem> - <para><literal>module GMap ( GMapKey, empty, lookup, insert, GMap(..) )</literal>: + <para><literal>module GMap ( GMapKey, empty, lookup, insert, GMap(..) )</literal>: Same as previous item.</para> </listitem> </itemizedlist> @@ -5022,16 +5032,16 @@ Two things to watch out for: <listitem><para> Consider this example: <programlisting> - module X where + module X where data family D module Y where import X data instance D Int = D1 | D2 </programlisting> - Module Y exports all the entities defined in Y, namely the data constructrs <literal>D1</literal> + Module Y exports all the entities defined in Y, namely the data constructors <literal>D1</literal> and <literal>D2</literal>, <emphasis>but not the data family <literal>D</literal></emphasis>. - That (annoyingly) means that you cannot selectively import Y selectively, + That (annoyingly) means that you cannot selectively import Y selectively, thus "<literal>import Y( D(D1,D2) )</literal>", because Y does not export <literal>D</literal>. Instead you should list the exports explicitly, thus: <programlisting> @@ -5040,7 +5050,7 @@ or module Y( module Y, D ) where ... </programlisting> </para></listitem> </itemizedlist> -</para> +</para> </sect3> <sect3 id="data-family-impexp-instances"> @@ -5081,7 +5091,7 @@ The situation is especially bad because the type instance for <literal>F Bool</l might be in another module, or even in a module that is not yet written. </para> <para> -However, type class instances of instances of data families can be defined +However, type class instances of instances of data families can be defined much like any other data type. For example, we can say <programlisting> data instance T Int = T1 Int | T2 Bool @@ -5115,6 +5125,223 @@ instance Show v => Show (GMap () v) where ... </sect1> +<sect1 id="kind-polymorphism-and-promotion"> +<title>Kind polymorphism and promotion</title> + +<para> +Standard Haskell has a rich type language. Types classify terms and serve to +avoid many common programming mistakes. The kind language, however, is +relatively simple, distinguishing only lifted types (kind <literal>*</literal>), +type constructors (eg. kind <literal>* -> * -> *</literal>), and unlifted +types (<xref linkend="glasgow-unboxed"/>). In particular when using advanced +type system features, such as type families (<xref linkend="type-families"/>) +or GADTs (<xref linkend="gadt"/>), this simple kind system is insufficient, +and fails to prevent simple errors. Consider the example of type-level natural +numbers, and length-indexed vectors: +<programlisting> +data Ze +data Su n + +data Vec :: * -> * -> * where + Nil :: Vec a Ze + Cons :: a -> Vec a n -> Vec a (Su n) +</programlisting> +The kind of <literal>Vec</literal> is <literal>* -> * -> *</literal>. This means +that eg. <literal>Vec Int Char</literal> is a well-kinded type, even though this +is not what we intend when defining length-indexed vectors. +</para> + +<para> +With the <option>-XPolyKinds</option> flag, users can specify better kinds for +their programs. This flag enables two orthogonal but related features: kind +polymorphism and user defined kinds through datatype promotion. With +<option>-XPolyKinds</option>, the example above can then be rewritten to: +<programlisting> +data Nat = Ze | Su Nat + +data Vec :: * -> Nat -> * where + Nil :: Vec a Ze + Cons :: a -> Vec a n -> Vec a (Su n) +</programlisting> +With the improved kind of <literal>Vec</literal>, things like +<literal>Vec Int Char</literal> are now ill-kinded, and GHC will report an +error. +</para> + +<para> +In this section we show a few examples of how to make use of the new kind +system. This extension is described in more detail in the paper +<ulink url="http://dreixel.net/research/pdf/ghp.pdf">Giving Haskell a +Promotion</ulink>, which appeared at TLDI 2012. +</para> + +<sect2 id="kind-polymorphism"> +<title>Kind polymorphism</title> +<para> +Currently there is a lot of code duplication in the way Typeable is implemented +(<xref linkend="deriving-typeable"/>): +<programlisting> +class Typeable (t :: *) where + typeOf :: t -> TypeRep + +class Typeable1 (t :: * -> *) where + typeOf1 :: t a -> TypeRep + +class Typeable2 (t :: * -> * -> *) where + typeOf2 :: t a b -> TypeRep +</programlisting> +</para> + +<para> +Kind polymorphism allows us to merge all these classes into one: +<programlisting> +data Proxy t = Proxy + +class Typeable t where + typeOf :: Proxy t -> TypeRep + +instance Typeable Int where typeOf _ = TypeRep +instance Typeable [] where typeOf _ = TypeRep +</programlisting> +Note that the datatype <literal>Proxy</literal> has kind +<literal>forall k. k -> *</literal> (inferred by GHC), and the new +<literal>Typeable</literal> class has kind +<literal>forall k. k -> Constraint</literal>. +</para> + +<para> +There are some restrictions in the current implementation: +<itemizedlist> + <listitem><para>You cannot explicitly abstract over kinds, or mention kind + variables. So the following are all rejected: +<programlisting> +data D1 (t :: k) + +data D2 :: k -> * + +data D3 (k :: BOX) +</programlisting></para> + </listitem> + <listitem><para>The return kind of a type family is always defaulted to + <literal>*</literal>. So the following is rejected: +<programlisting> +type family F a +type instance F Int = Maybe +</programlisting></para> + </listitem> +</itemizedlist> +</para> + +</sect2> + +<sect2 id="promotion"> +<title>Datatype promotion</title> +<para> +Along with kind polymorphism comes the ability to define custom named kinds. +With <option>-XPolyKinds</option>, GHC automatically promotes every suitable +datatype to be a kind, and its (value) constructors to be type constructors. +The following types +<programlisting> +data Nat = Ze | Su Nat + +data List a = Nil | Cons a (List a) + +data Pair a b = Pair a b + +data Sum a b = L a | R b +</programlisting> +give rise to the following kinds and type constructors: +<programlisting> +Nat :: BOX +Ze :: Nat +Su :: Nat -> Nat + +List k :: BOX +Nil :: List k +Cons :: k -> List k -> List k + +Pair k1 k2 :: BOX +Pair :: k1 -> k2 -> Pair k1 k2 + +Sum k1 k2 :: BOX +L :: k1 -> Sum k1 k2 +R :: k2 -> Sum k1 k2 +</programlisting> +Note that <literal>List</literal>, for instance, does not get kind +<literal>BOX -> BOX</literal>, because we do not further classify kinds; all +kinds have sort <literal>BOX</literal>. +</para> + +<para> +The following restrictions apply to promotion: +<itemizedlist> + <listitem><para>We only promote datatypes whose kinds are of the form + <literal>* -> ... -> * -> *</literal>. In particular, we do not promote + higher-kinded datatypes such as <literal>data Fix f = In (f (Fix f))</literal>, + or datatypes whose kinds involve promoted types such as + <literal>Vec :: * -> Nat -> *</literal>.</para></listitem> + <listitem><para>We do not promote datatypes whose constructors are kind + polymorphic, involve constraints, or use existential quantification. + </para></listitem> +</itemizedlist> +</para> + +<sect3 id="promotion-syntax"> +<title>Distinguishing between types and constructors</title> +<para> +Since constructors and types share the same namespace, with promotion you can +get ambiguous type names: +<programlisting> +data P -- 1 + +data Prom = P -- 2 + +type T = P -- 1 or promoted 2? +</programlisting> +In these cases, if you want to refer to the promoted constructor, you should +prefix its name with a quote: +<programlisting> +type T1 = P -- 1 + +type T2 = 'P -- promoted 2 +</programlisting> +Note that promoted datatypes give rise to named kinds. Since these can never be +ambiguous, we do not allow quotes in kind names. +</para> +</sect3> + +<sect3 id="promoted-lists-and-tuples"> +<title>Promoted lists and tuples types</title> +<para> +Haskell's list and tuple types are natively promoted to kinds, and enjoy the +same convenient syntax at the type level, albeit prefixed with a quote: +<programlisting> +data HList :: [*] -> * where + HNil :: HList '[] + HCons :: a -> HList t -> HList (a ': t) + +data Tuple :: (*,*) -> * where + Tuple :: a -> b -> Tuple '(a,b) +</programlisting> +Note that this requires <option>-XTypeOperators</option>. +</para> +</sect3> + +</sect2> + +<sect2 id="kind-polymorphism-limitations"> +<title>Shortcomings of the current implementation</title> +<para> +For the release on GHC 7.4 we focused on getting the new kind-polymorphic core +to work with all existing programs (which do not make use of kind polymorphism). +Many things already work properly with <option>-XPolyKinds</option>, but we +expect that some things will not work. If you run into trouble, please +<link linkend="bug-reporting">report a bug</link>! +</para> +</sect2> + +</sect1> + <sect1 id="equality-constraints"> <title>Equality constraints</title> <para> @@ -5228,7 +5455,7 @@ foo x = (show x, read) </para> <programlisting> -type family Clsish u a +type family Clsish u a type instance Clsish () a = Cls a class Clsish () a => Cls a where </programlisting> @@ -5236,7 +5463,7 @@ class Clsish () a => Cls a where <programlisting> class OkCls a where -type family OkClsish u a +type family OkClsish u a type instance OkClsish () a = OkCls a instance OkClsish () a => OkCls a where </programlisting> @@ -6879,10 +7106,10 @@ The quoted <replaceable>string</replaceable> finishes at the first occurrence of the two-character sequence <literal>"|]"</literal>. Absolutely no escaping is performed. If you want to embed that character sequence in the string, you must invent your own escape convention (such -as, say, using the string <literal>"|~]"</literal> instead), and make your +as, say, using the string <literal>"|~]"</literal> instead), and make your quoter function interpret <literal>"|~]"</literal> as <literal>"|]"</literal>. One way to implement this is to compose your quoter with a pre-processing pass to -perform your escape conversion. See the +perform your escape conversion. See the <ulink url="http://hackage.haskell.org/trac/ghc/ticket/5348"> discussion in Trac</ulink> for details. </para></listitem> @@ -8302,12 +8529,16 @@ happen. {-# SPECIALIZE hammeredLookup :: [(Widget, value)] -> Widget -> value #-} </programlisting> +<itemizedlist> +<listitem> <para>A <literal>SPECIALIZE</literal> pragma for a function can - be put anywhere its type signature could be put. Moreover, you + be put anywhere its type signature could be put. Moreover, you can also <literal>SPECIALIZE</literal> an <emphasis>imported</emphasis> function provided it was given an <literal>INLINABLE</literal> pragma at its definition site (<xref linkend="inlinable-pragma"/>).</para> +</listitem> +<listitem> <para>A <literal>SPECIALIZE</literal> has the effect of generating (a) a specialised version of the function and (b) a rewrite rule (see <xref linkend="rewrite-rules"/>) that rewrites a call to @@ -8318,7 +8549,36 @@ happen. by <literal>f</literal>, if they are in the same module as the <literal>SPECIALIZE</literal> pragma, or if they are <literal>INLINABLE</literal>; and so on, transitively.</para> +</listitem> +<listitem> + <para>You can add phase control (<xref linkend="phase-control"/>) + to the RULE generated by a <literal>SPECIALIZE</literal> pragma, + just as you can if you write a RULE directly. For example: +<programlisting> + {-# SPECIALIZE [0] hammeredLookup :: [(Widget, value)] -> Widget -> value #-} +</programlisting> + generates a specialisation rule that only fires in Phase 0 (the final phase). + If you do not specify any phase control in the <literal>SPECIALIZE</literal> pragma, + the phase control is inherited from the inline pragma (if any) of the function. + For example: +<programlisting> + foo :: Num a => a -> a + foo = ...blah... + {-# NOINLINE [0] foo #-} + {-# SPECIALIZE foo :: Int -> Int #-} +</programlisting> + The <literal>NOINLINE</literal> pragma tells GHC not to inline <literal>foo</literal> + until Phase 0; and this property is inherited by the specialisation RULE, which will + therefore only fire in Phase 0.</para> + <para>The main reason for using phase control on specialisations is so that you can + write optimisation RULES that fire early in the compilation pipeline, and only + <emphasis>then</emphasis> specialise the calls to the function. If specialisation is + done too early, the optimisation rules might fail to fire. + </para> +</listitem> + +<listitem> <para>The type in a SPECIALIZE pragma can be any type that is less polymorphic than the type of the original function. In concrete terms, if the original function is <literal>f</literal> then the pragma @@ -8346,6 +8606,8 @@ The last of these examples will generate a RULE with a somewhat-complex left-hand side (try it yourself), so it might not fire very well. If you use this kind of specialisation, let us know how well it works. </para> +</listitem> +</itemizedlist> <sect3 id="specialize-inline"> <title>SPECIALIZE INLINE</title> @@ -8376,6 +8638,11 @@ the specialised function will be inlined. It has two calls to both at type <literal>Int</literal>. Both these calls fire the first specialisation, whose body is also inlined. The result is a type-based unrolling of the indexing function.</para> +<para>You can add explicit phase control (<xref linkend="phase-control"/>) +to <literal>SPECIALISE INLINE</literal> pragma, +just like on an <literal>INLINE</literal> pragma; if you do so, the same phase +is used for the rewrite rule and the INLINE control of the specialised function.</para> + <para>Warning: you can make GHC diverge by using <literal>SPECIALISE INLINE</literal> on an ordinarily-recursive function.</para> </sect3> diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml index 3575b3cd6b..a8352aea6f 100644 --- a/docs/users_guide/safe_haskell.xml +++ b/docs/users_guide/safe_haskell.xml @@ -545,7 +545,7 @@ </para> </sect3> - <sec3 id="trustworthy-guarantees"> + <sect3 id="trustworthy-guarantees"> <title>Trustworthy Requirements</title> <indexterm><primary>trustworthy</primary></indexterm> @@ -554,7 +554,7 @@ exposed by its export list) can't be used in an unsafe manner. This mean that symbols exported should respect type safety and referential transparency. - </sec3> + </sect3> <sect3 id="safe-package-trust"> <title>Package Trust</title> @@ -582,7 +582,7 @@ </sect2> - <sec2 id="safe-inference"> + <sect2 id="safe-inference"> <title>Safe Haskell Inference</title> <indexterm><primary>safe inference</primary></indexterm> @@ -619,7 +619,7 @@ user of the library would have to wrap it in a shim that simply re-exported your API through a trustworthy module, an annoying practice. </para> - </sec2> + </sect2> <sect2 id="safe-flag-summary"> <title>Safe Haskell Flag Summary</title> @@ -1047,7 +1047,7 @@ publish-docs: # Directory in which we're going to build the src dist # SRC_DIST_NAME=ghc-$(ProjectVersion) -SRC_DIST_DIR=$(TOP)/$(SRC_DIST_NAME) +SRC_DIST_DIR=$(SRC_DIST_NAME) # # Files to include in source distributions @@ -1083,8 +1083,8 @@ sdist-prep : cd $(SRC_DIST_DIR) && for i in $(SRC_DIST_DIRS); do mkdir $$i; ( cd $$i && lndir $(TOP)/$$i ); done cd $(SRC_DIST_DIR) && for i in $(SRC_DIST_FILES); do $(LN_S) $(TOP)/$$i .; done cd $(SRC_DIST_DIR) && $(MAKE) distclean - rm -rf $(SRC_DIST_DIR)/libraries/tarballs/ - rm -rf $(SRC_DIST_DIR)/libraries/stamp/ + $(call removeTrees,$(SRC_DIST_DIR)/libraries/tarballs/) + $(call removeTrees,$(SRC_DIST_DIR)/libraries/stamp/) $(call sdist_file,compiler,stage2,cmm,,CmmLex,x) $(call sdist_file,compiler,stage2,cmm,,CmmParse,y) $(call sdist_file,compiler,stage2,parser,,Lexer,x) @@ -1096,7 +1096,7 @@ sdist-prep : $(call sdist_file,utils/haddock,dist,src,Haddock,Lex,x) $(call sdist_file,utils/haddock,dist,src,Haddock,Parse,y) cd $(SRC_DIST_DIR) && $(call removeTrees,compiler/stage[123] mk/build.mk) - cd $(SRC_DIST_DIR) && "$(FIND)" $(SRC_DIST_DIRS) \( -name _darcs -o -name SRC -o -name "autom4te*" -o -name "*~" -o -name ".cvsignore" -o -name "\#*" -o -name ".\#*" -o -name "log" -o -name "*-SAVE" -o -name "*.orig" -o -name "*.rej" -o -name "*-darcs-backup*" \) -print | "$(XARGS)" $(XARGS_OPTS) "$(RM)" $(RM_OPTS_REC) + cd $(SRC_DIST_DIR) && "$(FIND)" $(SRC_DIST_DIRS) \( -name .git -o -name "autom4te*" -o -name "*~" -o -name "\#*" -o -name ".\#*" -o -name "log" -o -name "*-SAVE" -o -name "*.orig" -o -name "*.rej" \) -print | "$(XARGS)" $(XARGS_OPTS) "$(RM)" $(RM_OPTS_REC) .PHONY: sdist sdist : sdist-prep diff --git a/ghc/ghc.mk b/ghc/ghc.mk index 38b3016b30..2af90bed28 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -26,8 +26,11 @@ ghc_stage1_MORE_HC_OPTS = $(GhcStage1HcOpts) ghc_stage2_MORE_HC_OPTS = $(GhcStage2HcOpts) ghc_stage3_MORE_HC_OPTS = $(GhcStage3HcOpts) -ghc_stage2_CC_OPTS = -Iincludes -ghc_stage3_CC_OPTS = -Iincludes +# We need __GLASGOW_HASKELL__ in hschooks.c, so we have to build C +# sources with GHC: +ghc_stage1_UseGhcForCC = YES +ghc_stage2_UseGhcForCC = YES +ghc_stage3_UseGhcForCC = YES ghc_stage1_C_FILES_NODEPS = ghc/hschooks.c diff --git a/ghc/hschooks.c b/ghc/hschooks.c index 18679281e0..037d4e18be 100644 --- a/ghc/hschooks.c +++ b/ghc/hschooks.c @@ -23,7 +23,11 @@ defaultsHook (void) // See #3408: the default idle GC time of 0.3s is too short on // Windows where we receive console events once per second or so. +#if __GLASGOW_HASKELL__ >= 703 + RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5); +#else RtsFlags.GcFlags.idleGCDelayTime = 5*1000; +#endif } void diff --git a/includes/Rts.h b/includes/Rts.h index 5caba59dbe..45c09f8fb7 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -155,6 +155,36 @@ void _assertFail(const char *filename, unsigned int linenum) #endif /* ----------------------------------------------------------------------------- + Time values in the RTS + -------------------------------------------------------------------------- */ + +// For most time values in the RTS we use a fixed resolution of nanoseconds, +// normalising the time we get from platform-dependent APIs to this +// resolution. +#define TIME_RESOLUTION 1000000000 +typedef StgInt64 Time; + +#if TIME_RESOLUTION == 1000000000 +// I'm being lazy, but it's awkward to define fully general versions of these +#define TimeToUS(t) (t / 1000) +#define TimeToNS(t) (t) +#define USToTime(t) ((Time)(t) * 1000) +#define NSToTime(t) ((Time)(t)) +#else +#error Fix TimeToNS(), TimeToUS() etc. +#endif + +#define SecondsToTime(t) ((Time)(t) * TIME_RESOLUTION) +#define TimeToSeconds(t) ((t) / TIME_RESOLUTION) + +// Use instead of SecondsToTime() when we have a floating-point +// seconds value, to avoid truncating it. +INLINE_HEADER Time fsecondsToTime (double t) +{ + return (Time)(t * TIME_RESOLUTION); +} + +/* ----------------------------------------------------------------------------- Include everything STG-ish -------------------------------------------------------------------------- */ diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index 2d1516f586..439b261fd8 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -52,7 +52,7 @@ struct GC_FLAGS { rtsBool ringBell; rtsBool frontpanel; - int idleGCDelayTime; /* in milliseconds */ + Time idleGCDelayTime; /* units: TIME_RESOLUTION */ StgWord heapBase; /* address to ask the OS for memory */ }; @@ -99,8 +99,8 @@ struct PROFILING_FLAGS { # define HEAP_BY_CLOSURE_TYPE 8 - nat profileInterval; /* delta between samples (in ms) */ - nat profileIntervalTicks; /* delta between samples (in 'ticks') */ + Time heapProfileInterval; /* time between samples */ + nat heapProfileIntervalTicks; /* ticks between samples (derived) */ rtsBool includeTSOs; @@ -135,12 +135,21 @@ struct TRACE_FLAGS { }; struct CONCURRENT_FLAGS { - int ctxtSwitchTime; /* in milliseconds */ - int ctxtSwitchTicks; /* derived */ + Time ctxtSwitchTime; /* units: TIME_RESOLUTION */ + int ctxtSwitchTicks; /* derived */ }; +/* + * The tickInterval is the time interval between "ticks", ie. + * timer signals (see Timer.{c,h}). It is the frequency at + * which we sample CCCS for profiling. + * + * It is changed by the +RTS -V<secs> flag. + */ +#define DEFAULT_TICK_INTERVAL USToTime(10000) + struct MISC_FLAGS { - int tickInterval; /* in milliseconds */ + Time tickInterval; /* units: TIME_RESOLUTION */ rtsBool install_signal_handlers; rtsBool machineReadable; StgWord linkerMemBase; /* address to ask the OS for memory diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h index 04e673fb12..20c6ebf4f2 100644 --- a/includes/rts/storage/TSO.h +++ b/includes/rts/storage/TSO.h @@ -54,7 +54,13 @@ typedef union { #if defined(mingw32_HOST_OS) StgAsyncIOResult *async_result; #endif +#if !defined(THREADED_RTS) StgWord target; + // Only for the non-threaded RTS: the target time for a thread + // blocked in threadDelay, in units of 10ms. This is a + // compromise: we don't want to take up much space in the TSO. If + // you want better resolution for threadDelay, use -threaded. +#endif } StgTSOBlockInfo; diff --git a/mk/config.mk.in b/mk/config.mk.in index 583bc472c5..f45404abdf 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -118,6 +118,7 @@ SharedLibsPlatformList = \ i386-unknown-linux x86_64-unknown-linux \ i386-unknown-freebsd x86_64-unknown-freebsd \ i386-unknown-openbsd x86_64-unknown-openbsd \ + i386-unknown-netbsd x86_64-unknown-netbsd \ i386-unknown-mingw32 \ i386-apple-darwin x86_64-apple-darwin powerpc-apple-darwin diff --git a/rts/GetTime.h b/rts/GetTime.h index b8d402db7c..86c5511df9 100644 --- a/rts/GetTime.h +++ b/rts/GetTime.h @@ -11,16 +11,10 @@ #include "BeginPrivate.h" -// We'll use a fixed resolution of usec for now. The machine -// dependent implementation may have a different resolution, but we'll -// normalise to this for the machine independent interface. -#define TICKS_PER_SECOND 1000000 -typedef StgInt64 Ticks; - -Ticks getProcessCPUTime (void); -Ticks getThreadCPUTime (void); -Ticks getProcessElapsedTime (void); -void getProcessTimes (Ticks *user, Ticks *elapsed); +Time getProcessCPUTime (void); +Time getThreadCPUTime (void); +Time getProcessElapsedTime (void); +void getProcessTimes (Time *user, Time *elapsed); /* Get the current date and time. Uses seconds since the Unix epoch, plus nanoseconds diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 85920932c9..8836d3bfe6 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1785,16 +1785,13 @@ stg_delayzh #else + W_ time; - W_ divisor; (time) = foreign "C" getourtimeofday() [R1]; - divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags)); - if (divisor == 0) { - divisor = 50; - } - divisor = divisor * 1000; - target = ((R1 + divisor - 1) / divisor) /* divide rounding up */ - + time + 1; /* Add 1 as getourtimeofday rounds down */ + // getourtimeofday() returns a value in units of 10ms + // R1 is in microseconds, we need to (/ 10000), rounding up + target = time + 1 + (R1 + 10000-1) / 10000; + StgTSO_block_info(CurrentTSO) = target; /* Insert the new thread in the sleeping queue. */ diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 56c44519fb..302d1d7997 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -1070,8 +1070,7 @@ heapCensusChain( Census *census, bdescr *bd ) } } -void -heapCensus( Ticks t ) +void heapCensus (Time t) { nat g, n; Census *census; diff --git a/rts/ProfHeap.h b/rts/ProfHeap.h index cf09c59231..b3bed903b5 100644 --- a/rts/ProfHeap.h +++ b/rts/ProfHeap.h @@ -9,11 +9,9 @@ #ifndef PROFHEAP_H #define PROFHEAP_H -#include "GetTime.h" // for Ticks - #include "BeginPrivate.h" -void heapCensus (Ticks t); +void heapCensus (Time t); nat initHeapProfiling (void); void endHeapProfiling (void); rtsBool strMatchesSelector (char* str, char* sel); diff --git a/rts/Profiling.c b/rts/Profiling.c index 38191ff4bd..c393c8fa83 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -801,11 +801,11 @@ reportCCSProfiling( void ) fprintf(prof_file, " %s", prog_argv[count]); fprintf(prof_file, "\n\n"); - fprintf(prof_file, "\ttotal time = %11.2f secs (%lu ticks @ %d ms)\n", - (double) total_prof_ticks * - (double) RtsFlags.MiscFlags.tickInterval / 1000, + fprintf(prof_file, "\ttotal time = %11.2f secs (%lu ticks @ %d us)\n", + ((double) total_prof_ticks * + (double) RtsFlags.MiscFlags.tickInterval) / TIME_RESOLUTION, (unsigned long) total_prof_ticks, - (int) RtsFlags.MiscFlags.tickInterval); + (int) TimeToUS(RtsFlags.MiscFlags.tickInterval)); fprintf(prof_file, "\ttotal alloc = %11s bytes", showStgWord64(total_alloc * sizeof(W_), diff --git a/rts/Proftimer.c b/rts/Proftimer.c index 82838184b7..76d7679000 100644 --- a/rts/Proftimer.c +++ b/rts/Proftimer.c @@ -50,7 +50,7 @@ void startHeapProfTimer( void ) { if (RtsFlags.ProfFlags.doHeapProfile && - RtsFlags.ProfFlags.profileIntervalTicks > 0) { + RtsFlags.ProfFlags.heapProfileIntervalTicks > 0) { do_heap_prof_ticks = rtsTrue; } } @@ -60,7 +60,7 @@ initProfTimer( void ) { performHeapProfile = rtsFalse; - ticks_to_heap_profile = RtsFlags.ProfFlags.profileIntervalTicks; + ticks_to_heap_profile = RtsFlags.ProfFlags.heapProfileIntervalTicks; startHeapProfTimer(); } @@ -80,7 +80,7 @@ handleProfTick(void) if (do_heap_prof_ticks) { ticks_to_heap_profile--; if (ticks_to_heap_profile <= 0) { - ticks_to_heap_profile = RtsFlags.ProfFlags.profileIntervalTicks; + ticks_to_heap_profile = RtsFlags.ProfFlags.heapProfileIntervalTicks; performHeapProfile = rtsTrue; } } diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index d8bcf1c915..3e3290dd3d 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -113,7 +113,7 @@ void initRtsFlagsDefaults(void) #ifdef RTS_GTK_FRONTPANEL RtsFlags.GcFlags.frontpanel = rtsFalse; #endif - RtsFlags.GcFlags.idleGCDelayTime = 300; /* millisecs */ + RtsFlags.GcFlags.idleGCDelayTime = USToTime(300000); // 300ms #if osf3_HOST_OS /* ToDo: Perhaps by adjusting this value we can make linking without @@ -150,7 +150,7 @@ void initRtsFlagsDefaults(void) #endif /* PROFILING */ RtsFlags.ProfFlags.doHeapProfile = rtsFalse; - RtsFlags.ProfFlags.profileInterval = 100; + RtsFlags.ProfFlags. heapProfileInterval = USToTime(100000); // 100ms #ifdef PROFILING RtsFlags.ProfFlags.includeTSOs = rtsFalse; @@ -176,8 +176,13 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.user = rtsFalse; #endif - RtsFlags.MiscFlags.tickInterval = 20; /* In milliseconds */ - RtsFlags.ConcFlags.ctxtSwitchTime = 20; /* In milliseconds */ +#ifdef PROFILING + // When profiling we want a lot more ticks + RtsFlags.MiscFlags.tickInterval = USToTime(1000); // 1ms +#else + RtsFlags.MiscFlags.tickInterval = DEFAULT_TICK_INTERVAL; +#endif + RtsFlags.ConcFlags.ctxtSwitchTime = USToTime(20000); // 20ms RtsFlags.MiscFlags.install_signal_handlers = rtsTrue; RtsFlags.MiscFlags.machineReadable = rtsFalse; @@ -312,9 +317,9 @@ usage_text[] = { #if !defined(PROFILING) "", -" -hT Heap residency profile (output file <program>.hp)", +" -h Heap residency profile (output file <program>.hp)", #endif -" -i<sec> Time between heap samples (seconds, default: 0.1)", +" -i<sec> Time between heap profile samples (seconds, default: 0.1)", "", #if defined(TICKY_TICKY) " -r<file> Produce ticky-ticky statistics (with -rstderr for stderr)", @@ -322,10 +327,15 @@ usage_text[] = { #endif " -C<secs> Context-switch interval in seconds.", " 0 or no argument means switch as often as possible.", -" Default: 0.02 sec; resolution is set by -V below.", -" -V<secs> Master tick interval in seconds (0 == disable timer).", -" This sets the resolution for -C and the profile timer -i.", " Default: 0.02 sec.", +" -V<secs> Master tick interval in seconds (0 == disable timer).", +" This sets the resolution for -C and the heap profile timer -i,", +" and is the frequence of time profile samples.", +#ifdef PROFILING +" Default: 0.001 sec.", +#else +" Default: 0.01 sec.", +#endif "", #if defined(DEBUG) " -Ds DEBUG: scheduler", @@ -884,11 +894,8 @@ error = rtsTrue; if (rts_argv[arg][2] == '\0') { /* use default */ } else { - I_ cst; /* tmp */ - - /* Convert to millisecs */ - cst = (I_) ((atof(rts_argv[arg]+2) * 1000)); - RtsFlags.GcFlags.idleGCDelayTime = cst; + RtsFlags.GcFlags.idleGCDelayTime = + fsecondsToTime(atof(rts_argv[arg]+2)); } break; @@ -1090,12 +1097,9 @@ error = rtsTrue; if (rts_argv[arg][2] == '\0') { /* use default */ } else { - I_ cst; /* tmp */ - - /* Convert to milliseconds */ - cst = (I_) ((atof(rts_argv[arg]+2) * 1000)); - RtsFlags.ProfFlags.profileInterval = cst; - } + RtsFlags.ProfFlags.heapProfileInterval = + fsecondsToTime(atof(rts_argv[arg]+2)); + } break; /* =========== CONCURRENT ========================= */ @@ -1104,12 +1108,9 @@ error = rtsTrue; if (rts_argv[arg][2] == '\0') RtsFlags.ConcFlags.ctxtSwitchTime = 0; else { - I_ cst; /* tmp */ - - /* Convert to milliseconds */ - cst = (I_) ((atof(rts_argv[arg]+2) * 1000)); - RtsFlags.ConcFlags.ctxtSwitchTime = cst; - } + RtsFlags.ConcFlags.ctxtSwitchTime = + fsecondsToTime(atof(rts_argv[arg]+2)); + } break; case 'V': /* master tick interval */ @@ -1118,11 +1119,8 @@ error = rtsTrue; // turns off ticks completely RtsFlags.MiscFlags.tickInterval = 0; } else { - I_ cst; /* tmp */ - - /* Convert to milliseconds */ - cst = (I_) ((atof(rts_argv[arg]+2) * 1000)); - RtsFlags.MiscFlags.tickInterval = cst; + RtsFlags.MiscFlags.tickInterval = + fsecondsToTime(atof(rts_argv[arg]+2)); } break; @@ -1358,14 +1356,14 @@ error = rtsTrue; static void normaliseRtsOpts (void) { if (RtsFlags.MiscFlags.tickInterval < 0) { - RtsFlags.MiscFlags.tickInterval = 50; + RtsFlags.MiscFlags.tickInterval = DEFAULT_TICK_INTERVAL; } // If the master timer is disabled, turn off the other timers. if (RtsFlags.MiscFlags.tickInterval == 0) { RtsFlags.ConcFlags.ctxtSwitchTime = 0; RtsFlags.GcFlags.idleGCDelayTime = 0; - RtsFlags.ProfFlags.profileInterval = 0; + RtsFlags.ProfFlags.heapProfileInterval = 0; } // Determine what tick interval we should use for the RTS timer @@ -1383,9 +1381,9 @@ static void normaliseRtsOpts (void) RtsFlags.MiscFlags.tickInterval); } - if (RtsFlags.ProfFlags.profileInterval > 0) { + if (RtsFlags.ProfFlags.heapProfileInterval > 0) { RtsFlags.MiscFlags.tickInterval = - stg_min(RtsFlags.ProfFlags.profileInterval, + stg_min(RtsFlags.ProfFlags.heapProfileInterval, RtsFlags.MiscFlags.tickInterval); } @@ -1397,12 +1395,12 @@ static void normaliseRtsOpts (void) RtsFlags.ConcFlags.ctxtSwitchTicks = 0; } - if (RtsFlags.ProfFlags.profileInterval > 0) { - RtsFlags.ProfFlags.profileIntervalTicks = - RtsFlags.ProfFlags.profileInterval / + if (RtsFlags.ProfFlags.heapProfileInterval > 0) { + RtsFlags.ProfFlags.heapProfileIntervalTicks = + RtsFlags.ProfFlags.heapProfileInterval / RtsFlags.MiscFlags.tickInterval; } else { - RtsFlags.ProfFlags.profileIntervalTicks = 0; + RtsFlags.ProfFlags.heapProfileIntervalTicks = 0; } if (RtsFlags.GcFlags.stkChunkBufferSize > diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index c09d5ed61d..c451292012 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -431,7 +431,7 @@ static void flushStdHandles(void) { Capability *cap; cap = rts_lock(); - rts_evalIO(cap, flushStdHandles_closure, NULL); + cap = rts_evalIO(cap, flushStdHandles_closure, NULL); rts_unlock(cap); } diff --git a/rts/RtsUtils.c b/rts/RtsUtils.c index 8ef6c0d6f2..e04b9846be 100644 --- a/rts/RtsUtils.c +++ b/rts/RtsUtils.c @@ -272,7 +272,7 @@ heapCheckFail( void ) * genericRaise(), rather than raise(3). */ int genericRaise(int sig) { -#if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)) +#if defined(THREADED_RTS) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS)) return pthread_kill(pthread_self(), sig); #else return raise(sig); diff --git a/rts/Schedule.c b/rts/Schedule.c index 4f18209b9e..8c305008ae 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1304,7 +1304,7 @@ scheduleNeedHeapProfile( rtsBool ready_to_gc STG_UNUSED ) // When we have +RTS -i0 and we're heap profiling, do a census at // every GC. This lets us get repeatable runs for debugging. if (performHeapProfile || - (RtsFlags.ProfFlags.profileInterval==0 && + (RtsFlags.ProfFlags.heapProfileInterval==0 && RtsFlags.ProfFlags.doHeapProfile && ready_to_gc)) { return rtsTrue; } else { diff --git a/rts/Stats.c b/rts/Stats.c index 23cb4bffaa..9c68364717 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -26,15 +26,15 @@ /* huh? */ #define BIG_STRING_LEN 512 -#define TICK_TO_DBL(t) ((double)(t) / TICKS_PER_SECOND) +#define TimeToSecondsDbl(t) ((double)(t) / TIME_RESOLUTION) -static Ticks +static Time start_init_cpu, start_init_elapsed, end_init_cpu, end_init_elapsed, start_exit_cpu, start_exit_elapsed, end_exit_cpu, end_exit_elapsed; -static Ticks GC_tot_cpu = 0; +static Time GC_tot_cpu = 0; static StgWord64 GC_tot_alloc = 0; static StgWord64 GC_tot_copied = 0; @@ -43,11 +43,11 @@ static StgWord64 GC_par_max_copied = 0; static StgWord64 GC_par_avg_copied = 0; #ifdef PROFILING -static Ticks RP_start_time = 0, RP_tot_time = 0; // retainer prof user time -static Ticks RPe_start_time = 0, RPe_tot_time = 0; // retainer prof elap time +static Time RP_start_time = 0, RP_tot_time = 0; // retainer prof user time +static Time RPe_start_time = 0, RPe_tot_time = 0; // retainer prof elap time -static Ticks HC_start_time, HC_tot_time = 0; // heap census prof user time -static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time +static Time HC_start_time, HC_tot_time = 0; // heap census prof user time +static Time HCe_start_time, HCe_tot_time = 0; // heap census prof elap time #endif #ifdef PROFILING @@ -66,9 +66,9 @@ static lnat max_slop = 0; static lnat GC_end_faults = 0; -static Ticks *GC_coll_cpu = NULL; -static Ticks *GC_coll_elapsed = NULL; -static Ticks *GC_coll_max_pause = NULL; +static Time *GC_coll_cpu = NULL; +static Time *GC_coll_elapsed = NULL; +static Time *GC_coll_max_pause = NULL; static void statsFlush( void ); static void statsClose( void ); @@ -77,7 +77,7 @@ static void statsClose( void ); Current elapsed time ------------------------------------------------------------------------- */ -Ticks stat_getElapsedTime(void) +Time stat_getElapsedTime(void) { return getProcessElapsedTime() - start_init_elapsed; } @@ -87,9 +87,9 @@ Ticks stat_getElapsedTime(void) ------------------------------------------------------------------------ */ double -mut_user_time_until( Ticks t ) +mut_user_time_until( Time t ) { - return TICK_TO_DBL(t - GC_tot_cpu); + return TimeToSecondsDbl(t - GC_tot_cpu); // heapCensus() time is included in GC_tot_cpu, so we don't need // to subtract it here. } @@ -97,7 +97,7 @@ mut_user_time_until( Ticks t ) double mut_user_time( void ) { - Ticks cpu; + Time cpu; cpu = getProcessCPUTime(); return mut_user_time_until(cpu); } @@ -110,13 +110,13 @@ mut_user_time( void ) double mut_user_time_during_RP( void ) { - return TICK_TO_DBL(RP_start_time - GC_tot_cpu - RP_tot_time); + return TimeToSecondsDbl(RP_start_time - GC_tot_cpu - RP_tot_time); } double mut_user_time_during_heap_census( void ) { - return TICK_TO_DBL(HC_start_time - GC_tot_cpu - RP_tot_time); + return TimeToSecondsDbl(HC_start_time - GC_tot_cpu - RP_tot_time); } #endif /* PROFILING */ @@ -177,16 +177,16 @@ initStats1 (void) statsPrintf(" bytes bytes bytes user elap user elap\n"); } GC_coll_cpu = - (Ticks *)stgMallocBytes( - sizeof(Ticks)*RtsFlags.GcFlags.generations, + (Time *)stgMallocBytes( + sizeof(Time)*RtsFlags.GcFlags.generations, "initStats"); GC_coll_elapsed = - (Ticks *)stgMallocBytes( - sizeof(Ticks)*RtsFlags.GcFlags.generations, + (Time *)stgMallocBytes( + sizeof(Time)*RtsFlags.GcFlags.generations, "initStats"); GC_coll_max_pause = - (Ticks *)stgMallocBytes( - sizeof(Ticks)*RtsFlags.GcFlags.generations, + (Time *)stgMallocBytes( + sizeof(Time)*RtsFlags.GcFlags.generations, "initStats"); for (i = 0; i < RtsFlags.GcFlags.generations; i++) { GC_coll_cpu[i] = 0; @@ -299,7 +299,7 @@ stat_gcWorkerThreadStart (gc_thread *gct) void stat_gcWorkerThreadDone (gc_thread *gct) { - Ticks thread_cpu, elapsed, gc_cpu, gc_elapsed; + Time thread_cpu, elapsed, gc_cpu, gc_elapsed; if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) { @@ -326,7 +326,7 @@ stat_endGC (gc_thread *gct, RtsFlags.ProfFlags.doHeapProfile) // heap profiling needs GC_tot_time { - Ticks cpu, elapsed, thread_gc_cpu, gc_cpu, gc_elapsed; + Time cpu, elapsed, thread_gc_cpu, gc_cpu, gc_elapsed; getProcessTimes(&cpu, &elapsed); gc_elapsed = elapsed - gct->gc_start_elapsed; @@ -344,10 +344,10 @@ stat_endGC (gc_thread *gct, alloc*sizeof(W_), copied*sizeof(W_), live*sizeof(W_)); statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2d)\n", - TICK_TO_DBL(gc_cpu), - TICK_TO_DBL(gc_elapsed), - TICK_TO_DBL(cpu), - TICK_TO_DBL(elapsed - start_init_elapsed), + TimeToSecondsDbl(gc_cpu), + TimeToSecondsDbl(gc_elapsed), + TimeToSecondsDbl(cpu), + TimeToSecondsDbl(elapsed - start_init_elapsed), faults - gct->gc_start_faults, gct->gc_start_faults - GC_end_faults, gen); @@ -405,7 +405,7 @@ stat_endGC (gc_thread *gct, void stat_startRP(void) { - Ticks user, elapsed; + Time user, elapsed; getProcessTimes( &user, &elapsed ); RP_start_time = user; @@ -427,7 +427,7 @@ stat_endRP( #endif double averageNumVisit) { - Ticks user, elapsed; + Time user, elapsed; getProcessTimes( &user, &elapsed ); RP_tot_time += user - RP_start_time; @@ -450,7 +450,7 @@ stat_endRP( void stat_startHeapCensus(void) { - Ticks user, elapsed; + Time user, elapsed; getProcessTimes( &user, &elapsed ); HC_start_time = user; @@ -465,7 +465,7 @@ stat_startHeapCensus(void) void stat_endHeapCensus(void) { - Ticks user, elapsed; + Time user, elapsed; getProcessTimes( &user, &elapsed ); HC_tot_time += user - HC_start_time; @@ -516,27 +516,27 @@ StgInt TOTAL_CALLS=1; statsPrintf(" (SLOW_CALLS_" #arity ") %% of (TOTAL_CALLS) : %.1f%%\n", \ SLOW_CALLS_##arity * 100.0/TOTAL_CALLS) -static inline Ticks get_init_cpu(void) { return end_init_cpu - start_init_cpu; } -static inline Ticks get_init_elapsed(void) { return end_init_elapsed - start_init_elapsed; } +static inline Time get_init_cpu(void) { return end_init_cpu - start_init_cpu; } +static inline Time get_init_elapsed(void) { return end_init_elapsed - start_init_elapsed; } void stat_exit(int alloc) { generation *gen; - Ticks gc_cpu = 0; - Ticks gc_elapsed = 0; - Ticks init_cpu = 0; - Ticks init_elapsed = 0; - Ticks mut_cpu = 0; - Ticks mut_elapsed = 0; - Ticks exit_cpu = 0; - Ticks exit_elapsed = 0; + Time gc_cpu = 0; + Time gc_elapsed = 0; + Time init_cpu = 0; + Time init_elapsed = 0; + Time mut_cpu = 0; + Time mut_elapsed = 0; + Time exit_cpu = 0; + Time exit_elapsed = 0; if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) { char temp[BIG_STRING_LEN]; - Ticks tot_cpu; - Ticks tot_elapsed; + Time tot_cpu; + Time tot_elapsed; nat i, g, total_collections = 0; getProcessTimes( &tot_cpu, &tot_elapsed ); @@ -611,10 +611,10 @@ stat_exit(int alloc) gen->no, gen->collections, gen->par_collections, - TICK_TO_DBL(GC_coll_cpu[g]), - TICK_TO_DBL(GC_coll_elapsed[g]), - gen->collections == 0 ? 0 : TICK_TO_DBL(GC_coll_elapsed[g] / gen->collections), - TICK_TO_DBL(GC_coll_max_pause[g])); + TimeToSecondsDbl(GC_coll_cpu[g]), + TimeToSecondsDbl(GC_coll_elapsed[g]), + gen->collections == 0 ? 0 : TimeToSecondsDbl(GC_coll_elapsed[g] / gen->collections), + TimeToSecondsDbl(GC_coll_max_pause[g])); } #if defined(THREADED_RTS) @@ -639,10 +639,10 @@ stat_exit(int alloc) statsPrintf(" Task %2d %-8s : %6.2fs (%6.2fs) %6.2fs (%6.2fs)\n", i, (task->worker) ? "(worker)" : "(bound)", - TICK_TO_DBL(task->mut_time), - TICK_TO_DBL(task->mut_etime), - TICK_TO_DBL(task->gc_time), - TICK_TO_DBL(task->gc_etime)); + TimeToSecondsDbl(task->mut_time), + TimeToSecondsDbl(task->mut_etime), + TimeToSecondsDbl(task->gc_time), + TimeToSecondsDbl(task->gc_etime)); } } @@ -668,27 +668,27 @@ stat_exit(int alloc) #endif statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed)); + TimeToSecondsDbl(init_cpu), TimeToSecondsDbl(init_elapsed)); statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed)); + TimeToSecondsDbl(mut_cpu), TimeToSecondsDbl(mut_elapsed)); statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(gc_cpu), TICK_TO_DBL(gc_elapsed)); + TimeToSecondsDbl(gc_cpu), TimeToSecondsDbl(gc_elapsed)); #ifdef PROFILING statsPrintf(" RP time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(RP_tot_time), TICK_TO_DBL(RPe_tot_time)); + TimeToSecondsDbl(RP_tot_time), TimeToSecondsDbl(RPe_tot_time)); statsPrintf(" PROF time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(HC_tot_time), TICK_TO_DBL(HCe_tot_time)); + TimeToSecondsDbl(HC_tot_time), TimeToSecondsDbl(HCe_tot_time)); #endif statsPrintf(" EXIT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(exit_cpu), TICK_TO_DBL(exit_elapsed)); + TimeToSecondsDbl(exit_cpu), TimeToSecondsDbl(exit_elapsed)); statsPrintf(" Total time %6.2fs (%6.2fs elapsed)\n\n", - TICK_TO_DBL(tot_cpu), TICK_TO_DBL(tot_elapsed)); + TimeToSecondsDbl(tot_cpu), TimeToSecondsDbl(tot_elapsed)); #ifndef THREADED_RTS statsPrintf(" %%GC time %5.1f%% (%.1f%% elapsed)\n\n", - TICK_TO_DBL(gc_cpu)*100/TICK_TO_DBL(tot_cpu), - TICK_TO_DBL(gc_elapsed)*100/TICK_TO_DBL(tot_elapsed)); + TimeToSecondsDbl(gc_cpu)*100/TimeToSecondsDbl(tot_cpu), + TimeToSecondsDbl(gc_elapsed)*100/TimeToSecondsDbl(tot_elapsed)); #endif if (tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time) == 0) @@ -696,19 +696,19 @@ stat_exit(int alloc) else showStgWord64( (StgWord64)((GC_tot_alloc*sizeof(W_))/ - TICK_TO_DBL(tot_cpu - GC_tot_cpu - + TimeToSecondsDbl(tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time))), temp, rtsTrue/*commas*/); statsPrintf(" Alloc rate %s bytes per MUT second\n\n", temp); statsPrintf(" Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n", - TICK_TO_DBL(tot_cpu - GC_tot_cpu - + TimeToSecondsDbl(tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time) - init_cpu) * 100 - / TICK_TO_DBL(tot_cpu), - TICK_TO_DBL(tot_cpu - GC_tot_cpu - + / TimeToSecondsDbl(tot_cpu), + TimeToSecondsDbl(tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time) - init_cpu) * 100 - / TICK_TO_DBL(tot_elapsed)); + / TimeToSecondsDbl(tot_elapsed)); /* TICK_PRINT(1); @@ -764,9 +764,9 @@ stat_exit(int alloc) max_residency*sizeof(W_), residency_samples, (unsigned long)(peak_mblocks_allocated * MBLOCK_SIZE / (1024L * 1024L)), - TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed), - TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed), - TICK_TO_DBL(gc_cpu), TICK_TO_DBL(gc_elapsed)); + TimeToSecondsDbl(init_cpu), TimeToSecondsDbl(init_elapsed), + TimeToSecondsDbl(mut_cpu), TimeToSecondsDbl(mut_elapsed), + TimeToSecondsDbl(gc_cpu), TimeToSecondsDbl(gc_elapsed)); } statsFlush(); @@ -865,10 +865,10 @@ extern void getGCStats( GCStats *s ) { nat total_collections = 0; nat g; - Ticks gc_cpu = 0; - Ticks gc_elapsed = 0; - Ticks current_elapsed = 0; - Ticks current_cpu = 0; + Time gc_cpu = 0; + Time gc_elapsed = 0; + Time current_elapsed = 0; + Time current_cpu = 0; getProcessTimes(¤t_cpu, ¤t_elapsed); @@ -892,16 +892,16 @@ extern void getGCStats( GCStats *s ) s->current_bytes_used = current_residency*(StgWord64)sizeof(W_); s->current_bytes_slop = current_slop*(StgWord64)sizeof(W_); /* - s->init_cpu_seconds = TICK_TO_DBL(get_init_cpu()); - s->init_wall_seconds = TICK_TO_DBL(get_init_elapsed()); + s->init_cpu_seconds = TimeToSecondsDbl(get_init_cpu()); + s->init_wall_seconds = TimeToSecondsDbl(get_init_elapsed()); */ - s->mutator_cpu_seconds = TICK_TO_DBL(current_cpu - end_init_cpu - gc_cpu - PROF_VAL(RP_tot_time + HC_tot_time)); - s->mutator_wall_seconds = TICK_TO_DBL(current_elapsed- end_init_elapsed - gc_elapsed); - s->gc_cpu_seconds = TICK_TO_DBL(gc_cpu); - s->gc_wall_seconds = TICK_TO_DBL(gc_elapsed); + s->mutator_cpu_seconds = TimeToSecondsDbl(current_cpu - end_init_cpu - gc_cpu - PROF_VAL(RP_tot_time + HC_tot_time)); + s->mutator_wall_seconds = TimeToSecondsDbl(current_elapsed- end_init_elapsed - gc_elapsed); + s->gc_cpu_seconds = TimeToSecondsDbl(gc_cpu); + s->gc_wall_seconds = TimeToSecondsDbl(gc_elapsed); /* EZY: Being consistent with incremental output, but maybe should also discount init */ - s->cpu_seconds = TICK_TO_DBL(current_cpu); - s->wall_seconds = TICK_TO_DBL(current_elapsed - end_init_elapsed); + s->cpu_seconds = TimeToSecondsDbl(current_cpu); + s->wall_seconds = TimeToSecondsDbl(current_elapsed - end_init_elapsed); s->par_avg_bytes_copied = GC_par_avg_copied*(StgWord64)sizeof(W_); s->par_max_bytes_copied = GC_par_max_copied*(StgWord64)sizeof(W_); } diff --git a/rts/Stats.h b/rts/Stats.h index f0060bdf4a..83b2cb6998 100644 --- a/rts/Stats.h +++ b/rts/Stats.h @@ -49,7 +49,7 @@ void stat_workerStop(void); void initStats0(void); void initStats1(void); -double mut_user_time_until(Ticks t); +double mut_user_time_until(Time t); double mut_user_time(void); #ifdef PROFILING @@ -59,8 +59,8 @@ double mut_user_time_during_heap_census(void); void statDescribeGens( void ); -Ticks stat_getElapsedGCTime(void); -Ticks stat_getElapsedTime(void); +Time stat_getElapsedGCTime(void); +Time stat_getElapsedTime(void); /* Only exported for Papi.c */ void statsPrintf( char *s, ... ) diff --git a/rts/Task.c b/rts/Task.c index 9e8214899c..d72d8a9085 100644 --- a/rts/Task.c +++ b/rts/Task.c @@ -165,7 +165,7 @@ static Task* newTask (rtsBool worker) { #if defined(THREADED_RTS) - Ticks currentElapsedTime, currentUserTime; + Time currentElapsedTime, currentUserTime; #endif Task *task; @@ -329,7 +329,7 @@ void taskTimeStamp (Task *task USED_IF_THREADS) { #if defined(THREADED_RTS) - Ticks currentElapsedTime, currentUserTime; + Time currentElapsedTime, currentUserTime; currentUserTime = getThreadCPUTime(); currentElapsedTime = getProcessElapsedTime(); @@ -347,7 +347,7 @@ taskTimeStamp (Task *task USED_IF_THREADS) } void -taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time) +taskDoneGC (Task *task, Time cpu_time, Time elapsed_time) { task->gc_time += cpu_time; task->gc_etime += elapsed_time; diff --git a/rts/Task.h b/rts/Task.h index 4000a045d4..386e003d28 100644 --- a/rts/Task.h +++ b/rts/Task.h @@ -149,12 +149,12 @@ typedef struct Task_ { // really want separate stats for each call in a nested chain of // foreign->haskell->foreign->haskell calls, but we'll get a // separate Task for each of the haskell calls. - Ticks elapsedtimestart; - Ticks muttimestart; - Ticks mut_time; - Ticks mut_etime; - Ticks gc_time; - Ticks gc_etime; + Time elapsedtimestart; + Time muttimestart; + Time mut_time; + Time mut_etime; + Time gc_time; + Time gc_etime; // Links tasks on the returning_tasks queue of a Capability, and // on spare_workers. @@ -208,7 +208,7 @@ void workerTaskStop (Task *task); void taskTimeStamp (Task *task); // The current Task has finished a GC, record the amount of time spent. -void taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time); +void taskDoneGC (Task *task, Time cpu_time, Time elapsed_time); // Put the task back on the free list, mark it stopped. Used by // forkProcess(). diff --git a/rts/Threads.c b/rts/Threads.c index 3e1c5cff0b..7e660d63f6 100644 --- a/rts/Threads.c +++ b/rts/Threads.c @@ -701,20 +701,22 @@ void printThreadBlockage(StgTSO *tso) { switch (tso->why_blocked) { +#if defined(mingw32_HOST_OS) + case BlockedOnDoProc: + debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID); + break; +#endif +#if !defined(THREADED_RTS) case BlockedOnRead: debugBelch("is blocked on read from fd %d", (int)(tso->block_info.fd)); break; case BlockedOnWrite: debugBelch("is blocked on write to fd %d", (int)(tso->block_info.fd)); break; -#if defined(mingw32_HOST_OS) - case BlockedOnDoProc: - debugBelch("is blocked on proc (request: %u)", tso->block_info.async_result->reqID); - break; -#endif case BlockedOnDelay: debugBelch("is blocked until %ld", (long)(tso->block_info.target)); break; +#endif case BlockedOnMVar: debugBelch("is blocked on an MVar @ %p", tso->block_info.closure); break; diff --git a/rts/Ticker.h b/rts/Ticker.h index 5804501da5..685a79e5d2 100644 --- a/rts/Ticker.h +++ b/rts/Ticker.h @@ -13,7 +13,7 @@ typedef void (*TickProc)(int); -void initTicker (nat ms, TickProc handle_tick); +void initTicker (Time interval, TickProc handle_tick); void startTicker (void); void stopTicker (void); void exitTicker (rtsBool wait); diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index 2e2209d2d3..88fc64010d 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -149,7 +149,7 @@ static inline void postBuf(EventsBuf *eb, StgWord8 *buf, nat size) } static inline StgWord64 time_ns(void) -{ return stat_getElapsedTime() * (1000000000LL/TICKS_PER_SECOND); } +{ return TimeToNS(stat_getElapsedTime()); } static inline void postEventTypeNum(EventsBuf *eb, EventTypeNum etNum) { postWord16(eb, etNum); } diff --git a/rts/posix/GetTime.c b/rts/posix/GetTime.c index eab7177fe5..c31b319af4 100644 --- a/rts/posix/GetTime.c +++ b/rts/posix/GetTime.c @@ -44,7 +44,7 @@ // we'll implement getProcessCPUTime() and getProcessElapsedTime() // separately, using getrusage() and gettimeofday() respectively -Ticks getProcessCPUTime(void) +Time getProcessCPUTime(void) { #if !defined(BE_CONSERVATIVE) && defined(HAVE_CLOCK_GETTIME) && defined (_SC_CPUTIME) && defined(CLOCK_PROCESS_CPUTIME_ID) && defined(HAVE_SYSCONF) static int checked_sysconf = 0; @@ -59,8 +59,7 @@ Ticks getProcessCPUTime(void) int res; res = clock_gettime(CLOCK_PROCESS_CPUTIME_ID, &ts); if (res == 0) { - return ((Ticks)ts.tv_sec * TICKS_PER_SECOND + - ((Ticks)ts.tv_nsec * TICKS_PER_SECOND) / 1000000000); + return SecondsToTime(ts.tv_sec) + NSToTime(ts.tv_nsec); } } #endif @@ -69,20 +68,18 @@ Ticks getProcessCPUTime(void) { struct rusage t; getrusage(RUSAGE_SELF, &t); - return ((Ticks)t.ru_utime.tv_sec * TICKS_PER_SECOND + - ((Ticks)t.ru_utime.tv_usec * TICKS_PER_SECOND)/1000000); + return SecondsToTime(t.ru_utime.tv_sec) + USToTime(t.ru_utime.tv_usec); } } -Ticks getProcessElapsedTime(void) +Time getProcessElapsedTime(void) { struct timeval tv; gettimeofday(&tv, (struct timezone *) NULL); - return ((Ticks)tv.tv_sec * TICKS_PER_SECOND + - ((Ticks)tv.tv_usec * TICKS_PER_SECOND)/1000000); + return SecondsToTime(tv.tv_sec) + USToTime(tv.tv_usec); } -void getProcessTimes(Ticks *user, Ticks *elapsed) +void getProcessTimes(Time *user, Time *elapsed) { *user = getProcessCPUTime(); *elapsed = getProcessElapsedTime(); @@ -92,29 +89,29 @@ void getProcessTimes(Ticks *user, Ticks *elapsed) // we'll use the old times() API. -Ticks getProcessCPUTime(void) +Time getProcessCPUTime(void) { #if !defined(THREADED_RTS) && USE_PAPI long long usec; if ((usec = PAPI_get_virt_usec()) < 0) { barf("PAPI_get_virt_usec: %lld", usec); } - return ((usec * TICKS_PER_SECOND) / 1000000); + return USToTime(usec); #else - Ticks user, elapsed; + Time user, elapsed; getProcessTimes(&user,&elapsed); return user; #endif } -Ticks getProcessElapsedTime(void) +Time getProcessElapsedTime(void) { - Ticks user, elapsed; + Time user, elapsed; getProcessTimes(&user,&elapsed); return elapsed; } -void getProcessTimes(Ticks *user, Ticks *elapsed) +void getProcessTimes(Time *user, Time *elapsed) { static nat ClockFreq = 0; @@ -141,20 +138,20 @@ void getProcessTimes(Ticks *user, Ticks *elapsed) struct tms t; clock_t r = times(&t); - *user = (((Ticks)t.tms_utime * TICKS_PER_SECOND) / ClockFreq); - *elapsed = (((Ticks)r * TICKS_PER_SECOND) / ClockFreq); + *user = SecondsToTime(t.tms_utime) / ClockFreq; + *elapsed = SecondsToTime(r) / ClockFreq; } #endif // HAVE_TIMES -Ticks getThreadCPUTime(void) +Time getThreadCPUTime(void) { #if USE_PAPI long long usec; if ((usec = PAPI_get_virt_usec()) < 0) { barf("PAPI_get_virt_usec: %lld", usec); } - return ((usec * TICKS_PER_SECOND) / 1000000); + return USToTime(usec); #elif !defined(BE_CONSERVATIVE) && defined(HAVE_CLOCK_GETTIME) && defined (_SC_THREAD_CPUTIME) && defined(CLOCK_THREAD_CPUTIME_ID) && defined(HAVE_SYSCONF) { @@ -172,8 +169,7 @@ Ticks getThreadCPUTime(void) int res; res = clock_gettime(CLOCK_THREAD_CPUTIME_ID, &ts); if (res == 0) { - return ((Ticks)ts.tv_sec * TICKS_PER_SECOND + - ((Ticks)ts.tv_nsec * TICKS_PER_SECOND) / 1000000000); + return SecondsToTime(ts.tv_sec) + NSToTime(ts.tv_nsec); } } } diff --git a/rts/posix/Itimer.c b/rts/posix/Itimer.c index e46bb12546..ece54910c2 100644 --- a/rts/posix/Itimer.c +++ b/rts/posix/Itimer.c @@ -44,68 +44,52 @@ #include <string.h> -/* Major bogosity: - * - * In the threaded RTS, we can't set the virtual timer because the - * thread which has the virtual timer might be sitting waiting for a - * capability, and the virtual timer only ticks in CPU time. +/* + * We use a realtime timer by default. I found this much more + * reliable than a CPU timer: * - * So, possible solutions: + * Experiments with different frequences: using + * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32, + * 1000us has <1% impact on runtime + * 100us has ~2% impact on runtime + * 10us has ~40% impact on runtime * - * (1) tick in realtime. Not very good, because this ticker is used for - * profiling, and this will give us unreliable time profiling - * results. + * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32, + * I cannot get it to tick faster than 10ms (10000us) + * which isn't great for profiling. * - * (2) save/restore the virtual timer around excursions into STG land. - * Sounds great, but I tried it and the resolution of the virtual timer - * isn't good enough (on Linux) - most of our excursions fall - * within the timer's resolution and we never make any progress. - * - * (3) have a virtual timer in every OS thread. Might be reasonable, - * because most of the time there is only ever one of these - * threads running, so it approximates a single virtual timer. - * But still quite bogus (and I got crashes when I tried this). + * In the threaded RTS, we can't tick in CPU time because the thread + * which has the virtual timer might be idle, so the tick would never + * fire. Therfore we used to tick in realtime in the threaded RTS and + * in CPU time otherwise, but now we always tick in realtime, for + * several reasons: * - * For now, we're using (1), but this needs a better solution. --SDM + * - resolution (see above) + * - consistency (-threaded is the same as normal) + * - more consistency: Windows only has a realtime timer + * + * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME, + * because the latter may jump around (NTP adjustments, leap seconds + * etc.). */ #if defined(USE_TIMER_CREATE) - # define ITIMER_SIGNAL SIGVTALRM -# ifdef THREADED_RTS -# define TIMER_FLAVOUR CLOCK_REALTIME -# else -# define TIMER_FLAVOUR CLOCK_PROCESS_CPUTIME_ID -# endif - #elif defined(HAVE_SETITIMER) - -# if defined(THREADED_RTS) || !defined(HAVE_SETITIMER_VIRTUAL) -// Oh dear, we have to use SIGALRM if there's no timer_create and -// we're using the THREADED_RTS. This leads to problems, see bug #850. -// We also use it if we don't have a virtual timer (trac #2883). -# define ITIMER_SIGNAL SIGALRM -# define ITIMER_FLAVOUR ITIMER_REAL -# else -# define ITIMER_SIGNAL SIGVTALRM -# define ITIMER_FLAVOUR ITIMER_VIRTUAL -# endif - +# define ITIMER_SIGNAL SIGALRM + // Using SIGALRM can leads to problems, see #850. But we have no + // option if timer_create() is not available. #else - # error No way to set an interval timer. - #endif #if defined(USE_TIMER_CREATE) static timer_t timer; #endif -static nat itimer_interval = 50; +static Time itimer_interval = DEFAULT_TICK_INTERVAL; -static -void -install_vtalrm_handler(TickProc handle_tick) +static void install_vtalrm_handler(TickProc handle_tick) { struct sigaction action; @@ -132,32 +116,35 @@ install_vtalrm_handler(TickProc handle_tick) } void -initTicker (nat ms, TickProc handle_tick) +initTicker (Time interval, TickProc handle_tick) { - install_vtalrm_handler(handle_tick); - -#if !defined(THREADED_RTS) - timestamp = getourtimeofday(); -#endif - - itimer_interval = ms; + itimer_interval = interval; #if defined(USE_TIMER_CREATE) { struct sigevent ev; + clockid_t clock; - // Keep programs like valgrind happy + // Keep programs like valgrind happy memset(&ev, 0, sizeof(ev)); ev.sigev_notify = SIGEV_SIGNAL; ev.sigev_signo = ITIMER_SIGNAL; - if (timer_create(TIMER_FLAVOUR, &ev, &timer) != 0) { +#if defined(CLOCK_MONOTONIC) + clock = CLOCK_MONOTONIC; +#else + clock = CLOCK_REALTIME; +#endif + + if (timer_create(clock, &ev, &timer) != 0) { sysErrorBelch("timer_create"); stg_exit(EXIT_FAILURE); } } #endif + + install_vtalrm_handler(handle_tick); } void @@ -167,8 +154,8 @@ startTicker(void) { struct itimerspec it; - it.it_value.tv_sec = itimer_interval / 1000; - it.it_value.tv_nsec = (itimer_interval % 1000) * 1000000; + it.it_value.tv_sec = TimeToSeconds(itimer_interval); + it.it_value.tv_nsec = TimeToNS(itimer_interval); it.it_interval = it.it_value; if (timer_settime(timer, 0, &it, NULL) != 0) { @@ -180,11 +167,11 @@ startTicker(void) { struct itimerval it; - it.it_value.tv_sec = itimer_interval / 1000; - it.it_value.tv_usec = (itimer_interval % 1000) * 1000; + it.it_value.tv_sec = TimeToSeconds(itimer_interval); + it.it_value.tv_usec = TimeToUS(itimer_interval); it.it_interval = it.it_value; - if (setitimer(ITIMER_FLAVOUR, &it, NULL) != 0) { + if (setitimer(ITIMER_REAL, &it, NULL) != 0) { sysErrorBelch("setitimer"); stg_exit(EXIT_FAILURE); } @@ -213,7 +200,7 @@ stopTicker(void) it.it_value.tv_usec = 0; it.it_interval = it.it_value; - if (setitimer(ITIMER_FLAVOUR, &it, NULL) != 0) { + if (setitimer(ITIMER_REAL, &it, NULL) != 0) { sysErrorBelch("setitimer"); stg_exit(EXIT_FAILURE); } @@ -229,23 +216,6 @@ exitTicker (rtsBool wait STG_UNUSED) #endif } -/* gettimeofday() takes around 1us on our 500MHz PIII. Since we're - * only calling it 50 times/s, it shouldn't have any great impact. - */ -lnat -getourtimeofday(void) -{ - struct timeval tv; - nat interval; - interval = RtsFlags.MiscFlags.tickInterval; - if (interval == 0) { interval = 50; } - gettimeofday(&tv, (struct timezone *) NULL); - - // Avoid overflow when we multiply seconds by 1000. See #2848 - return (lnat)((StgWord64)tv.tv_sec * 1000 / interval + - (StgWord64)tv.tv_usec / (interval * 1000)); -} - int rtsTimerSignal(void) { diff --git a/rts/posix/Itimer.h b/rts/posix/Itimer.h index b67c8c442e..7996da7c94 100644 --- a/rts/posix/Itimer.h +++ b/rts/posix/Itimer.h @@ -9,6 +9,4 @@ #ifndef ITIMER_H #define ITIMER_H -RTS_PRIVATE lnat getourtimeofday ( void ); - #endif /* ITIMER_H */ diff --git a/rts/posix/Select.c b/rts/posix/Select.c index 3c87fbdc70..45737ce0cc 100644 --- a/rts/posix/Select.c +++ b/rts/posix/Select.c @@ -16,6 +16,7 @@ #include "Capability.h" #include "Select.h" #include "AwaitEvent.h" +#include "Stats.h" # ifdef HAVE_SYS_SELECT_H # include <sys/select.h> @@ -37,13 +38,24 @@ #endif #if !defined(THREADED_RTS) -/* last timestamp */ -lnat timestamp = 0; /* * The threaded RTS uses an IO-manager thread in Haskell instead (see GHC.Conc) */ +#define LowResTimeToTime(t) (USToTime((t) * 10000)) + +/* + * Return the time since the program started, in LowResTime, + * rounded down. + * + * This is only used by posix/Select.c. It should probably go away. + */ +LowResTime getourtimeofday(void) +{ + return TimeToUS(stat_getElapsedTime()) / 10000; +} + /* There's a clever trick here to avoid problems when the time wraps * around. Since our maximum delay is smaller than 31 bits of ticks * (it's actually 31 bits of microseconds), we can safely check @@ -55,15 +67,14 @@ lnat timestamp = 0; * if this is true, then our time has expired. * (idea due to Andy Gill). */ -static rtsBool -wakeUpSleepingThreads(lnat ticks) +static rtsBool wakeUpSleepingThreads (LowResTime now) { StgTSO *tso; rtsBool flag = rtsFalse; while (sleeping_queue != END_TSO_QUEUE) { tso = sleeping_queue; - if (((long)ticks - (long)tso->block_info.target) < 0) { + if (((long)now - (long)tso->block_info.target) < 0) { break; } sleeping_queue = tso->_link; @@ -108,7 +119,8 @@ awaitEvent(rtsBool wait) rtsBool select_succeeded = rtsTrue; rtsBool unblock_all = rtsFalse; struct timeval tv; - lnat min, ticks; + Time min; + LowResTime now; tv.tv_sec = 0; tv.tv_usec = 0; @@ -128,18 +140,17 @@ awaitEvent(rtsBool wait) */ do { - ticks = timestamp = getourtimeofday(); - if (wakeUpSleepingThreads(ticks)) { + now = getourtimeofday(); + if (wakeUpSleepingThreads(now)) { return; } if (!wait) { min = 0; } else if (sleeping_queue != END_TSO_QUEUE) { - min = (sleeping_queue->block_info.target - ticks) - * RtsFlags.MiscFlags.tickInterval * 1000; + min = LowResTimeToTime(sleeping_queue->block_info.target - now); } else { - min = 0x7ffffff; + min = (Time)-1; } /* @@ -185,8 +196,8 @@ awaitEvent(rtsBool wait) /* Check for any interesting events */ - tv.tv_sec = min / 1000000; - tv.tv_usec = min % 1000000; + tv.tv_sec = TimeToSeconds(min); + tv.tv_usec = TimeToUS(min) % 1000000; while ((numFound = select(maxfd+1, &rfd, &wfd, NULL, &tv)) < 0) { if (errno != EINTR) { @@ -236,7 +247,7 @@ awaitEvent(rtsBool wait) /* check for threads that need waking up */ - wakeUpSleepingThreads(getourtimeofday()); + wakeUpSleepingThreads(getourtimeofday()); /* If new runnable threads have arrived, stop waiting for * I/O and run them. diff --git a/rts/posix/Select.h b/rts/posix/Select.h index e92a4bc889..15fa00ac66 100644 --- a/rts/posix/Select.h +++ b/rts/posix/Select.h @@ -9,9 +9,9 @@ #ifndef POSIX_SELECT_H #define POSIX_SELECT_H -#if !defined(THREADED_RTS) -/* In Select.c */ -extern lnat timestamp; -#endif +// An absolute time value in units of 10ms. +typedef StgWord LowResTime; + +RTS_PRIVATE LowResTime getourtimeofday ( void ); #endif /* POSIX_SELECT_H */ diff --git a/rts/sm/GCThread.h b/rts/sm/GCThread.h index e42a3a1239..b4f325631f 100644 --- a/rts/sm/GCThread.h +++ b/rts/sm/GCThread.h @@ -181,9 +181,9 @@ typedef struct gc_thread_ { lnat no_work; lnat scav_find_work; - Ticks gc_start_cpu; // process CPU time - Ticks gc_start_elapsed; // process elapsed time - Ticks gc_start_thread_cpu; // thread CPU time + Time gc_start_cpu; // process CPU time + Time gc_start_elapsed; // process elapsed time + Time gc_start_thread_cpu; // thread CPU time lnat gc_start_faults; // ------------------- diff --git a/rts/win32/GetTime.c b/rts/win32/GetTime.c index 13fb5ab22d..9a322bf0a5 100644 --- a/rts/win32/GetTime.c +++ b/rts/win32/GetTime.c @@ -15,26 +15,26 @@ # include <time.h> #endif -#define HNS_PER_SEC 10000000LL /* FILETIMES are in units of 100ns */ /* Convert FILETIMEs into secs */ -static INLINE_ME Ticks -fileTimeToTicks(FILETIME ft) +static INLINE_ME Time +fileTimeToRtsTime(FILETIME ft) { - Ticks t; - t = ((Ticks)ft.dwHighDateTime << 32) | ft.dwLowDateTime; - t = (t * TICKS_PER_SECOND) / HNS_PER_SEC; + Time t; + t = ((Time)ft.dwHighDateTime << 32) | ft.dwLowDateTime; + t = NSToTime(t * 100); + /* FILETIMES are in units of 100ns */ return t; } void -getProcessTimes(Ticks *user, Ticks *elapsed) +getProcessTimes(Time *user, Time *elapsed) { *user = getProcessCPUTime(); *elapsed = getProcessElapsedTime(); } -Ticks +Time getProcessCPUTime(void) { FILETIME creationTime, exitTime, userTime, kernelTime = {0,0}; @@ -44,14 +44,14 @@ getProcessCPUTime(void) return 0; } - return fileTimeToTicks(userTime); + return fileTimeToRtsTime(userTime); } // getProcessElapsedTime relies on QueryPerformanceFrequency // which should be available on any Windows computer thay you // would want to run Haskell on. Satnam Singh, 5 July 2010. -Ticks +Time getProcessElapsedTime(void) { // frequency represents the number of ticks per second @@ -73,13 +73,14 @@ getProcessElapsedTime(void) // Get the tick count. QueryPerformanceCounter(&system_time) ; - // Return the tick count as a millisecond value. + // Return the tick count as a Time value. // Using double to compute the intermediate value, because a 64-bit - // int would overflow when multiplied by TICKS_PER_SECOND in about 81 days. - return (Ticks)((TICKS_PER_SECOND * (double)system_time.QuadPart) / (double)frequency.QuadPart) ; + // int would overflow when multiplied by TICK_RESOLUTION in about 81 days. + return fsecondsToTime((double)system_time.QuadPart / + (double)frequency.QuadPart) ; } -Ticks +Time getThreadCPUTime(void) { FILETIME creationTime, exitTime, userTime, kernelTime = {0,0}; @@ -89,7 +90,7 @@ getThreadCPUTime(void) return 0; } - return fileTimeToTicks(userTime); + return fileTimeToRtsTime(userTime); } void diff --git a/rts/win32/Ticker.c b/rts/win32/Ticker.c index 1c45482651..d54fa4680f 100644 --- a/rts/win32/Ticker.c +++ b/rts/win32/Ticker.c @@ -2,166 +2,80 @@ * RTS periodic timers. * */ +#define _WIN32_WINNT 0x0500 + #include "Rts.h" #include "Ticker.h" #include <windows.h> #include <stdio.h> #include <process.h> -/* - * Provide a timer service for the RTS, periodically - * notifying it that a number of 'ticks' has passed. - * - */ - -/* To signal pause or shutdown of the timer service, we use a local - * event which the timer thread listens to. - */ -static HANDLE hStopEvent = INVALID_HANDLE_VALUE; -static HANDLE tickThread = INVALID_HANDLE_VALUE; - -static TickProc tickProc = NULL; +static TickProc tick_proc = NULL; +static HANDLE timer_queue = NULL; +static HANDLE timer = NULL; +static Time tick_interval = 0; -static enum { TickerGo, TickerPause, TickerExit } ticker_state; - -/* - * Ticking is done by a separate thread which periodically - * wakes up to handle a tick. - * - * This is the portable way of providing a timer service under - * Win32; features like waitable timers or timer queues are only - * supported by a subset of the Win32 platforms (notably not - * under Win9x.) - * - */ -static -unsigned -WINAPI -TimerProc(PVOID param) +static VOID CALLBACK tick_callback( + PVOID lpParameter STG_UNUSED, + BOOLEAN TimerOrWaitFired STG_UNUSED + ) { - int ms = (int)param; - DWORD waitRes = 0; - - /* interpret a < 0 timeout period as 'instantaneous' */ - if (ms < 0) ms = 0; - - while (1) { - switch (ticker_state) { - case TickerGo: - waitRes = WaitForSingleObject(hStopEvent, ms); - break; - case TickerPause: - waitRes = WaitForSingleObject(hStopEvent, INFINITE); - break; - case TickerExit: - /* event has become signalled */ - tickProc = NULL; - CloseHandle(hStopEvent); - hStopEvent = INVALID_HANDLE_VALUE; - return 0; - } - - switch (waitRes) { - case WAIT_OBJECT_0: - /* event has become signalled */ - ResetEvent(hStopEvent); - continue; - case WAIT_TIMEOUT: - /* tick */ - tickProc(0); - break; - case WAIT_FAILED: - sysErrorBelch("TimerProc: WaitForSingleObject failed"); - break; - default: - errorBelch("TimerProc: unexpected result %lu\n", waitRes); - break; - } - } - return 0; + tick_proc(0); } +// We use the CreateTimerQueue() API which has been around since +// Windows 2000. Apparently it gives bad results before Windows 7, +// though: http://www.virtualdub.org/blog/pivot/entry.php?id=272 +// +// Even with the improvements in Windows 7, this timer isn't going to +// be very useful for profiling with a max usable resolution of +// 15ms. Unfortunately we don't have anything better. void -initTicker (nat ms, TickProc handle_tick) +initTicker (Time interval, TickProc handle_tick) { - unsigned threadId; - /* 'hStopEvent' is a manual-reset event that's signalled upon - * shutdown of timer service (=> timer thread.) - */ - hStopEvent = CreateEvent ( NULL, - TRUE, - FALSE, - NULL); - if (hStopEvent == INVALID_HANDLE_VALUE) { - sysErrorBelch("CreateEvent"); - stg_exit(EXIT_FAILURE); - } - tickProc = handle_tick; - ticker_state = TickerPause; - tickThread = (HANDLE)(long)_beginthreadex( NULL, - 0, - TimerProc, - (LPVOID)ms, - 0, - &threadId); + tick_interval = interval; + tick_proc = handle_tick; - if (tickThread == 0) { - sysErrorBelch("_beginthreadex"); - stg_exit(EXIT_FAILURE); - } + timer_queue = CreateTimerQueue(); + if (timer_queue == NULL) { + sysErrorBelch("CreateTimerQueue"); + stg_exit(EXIT_FAILURE); + } } void startTicker(void) { - ticker_state = TickerGo; - SetEvent(hStopEvent); + BOOL r; + + r = CreateTimerQueueTimer(&timer, + timer_queue, + tick_callback, + 0, + 0, + TimeToUS(tick_interval) / 1000, // ms + WT_EXECUTEINTIMERTHREAD); + if (r == 0) { + sysErrorBelch("CreateTimerQueueTimer"); + stg_exit(EXIT_FAILURE); + } } void stopTicker(void) { - ticker_state = TickerPause; - SetEvent(hStopEvent); + if (timer_queue != NULL && timer != NULL) { + DeleteTimerQueueTimer(timer_queue, timer, NULL); + timer = NULL; + } } void exitTicker (rtsBool wait) { - // We must wait for the ticker thread to terminate, since if we - // are in a DLL that is about to be unloaded, the ticker thread - // cannot be allowed to return to a missing DLL. - - if (hStopEvent != INVALID_HANDLE_VALUE && - tickThread != INVALID_HANDLE_VALUE) { - DWORD exitCode; - ticker_state = TickerExit; - SetEvent(hStopEvent); - while (wait) { - // See #3748: - // - // when the RTS is compiled into a DLL (wait==rtsTrue), - // the ticker thread must stop before we exit, or chaos - // will ensue. We can't kill it, because it may be - // holding a lock. - // - // When not compiled into a DLL, we wait for - // the thread out of courtesy, but give up after 200ms if - // it still hasn't stopped. - WaitForSingleObject(tickThread, 200); - if (!GetExitCodeThread(tickThread, &exitCode)) { - return; - } - CloseHandle(tickThread); - if (exitCode != STILL_ACTIVE) { - tickThread = INVALID_HANDLE_VALUE; - if ( hStopEvent != INVALID_HANDLE_VALUE ) { - CloseHandle(hStopEvent); - hStopEvent = INVALID_HANDLE_VALUE; - } - return; - } - } + if (timer_queue != NULL) { + DeleteTimerQueueEx(timer_queue, wait ? INVALID_HANDLE_VALUE : NULL); + timer_queue = NULL; } } diff --git a/rules/build-prog.mk b/rules/build-prog.mk index 99093d3fee..1f43169ce3 100644 --- a/rules/build-prog.mk +++ b/rules/build-prog.mk @@ -117,8 +117,12 @@ ifeq "$3" "0" # worry about where the RTS header files are $(call c-suffix-rules,$1,$2,v,YES) else +ifeq "$$($1_$2_UseGhcForCC)" "YES" +$(call c-suffix-rules,$1,$2,v,YES) +else $(call c-suffix-rules,$1,$2,v,NO) endif +endif $(call hs-suffix-rules,$1,$2,v) $$(foreach dir,$$($1_$2_HS_SRC_DIRS),\ |