diff options
| author | David Terei <davidterei@gmail.com> | 2011-08-01 13:37:13 -0700 |
|---|---|---|
| committer | David Terei <davidterei@gmail.com> | 2011-08-01 13:37:13 -0700 |
| commit | dd96a196e4719d04ba78675069e93d01a50b7b33 (patch) | |
| tree | 2c3dedf8ef507214bcd7b71e0cc96defffe18b58 | |
| parent | e3e5cce62fd17e08f99388a046ba2e54f2a47824 (diff) | |
| parent | 353c15e16dbb98e5efcdb10558837c4303df9344 (diff) | |
| download | haskell-dd96a196e4719d04ba78675069e93d01a50b7b33.tar.gz | |
Merge branch 'master' of ssh://darcs.haskell.org/home/darcs/ghc
106 files changed, 3297 insertions, 1859 deletions
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h index 303d2bdc65..b6f92ae2e7 100644 --- a/compiler/HsVersions.h +++ b/compiler/HsVersions.h @@ -36,19 +36,19 @@ you will screw up the layout where they are used in case expressions! name :: IORef (ty); \ name = Util.global (value); -#define GLOBAL_MVAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: MVar (ty); \ -name = Util.globalMVar (value); +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.globalM (value); #endif #else /* __HADDOCK__ */ #define GLOBAL_VAR(name,value,ty) \ name :: IORef (ty); \ name = Util.global (value); -#define GLOBAL_MVAR(name,value,ty) \ -name :: MVar (ty); \ -name = Util.globalMVar (value); +#define GLOBAL_VAR_M(name,value,ty) \ +name :: IORef (ty); \ +name = Util.globalM (value); #endif #define COMMA , diff --git a/compiler/basicTypes/NameEnv.lhs b/compiler/basicTypes/NameEnv.lhs index 984f0963cc..0dc5c32c7a 100644 --- a/compiler/basicTypes/NameEnv.lhs +++ b/compiler/basicTypes/NameEnv.lhs @@ -15,7 +15,7 @@ module NameEnv ( extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, foldNameEnv, filterNameEnv, - plusNameEnv, plusNameEnv_C, + plusNameEnv, plusNameEnv_C, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv ) where @@ -41,6 +41,7 @@ emptyNameEnv :: NameEnv a mkNameEnv :: [(Name,a)] -> NameEnv a nameEnvElts :: NameEnv a -> [a] nameEnvUniqueElts :: NameEnv a -> [(Unique, a)] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a @@ -64,6 +65,7 @@ unitNameEnv x y = unitUFM x y extendNameEnv x y z = addToUFM x y z extendNameEnvList x l = addListToUFM x l lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM mkNameEnv l = listToUFM l elemNameEnv x y = elemUFM x y foldNameEnv a b c = foldUFM a b c diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs index 41806040d2..3ebf95023b 100644 --- a/compiler/basicTypes/Unique.lhs +++ b/compiler/basicTypes/Unique.lhs @@ -173,6 +173,9 @@ instance Uniquable FastString where instance Uniquable Int where getUnique i = mkUniqueGrimily i + +instance Uniquable n => Uniquable (IPName n) where + getUnique (IPName n) = getUnique n \end{code} diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index 3c3ff7f440..5cbf89b932 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -32,7 +32,7 @@ module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId, + Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -103,7 +103,6 @@ type TyVar = Var type CoVar = Id -- A coercion variable is simply an Id -- variable of kind @ty1 ~ ty2@. Hence its -- 'varType' is always @PredTy (EqPred t1 t2)@ -type TyCoVar = TyVar -- Something that is a type OR coercion variable. \end{code} %************************************************************************ diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index 07fabb0345..905c0b5dfb 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -12,7 +12,7 @@ module VarEnv ( emptyVarEnv, unitVarEnv, mkVarEnv, elemVarEnv, varEnvElts, varEnvKeys, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, - plusVarEnv, plusVarEnv_C, + plusVarEnv, plusVarEnv_C, alterVarEnv, delVarEnvList, delVarEnv, minusVarEnv, intersectsVarEnv, lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, @@ -286,12 +286,16 @@ rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR new_b = uniqAway in_scope bR delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 -delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } -delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 -delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } -delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- ^ Look up the renaming of an occurrence in the left or right term @@ -364,6 +368,7 @@ emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a zipVarEnv :: [Var] -> [a] -> VarEnv a unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b @@ -395,6 +400,7 @@ foldVarEnv :: (a -> b -> b) -> b -> VarEnv a -> b \begin{code} elemVarEnv = elemUFM elemVarEnvByKey = elemUFM_Directly +alterVarEnv = alterUFM extendVarEnv = addToUFM extendVarEnv_C = addToUFM_C extendVarEnv_Acc = addToUFM_Acc diff --git a/compiler/basicTypes/VarSet.lhs b/compiler/basicTypes/VarSet.lhs index e0ff52d690..c7464c34d7 100644 --- a/compiler/basicTypes/VarSet.lhs +++ b/compiler/basicTypes/VarSet.lhs @@ -6,7 +6,7 @@ \begin{code} module VarSet ( -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet, + VarSet, IdSet, TyVarSet, CoVarSet, -- ** Manipulating these sets emptyVarSet, unitVarSet, mkVarSet, @@ -22,7 +22,7 @@ module VarSet ( #include "HsVersions.h" -import Var ( Var, TyVar, CoVar, TyCoVar, Id ) +import Var ( Var, TyVar, CoVar, Id ) import Unique import UniqSet \end{code} @@ -37,7 +37,6 @@ import UniqSet type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar -type TyCoVarSet = UniqSet TyCoVar type CoVarSet = UniqSet CoVar emptyVarSet :: VarSet diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 8828adb0d0..fdab13264f 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -65,6 +65,7 @@ module CLabel ( mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, + mkCAFBlackHoleEntryLabel, mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, @@ -99,8 +100,7 @@ module CLabel ( mkHpcTicksLabel, hasCAF, - infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, - localiseLabel, + cvtToClosureLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -286,7 +286,7 @@ data IdLabelInfo = Closure -- ^ Label for closure | SRT -- ^ Static reference table | InfoTable IsLocal -- ^ Info tables for closures; always read-only - | Entry IsLocal -- ^ Entry point + | Entry -- ^ Entry point | Slow -- ^ Slow entry point | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id @@ -361,12 +361,12 @@ mkRednCountsLabel name c = IdLabel name c RednCounts -- These have local & (possibly) external variants: mkLocalClosureLabel name c = IdLabel name c Closure mkLocalInfoTableLabel name c = IdLabel name c (InfoTable True) -mkLocalEntryLabel name c = IdLabel name c (Entry True) +mkLocalEntryLabel name c = IdLabel name c Entry mkLocalClosureTableLabel name c = IdLabel name c ClosureTable mkClosureLabel name c = IdLabel name c Closure mkInfoTableLabel name c = IdLabel name c (InfoTable False) -mkEntryLabel name c = IdLabel name c (Entry False) +mkEntryLabel name c = IdLabel name c Entry mkClosureTableLabel name c = IdLabel name c ClosureTable mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable mkLocalConEntryLabel c con = IdLabel con c ConEntry @@ -390,6 +390,7 @@ mkMAP_DIRTY_infoLabel = CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY") mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, @@ -499,32 +500,10 @@ mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- ----------------------------------------------------------------------------- --- Converting between info labels and entry/ret labels. - -infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c (InfoTable lcl)) = IdLabel n c (Entry lcl) -infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -infoLblToEntryLbl _ - = panic "CLabel.infoLblToEntryLbl" - - -entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n c (Entry lcl)) = IdLabel n c (InfoTable lcl) -entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo -entryLblToInfoLbl l - = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) - +-- Brutal method of obtaining a closure label cvtToClosureLbl (IdLabel n c (InfoTable _)) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c (Entry _)) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure cvtToClosureLbl l@(IdLabel n c Closure) = l @@ -532,19 +511,6 @@ cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) -cvtToSRTLbl (IdLabel n c (InfoTable _)) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c (Entry _)) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c -cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c -cvtToSRTLbl l - = pprPanic "cvtToSRTLbl" (pprCLabel l) - -localiseLabel :: CLabel -> CLabel -localiseLabel (IdLabel n c (Entry _)) = IdLabel n c (Entry True) -localiseLabel (IdLabel n c (InfoTable _)) = IdLabel n c (InfoTable True) -localiseLabel l = l - - -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? hasCAF :: CLabel -> Bool @@ -710,7 +676,6 @@ externallyVisibleCLabel (LargeSRTLabel _) = False externallyVisibleIdLabel :: IdLabelInfo -> Bool externallyVisibleIdLabel SRT = False -externallyVisibleIdLabel (Entry lcl) = not lcl externallyVisibleIdLabel (InfoTable lcl) = not lcl externallyVisibleIdLabel _ = True @@ -858,6 +823,33 @@ Many of these distinctions are only for documentation reasons. For example, _ret is only distinguished from _entry to make it easy to tell whether a code fragment is a return point or a closure/function entry. + +Note [Closure and info labels] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a function 'foo, we have: + foo_info : Points to the info table describing foo's closure + (and entry code for foo with tables next to code) + foo_closure : Static (no-free-var) closure only: + points to the statically-allocated closure + +For a data constructor (such as Just or Nothing), we have: + Just_con_info: Info table for the data constructor itself + the first word of a heap-allocated Just + Just_info: Info table for the *worker function*, an + ordinary Haskell function of arity 1 that + allocates a (Just x) box: + Just = \x -> Just x + Just_closure: The closure for this worker + + Nothing_closure: a statically allocated closure for Nothing + Nothing_static_info: info table for Nothing_closure + +All these must be exported symbol, EXCEPT Just_info. We don't need to +export this because in other modules we either have + * A reference to 'Just'; use Just_closure + * A saturated call 'Just x'; allocate using Just_con_info +Not exporting these Just_info labels reduces the number of symbols +somewhat. -} instance Outputable CLabel where @@ -998,7 +990,7 @@ ppIdFlavor x = pp_cSEP <> Closure -> ptext (sLit "closure") SRT -> ptext (sLit "srt") InfoTable _ -> ptext (sLit "info") - Entry _ -> ptext (sLit "entry") + Entry -> ptext (sLit "entry") Slow -> ptext (sLit "slow") RednCounts -> ptext (sLit "ct") ConEntry -> ptext (sLit "con_entry") diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs index 9bd2386776..552878e7bb 100644 --- a/compiler/cmm/CmmDecl.hs +++ b/compiler/cmm/CmmDecl.hs @@ -55,7 +55,7 @@ newtype GenCmm d h g = Cmm [GenCmmTop d h g] data GenCmmTop d h g = CmmProc -- A procedure h -- Extra header such as the info table - CLabel -- Used to generate both info & entry labels (though the info table label is in 'h' in RawCmmTop) + CLabel -- Entry label g -- Control-flow graph for the procedure's code | CmmData -- Static data @@ -70,16 +70,13 @@ data GenCmmTop d h g -- Info table as a haskell data type data CmmInfoTable = CmmInfoTable - LocalInfoTable + CLabel -- Info table label HasStaticClosure ProfilingInfo ClosureTypeTag -- Int ClosureTypeInfo | CmmNonInfoTable -- Procedure doesn't need an info table --- | If the table is local, we don't export its identifier even if the corresponding Id is exported. --- It's always safe to say 'False' here, but it might save symbols to say 'True' -type LocalInfoTable = Bool type HasStaticClosure = Bool -- TODO: The GC target shouldn't really be part of CmmInfo diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 47d0c8b004..e463b3619f 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,5 +1,5 @@ module CmmInfo ( - emptyContInfoTable, + mkEmptyContInfoTable, cmmToRawCmm, mkInfoTable, ) where @@ -27,9 +27,9 @@ import UniqSupply import Data.Bits -- When we split at proc points, we need an empty info table. -emptyContInfoTable :: CmmInfoTable -emptyContInfoTable = CmmInfoTable False False (ProfilingInfo zero zero) rET_SMALL - (ContInfo [] NoC_SRT) +mkEmptyContInfoTable :: CLabel -> CmmInfoTable +mkEmptyContInfoTable info_lbl = CmmInfoTable info_lbl False (ProfilingInfo zero zero) rET_SMALL + (ContInfo [] NoC_SRT) where zero = CmmInt 0 wordWidth cmmToRawCmm :: [Cmm] -> IO [RawCmm] @@ -80,9 +80,8 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) = -- Code without an info table. Easy. CmmNonInfoTable -> [CmmProc Nothing entry_label blocks] - CmmInfoTable is_local _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> - let info_label = (if is_local then localiseLabel else id) $ entryLblToInfoLbl entry_label - ty_prof' = makeRelativeRefTo info_label ty_prof + CmmInfoTable info_label _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> + let ty_prof' = makeRelativeRefTo info_label ty_prof cl_prof' = makeRelativeRefTo info_label cl_prof in case type_info of -- A function entry point. diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 2d59fe751e..9d9136e18b 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -266,7 +266,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False False prof (fromIntegral $9) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } @@ -275,7 +275,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False False prof (fromIntegral $9) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral $15)) @@ -290,7 +290,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False False prof (fromIntegral $9) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (ArgSpec (fromIntegral $15)) zeroCLit), @@ -306,7 +306,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- but that's the way the old code did it we can fix it some other time. desc_lit <- code $ mkStringCLit $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False False prof (fromIntegral $11) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } @@ -315,7 +315,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $9 $11 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False False prof (fromIntegral $7) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } @@ -324,7 +324,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do let infoLabel = mkCmmInfoLabel pkg $3 return (mkCmmRetLabel pkg $3, - CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable (mkCmmInfoLabel pkg $3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } @@ -333,7 +333,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do live <- sequence (map (liftM Just) $7) return (mkCmmRetLabel pkg $3, - CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable (mkCmmInfoLabel pkg $3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index b608b291d4..c063f639af 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -384,7 +384,8 @@ add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> CmmTop -> FuelUniqSM [CmmTop] splitAtProcPoints entry_label callPPs procPoints procMap - (CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) + (CmmProc (TopInfo {info_tbl=info_tbl, + stack_info=stack_info}) top_l g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach let addBlock b graphEnv = @@ -401,12 +402,18 @@ splitAtProcPoints entry_label callPPs procPoints procMap where graph = mapLookup procId graphEnv `orElse` mapEmpty graph' = mapInsert bid b graph graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g - -- Build a map from proc point BlockId to labels for their new procedures + -- Build a map from proc point BlockId to pairs of: + -- * Labels for their new procedures + -- * Labels for the info tables of their new procedures (only if the proc point is a callPP) -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = return $ Map.insert pp lbl map - where lbl = if pp == entry then entry_label else blockLbl pp - procLabels <- foldM add_label Map.empty - (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + let add_label map pp = Map.insert pp lbls map + where lbls | pp == entry = (entry_label, Just entry_info_lbl) + | otherwise = (blockLbl pp, guard (setMember pp callPPs) >> Just (infoTblLbl pp)) + entry_info_lbl = case info_tbl of + CmmInfoTable entry_info_label _ _ _ _ -> entry_info_label + CmmNonInfoTable -> pprPanic "splitAtProcPoints: looked at info label for entry without info table" (ppr pp) + procLabels = foldl add_label Map.empty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) -- For each procpoint, we need to know the SP offset on entry. -- If the procpoint is: -- - continuation of a call, the SP offset is in the call @@ -427,9 +434,8 @@ splitAtProcPoints entry_label callPPs procPoints procMap do bid <- liftM mkBlockId getUniqueM let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump) StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp - jump = CmmCall (CmmLit (CmmLabel l')) Nothing argSpace 0 + jump = CmmCall (CmmLit (CmmLabel l)) Nothing argSpace 0 (off `orElse` 0) -- Jump's shouldn't need the offset... - l' = if setMember pp callPPs then entryLblToInfoLbl l else l return (mapInsert pp bid env, b : bs) add_jumps (newGraphEnv) (ppId, blockEnv) = do let needed_jumps = -- find which procpoints we currently branch to @@ -442,8 +448,8 @@ splitAtProcPoints entry_label callPPs procPoints procMap CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) _ -> rst add_if_pp id rst = case Map.lookup id procLabels of - Just x -> (id, x) : rst - Nothing -> rst + Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst + Nothing -> rst (jumpEnv, jumpBlocks) <- foldM add_jump_block (mapEmpty, []) needed_jumps -- update the entry block @@ -458,24 +464,23 @@ splitAtProcPoints entry_label callPPs procPoints procMap -- pprTrace "g' pre jumps" (ppr g') $ do return (mapInsert ppId g' newGraphEnv) graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv - let to_proc (bid, (stack_info, g)) | setMember bid callPPs = - if bid == entry then - CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) - top_l (replacePPIds g) - else - CmmProc (TopInfo {info_tbl=emptyContInfoTable, stack_info=stack_info}) - lbl (replacePPIds g) - where lbl = expectJust "pp label" $ Map.lookup bid procLabels - to_proc (bid, (stack_info, g)) = - CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info}) - lbl (replacePPIds g) - where lbl = expectJust "pp label" $ Map.lookup bid procLabels + let to_proc (bid, (stack_info, g)) = case expectJust "pp label" $ Map.lookup bid procLabels of + (lbl, Just info_lbl) + | bid == entry + -> CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) + top_l (replacePPIds g) + | otherwise + -> CmmProc (TopInfo {info_tbl=mkEmptyContInfoTable info_lbl, stack_info=stack_info}) + lbl (replacePPIds g) + (lbl, Nothing) + -> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info}) + lbl (replacePPIds g) -- References to procpoint IDs can now be replaced with the infotable's label replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g where repl e@(CmmLit (CmmBlock bid)) = case Map.lookup bid procLabels of - Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l)) - Nothing -> e + Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) + _ -> e repl e = e -- The C back end expects to see return continuations before the call sites. -- Here, we sort them in reverse order -- it gets reversed later. diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 3ff646ca07..ebdde2d31a 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -185,7 +185,7 @@ mkStaticClosureFields cl_info ccs caf_refs payload = mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field where - info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info + info_lbl = infoTableLabelFromCI cl_info -- CAFs must have consistent layout, regardless of whether they -- are actually updatable or not. The layout of a CAF is: @@ -302,7 +302,7 @@ hpStkCheck cl_info is_fun reg_save_code code -- Strictly speaking, we should tag node here. But if -- node doesn't point to the closure, the code for the closure -- cannot depend on the value of R1 anyway, so we're safe. - closure_lbl = closureLabelFromCI cl_info (clHasCafRefs cl_info) + closure_lbl = closureLabelFromCI cl_info full_save_code = node_asst `plusStmts` reg_save_code @@ -570,8 +570,7 @@ allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets -- Remember, virtHp points to last allocated word, -- ie 1 *before* the info-ptr word of new object. - info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info - (clHasCafRefs cl_info))) + info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..] -- SAY WHAT WE ARE ABOUT TO DO diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 093b9ffaab..dbd22f3906 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -57,9 +57,7 @@ emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code emitClosureCodeAndInfoTable cl_info args body = do { blks <- cgStmtsToBlocks body ; info <- mkCmmInfo cl_info - ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks } - where - info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info + ; emitInfoTableAndCode (entryLabelFromCI cl_info) info args blks } -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. @@ -84,12 +82,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable False False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (infoTableLabelFromCI cl_info) False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable (closureInfoLocal cl_info) False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (infoTableLabelFromCI cl_info) False prof cl_type info) where info = case lf_info of @@ -105,7 +103,7 @@ mkCmmInfo cl_info = do ThunkInfo (ptrs, nptrs) srt _ -> panic "unexpected lambda form in mkCmmInfo" where - info_lbl = infoTableLabelFromCI cl_info has_caf_refs + info_lbl = infoTableLabelFromCI cl_info has_caf_refs = clHasCafRefs cl_info cl_type = smRepClosureTypeInt (closureSMRep cl_info) @@ -142,16 +140,17 @@ emitReturnTarget name stmts ; let info = CmmInfo gc_target Nothing - (CmmInfoTable False False + (CmmInfoTable info_lbl False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) - ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks + ; emitInfoTableAndCode entry_lbl info args blks ; return info_lbl } where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq -- The gc_target is to inform the CPS pass when it inserts a stack check. -- Since that pass isn't used yet we'll punt for now. diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index effa7a42d6..1d2902188c 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -47,7 +47,7 @@ module CgUtils ( packHalfWordsCLit, blankWord, - getSRTInfo, clHasCafRefs + getSRTInfo ) where #include "HsVersions.h" @@ -995,12 +995,6 @@ getSRTInfo = do srt_escape = (-1) :: StgHalfWord -clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs -clHasCafRefs (ConInfo {}) = NoCafRefs - -- ----------------------------------------------------------------------------- -- -- STG/Cmm GlobalReg diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index daf476adfc..60f1bda7f5 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -29,13 +29,13 @@ module ClosureInfo ( closureGoodStuffSize, closurePtrsSize, slopSize, - infoTableLabelFromCI, + infoTableLabelFromCI, entryLabelFromCI, closureLabelFromCI, isLFThunk, closureUpdReqd, closureNeedsUpdSpace, closureIsThunk, closureSingleEntry, closureReEntrant, isConstrClosure_maybe, closureFunInfo, isStandardFormThunk, isKnownFun, - funTag, funTagLFInfo, tagForArity, + funTag, funTagLFInfo, tagForArity, clHasCafRefs, enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, @@ -50,7 +50,7 @@ module ClosureInfo ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - closureInfoLocal, isStaticClosure, + isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, @@ -59,7 +59,6 @@ module ClosureInfo ( #include "../includes/MachDeps.h" #include "HsVersions.h" ---import CgUtils import StgSyn import SMRep @@ -185,7 +184,6 @@ data LambdaFormInfo | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to -- be in the heap, so we make a black hole to hold it. - CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). ------------------------- @@ -315,7 +313,7 @@ mkLFImported id \begin{code} isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk _ _ _ _ _) = True -isLFThunk (LFBlackHole _) = True +isLFThunk LFBlackHole = True -- return True for a blackhole: this function is used to determine -- whether to use the thunk header in SMP mode, and a blackhole -- must have one. @@ -530,7 +528,7 @@ nodeMustPointToIt (LFThunk _ _ _ _ _) = True -- Node must point to any standard-form thunk nodeMustPointToIt (LFUnknown _) = True -nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point +nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point nodeMustPointToIt (LFLetNoEscape _) = False \end{code} @@ -648,7 +646,7 @@ getCallMethod _ name _ (LFUnknown False) n_args | otherwise = EnterIt -- Not a function -getCallMethod _ _ _ (LFBlackHole _) _ +getCallMethod _ _ _ LFBlackHole _ = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it @@ -848,10 +846,6 @@ staticClosureRequired _ _ _ = True %************************************************************************ \begin{code} -closureInfoLocal :: ClosureInfo -> Bool -closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl -closureInfoLocal ConInfo{} = False - isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -861,7 +855,7 @@ closureUpdReqd ConInfo{} = False lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable (LFBlackHole _) = True +lfUpdatable LFBlackHole = True -- Black-hole closures are allocated to receive the results of an -- alg case with a named default... so they need to be updated. lfUpdatable _ = False @@ -909,6 +903,12 @@ funTagLFInfo lf tagForArity :: Int -> Maybe Int tagForArity i | i <= mAX_PTR_TAG = Just i | otherwise = Nothing + +clHasCafRefs :: ClosureInfo -> CafInfo +clHasCafRefs (ClosureInfo {closureSRT = srt}) = + case srt of NoC_SRT -> NoCafRefs + _ -> MayHaveCafRefs +clHasCafRefs (ConInfo {}) = NoCafRefs \end{code} \begin{code} @@ -924,35 +924,46 @@ isToplevClosure _ = False Label generation. \begin{code} -infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel -infoTableLabelFromCI (ClosureInfo { closureName = name, - closureLFInfo = lf_info }) caf +infoTableLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI = fst . labelsFromCI + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI = snd . labelsFromCI + +labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) +labelsFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfLcl = is_lcl }) = case lf_info of - LFBlackHole info -> info + LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - mkSelectorInfoLabel upd_flag offset + bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ -> - mkApInfoTableLabel upd_flag arity + bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - LFThunk{} -> mkInfoTableLabel name caf + LFThunk{} -> bothL std_mk_lbls name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkInfoTableLabel name caf + LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl - _ -> panic "infoTableLabelFromCI" + _ -> panic "labelsFromCI" + where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel) -infoTableLabelFromCI (ConInfo { closureCon = con, - closureSMRep = rep }) caf - | isStaticRep rep = mkStaticInfoTableLabel name caf - | otherwise = mkConInfoTableLabel name caf +labelsFromCI cl@(ConInfo { closureCon = con, + closureSMRep = rep }) + | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl + | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl where name = dataConName con +bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) +bothL (f, g) x y = (f x y, g x y) + -- ClosureInfo for a closure (as opposed to a constructor) is always local -closureLabelFromCI :: ClosureInfo -> CafInfo -> CLabel -closureLabelFromCI (ClosureInfo { closureName = nm }) caf = mkLocalClosureLabel nm caf -closureLabelFromCI _ _ = panic "closureLabelFromCI" +closureLabelFromCI :: ClosureInfo -> CLabel +closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm $ clHasCafRefs cl +closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. @@ -1008,7 +1019,7 @@ cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureType = ty }) = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, + closureLFInfo = LFBlackHole, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 7c4f8bc8b8..2492bafc6c 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -35,7 +35,7 @@ module StgCmmClosure ( closureGoodStuffSize, closurePtrsSize, slopSize, - closureName, infoTableLabelFromCI, + closureName, infoTableLabelFromCI, entryLabelFromCI, closureLabelFromCI, closureTypeInfo, closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, @@ -56,7 +56,7 @@ module StgCmmClosure ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - closureInfoLocal, isStaticClosure, + isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, clHasCafRefs @@ -157,7 +157,6 @@ data LambdaFormInfo | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to -- be in the heap, so we make a black hole to hold it. - CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). ------------------------- @@ -354,7 +353,7 @@ maybeIsLFCon _ = Nothing ------------ isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk _ _ _ _ _) = True -isLFThunk (LFBlackHole _) = True +isLFThunk LFBlackHole = True -- return True for a blackhole: this function is used to determine -- whether to use the thunk header in SMP mode, and a blackhole -- must have one. @@ -440,7 +439,7 @@ nodeMustPointToIt (LFThunk {}) -- Node must point to a standard-form thunk nodeMustPointToIt (LFUnknown _) = True nodeMustPointToIt LFUnLifted = False -nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point +nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point nodeMustPointToIt LFLetNoEscape = False ----------------------------------------------------------------------------- @@ -548,7 +547,7 @@ getCallMethod _ name _ (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod _ _name _ (LFBlackHole _) _n_args +getCallMethod _ _name _ LFBlackHole _n_args = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it @@ -757,7 +756,7 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureType = ty, closureCafs = cafs }) = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, + closureLFInfo = LFBlackHole, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, @@ -938,10 +937,6 @@ staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con }) GenericRep _ _ _ ConstrNoCaf -> False _other -> True -closureInfoLocal :: ClosureInfo -> Bool -closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl -closureInfoLocal ConInfo{} = False - isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -951,7 +946,7 @@ closureUpdReqd ConInfo{} = False lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable (LFBlackHole _) = True +lfUpdatable LFBlackHole = True -- Black-hole closures are allocated to receive the results of an -- alg case with a named default... so they need to be updated. lfUpdatable _ = False @@ -997,29 +992,40 @@ isToplevClosure _ = False -------------------------------------- infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI cl@(ClosureInfo { closureName = name, - closureLFInfo = lf_info }) +infoTableLabelFromCI = fst . labelsFromCI + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI = snd . labelsFromCI + +labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) +labelsFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfLcl = is_lcl }) = case lf_info of - LFBlackHole info -> info + LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - mkSelectorInfoLabel upd_flag offset + bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ -> - mkApInfoTableLabel upd_flag arity + bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> bothL std_mk_lbls name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl - _other -> panic "infoTableLabelFromCI" + _other -> panic "labelsFromCI" + where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel) -infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) - | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl - | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl +labelsFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) + | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl + | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl where name = dataConName con +bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) +bothL (f, g) x y = (f x y, g x y) + -- ClosureInfo for a closure (as opposed to a constructor) is always local closureLabelFromCI :: ClosureInfo -> CLabel closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 278c41aef2..63fc840845 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -481,10 +481,8 @@ emitClosureAndInfoTable :: emitClosureAndInfoTable cl_info conv args body = do { info <- mkCmmInfo cl_info ; blks <- getCode body - ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks + ; emitProcWithConvention conv info (entryLabelFromCI cl_info) args blks } - where - info_lbl = infoTableLabelFromCI cl_info -- Convert from 'ClosureInfo' to 'CmmInfoTable'. -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) @@ -496,7 +494,7 @@ mkCmmInfo cl_info ad_lit <- mkStringCLit (closureValDescr cl_info) return $ ProfilingInfo fd_lit ad_lit else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - ; return (CmmInfoTable (closureInfoLocal cl_info) (isStaticClosure cl_info) prof cl_type info) } + ; return (CmmInfoTable (infoTableLabelFromCI cl_info) (isStaticClosure cl_info) prof cl_type info) } where k_with_con_name con_info con info_lbl = do cstr <- mkByteStringCLit $ dataConIdentity con diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 3e79b135e7..6a23b10002 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -936,7 +936,7 @@ checkBndrIdInScope binder id msg = ptext (sLit "is out of scope inside info for") <+> ppr binder -checkTyCoVarInScope :: TyCoVar -> LintM () +checkTyCoVarInScope :: Var -> LintM () checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v checkInScope :: SDoc -> Var -> LintM () diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 6325a08dc2..fdd92794bb 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -367,7 +367,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) ; let float = mkFloat False False v rhs2 - ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) }) + ; return ( addFloat floats2 float + , cpeEtaExpand arity (Var v)) }) -- Record if the binder is evaluated -- and otherwise trim off the unfolding altogether @@ -655,7 +656,7 @@ cpeArg env is_strict arg arg_ty { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 arg_float = mkFloat is_strict is_unlifted v arg3 - ; return (addFloat floats2 arg_float, Var v) } } + ; return (addFloat floats2 arg_float, varToCoreExpr v) } } where is_unlifted = isUnLiftedType arg_ty want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 3490377336..ca0fbd5a52 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -50,7 +50,7 @@ import Type hiding ( substTy, extendTvSubst, extendTvSubstList import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) import OptCoercion ( optCoercion ) -import PprCore ( pprCoreBindings ) +import PprCore ( pprCoreBindings, pprRules ) import Module ( Module ) import VarSet import VarEnv @@ -101,7 +101,7 @@ data Subst -- applying the substitution IdSubstEnv -- Substitution for Ids TvSubstEnv -- Substitution from TyVars to Types - CvSubstEnv -- Substitution from TyCoVars to Coercions + CvSubstEnv -- Substitution from CoVars to Coercions -- INVARIANT 1: See #in_scope_invariant# -- This is what lets us deal with name capture properly @@ -213,14 +213,14 @@ extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEn extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs --- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this -extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) --- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the +-- | Adds multiple 'CoVar' -> 'Coercion' substitutions to the -- 'Subst': see also 'extendCvSubst' -extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst +extendCvSubstList :: Subst -> [(CoVar,Coercion)] -> Subst extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) -- | Add a substitution appropriate to the thing being substituted @@ -261,7 +261,7 @@ lookupIdSubst doc (Subst in_scope ids _ _) v lookupTvSubst :: Subst -> TyVar -> Type lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v --- | Find the coercion substitution for a 'TyCoVar' in the 'Subst' +-- | Find the coercion substitution for a 'CoVar' in the 'Subst' lookupCvSubst :: Subst -> CoVar -> Coercion lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v @@ -800,7 +800,7 @@ simpleOptPgm :: DynFlags -> Module -> IO ([CoreBind], [CoreRule], [CoreVect]) simpleOptPgm dflags this_mod binds rules vects = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings occ_anald_binds); + (pprCoreBindings occ_anald_binds $$ pprRules rules ); ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) } where diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 872e732a61..ccb87e7782 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -141,106 +141,118 @@ These data types are the heart of the compiler -- optimization, analysis and code generation on. -- -- The type parameter @b@ is for the type of binders in the expression tree. +-- +-- The language consists of the following elements: +-- +-- * Variables +-- +-- * Primitive literals +-- +-- * Applications: note that the argument may be a 'Type'. +-- +-- See "CoreSyn#let_app_invariant" for another invariant +-- +-- * Lambda abstraction +-- +-- * Recursive and non recursive @let@s. Operationally +-- this corresponds to allocating a thunk for the things +-- bound and then executing the sub-expression. +-- +-- #top_level_invariant# +-- #letrec_invariant# +-- +-- The right hand sides of all top-level and recursive @let@s +-- /must/ be of lifted type (see "Type#type_classification" for +-- the meaning of /lifted/ vs. /unlifted/). +-- +-- #let_app_invariant# +-- The right hand side of of a non-recursive 'Let' +-- _and_ the argument of an 'App', +-- /may/ be of unlifted type, but only if the expression +-- is ok-for-speculation. This means that the let can be floated +-- around without difficulty. For example, this is OK: +-- +-- > y::Int# = x +# 1# +-- +-- But this is not, as it may affect termination if the +-- expression is floated out: +-- +-- > y::Int# = fac 4# +-- +-- In this situation you should use @case@ rather than a @let@. The function +-- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or +-- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, +-- which will generate a @case@ if necessary +-- +-- #type_let# +-- We allow a /non-recursive/ let to bind a type variable, thus: +-- +-- > Let (NonRec tv (Type ty)) body +-- +-- This can be very convenient for postponing type substitutions until +-- the next run of the simplifier. +-- +-- At the moment, the rest of the compiler only deals with type-let +-- in a Let expression, rather than at top level. We may want to revist +-- this choice. +-- +-- * Case split. Operationally this corresponds to evaluating +-- the scrutinee (expression examined) to weak head normal form +-- and then examining at most one level of resulting constructor (i.e. you +-- cannot do nested pattern matching directly with this). +-- +-- The binder gets bound to the value of the scrutinee, +-- and the 'Type' must be that of all the case alternatives +-- +-- #case_invariants# +-- This is one of the more complicated elements of the Core language, +-- and comes with a number of restrictions: +-- +-- The 'DEFAULT' case alternative must be first in the list, +-- if it occurs at all. +-- +-- The remaining cases are in order of increasing +-- tag (for 'DataAlts') or +-- lit (for 'LitAlts'). +-- This makes finding the relevant constructor easy, +-- and makes comparison easier too. +-- +-- The list of alternatives must be exhaustive. An /exhaustive/ case +-- does not necessarily mention all constructors: +-- +-- @ +-- data Foo = Red | Green | Blue +-- ... case x of +-- Red -> True +-- other -> f (case x of +-- Green -> ... +-- Blue -> ... ) ... +-- @ +-- +-- The inner case does not need a @Red@ alternative, because @x@ +-- can't be @Red@ at that program point. +-- +-- * Cast an expression to a particular type. +-- This is used to implement @newtype@s (a @newtype@ constructor or +-- destructor just becomes a 'Cast' in Core) and GADTs. +-- +-- * Notes. These allow general information to be added to expressions +-- in the syntax tree +-- +-- * A type: this should only show up at the top level of an Arg +-- +-- * A coercion data Expr b - = Var Id -- ^ Variables - - | Lit Literal -- ^ Primitive literals - - | App (Expr b) (Arg b) -- ^ Applications: note that the argument may be a 'Type'. - -- - -- See "CoreSyn#let_app_invariant" for another invariant - - | Lam b (Expr b) -- ^ Lambda abstraction - - | Let (Bind b) (Expr b) -- ^ Recursive and non recursive @let@s. Operationally - -- this corresponds to allocating a thunk for the things - -- bound and then executing the sub-expression. - -- - -- #top_level_invariant# - -- #letrec_invariant# - -- - -- The right hand sides of all top-level and recursive @let@s - -- /must/ be of lifted type (see "Type#type_classification" for - -- the meaning of /lifted/ vs. /unlifted/). - -- - -- #let_app_invariant# - -- The right hand side of of a non-recursive 'Let' - -- _and_ the argument of an 'App', - -- /may/ be of unlifted type, but only if the expression - -- is ok-for-speculation. This means that the let can be floated - -- around without difficulty. For example, this is OK: - -- - -- > y::Int# = x +# 1# - -- - -- But this is not, as it may affect termination if the - -- expression is floated out: - -- - -- > y::Int# = fac 4# - -- - -- In this situation you should use @case@ rather than a @let@. The function - -- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or - -- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, - -- which will generate a @case@ if necessary - -- - -- #type_let# - -- We allow a /non-recursive/ let to bind a type variable, thus: - -- - -- > Let (NonRec tv (Type ty)) body - -- - -- This can be very convenient for postponing type substitutions until - -- the next run of the simplifier. - -- - -- At the moment, the rest of the compiler only deals with type-let - -- in a Let expression, rather than at top level. We may want to revist - -- this choice. - - | Case (Expr b) b Type [Alt b] -- ^ Case split. Operationally this corresponds to evaluating - -- the scrutinee (expression examined) to weak head normal form - -- and then examining at most one level of resulting constructor (i.e. you - -- cannot do nested pattern matching directly with this). - -- - -- The binder gets bound to the value of the scrutinee, - -- and the 'Type' must be that of all the case alternatives - -- - -- #case_invariants# - -- This is one of the more complicated elements of the Core language, - -- and comes with a number of restrictions: - -- - -- The 'DEFAULT' case alternative must be first in the list, - -- if it occurs at all. - -- - -- The remaining cases are in order of increasing - -- tag (for 'DataAlts') or - -- lit (for 'LitAlts'). - -- This makes finding the relevant constructor easy, - -- and makes comparison easier too. - -- - -- The list of alternatives must be exhaustive. An /exhaustive/ case - -- does not necessarily mention all constructors: - -- - -- @ - -- data Foo = Red | Green | Blue - -- ... case x of - -- Red -> True - -- other -> f (case x of - -- Green -> ... - -- Blue -> ... ) ... - -- @ - -- - -- The inner case does not need a @Red@ alternative, because @x@ - -- can't be @Red@ at that program point. - - | Cast (Expr b) Coercion -- ^ Cast an expression to a particular type. - -- This is used to implement @newtype@s (a @newtype@ constructor or - -- destructor just becomes a 'Cast' in Core) and GADTs. - - | Note Note (Expr b) -- ^ Notes. These allow general information to be - -- added to expressions in the syntax tree - - | Type Type -- ^ A type: this should only show up at the top - -- level of an Arg - - | Coercion Coercion -- ^ A coercion + = Var Id + | Lit Literal + | App (Expr b) (Arg b) + | Lam b (Expr b) + | Let (Bind b) (Expr b) + | Case (Expr b) b Type [Alt b] + | Cast (Expr b) Coercion + | Note Note (Expr b) + | Type Type + | Coercion Coercion deriving (Data, Typeable) -- | Type synonym for expressions that occur in function argument positions. diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 217ed47384..d79641f7dc 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -57,7 +57,7 @@ import BasicTypes ( Arity ) import Type import Coercion import PrelNames -import VarEnv ( mkInScopeSet ) +import VarEnv import Bag import Util import Pair @@ -1212,48 +1212,100 @@ a data constructor. However e might not *look* as if \begin{code} +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + -- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is -- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, -- where t1..tk are the *universally-qantified* type args of 'dc' exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe id_unf expr + = go (Left in_scope) expr (CC [] (mkReflCo (exprType expr))) + where + in_scope = mkInScopeSet (exprFreeVars expr) + + go :: Either InScopeSet Subst + -> CoreExpr -> ConCont + -> Maybe (DataCon, [Type], [CoreExpr]) + go subst (Note note expr) cont + | notSccNote note = go subst expr cont + go subst (Cast expr co1) (CC [] co2) + = go subst expr (CC [] (subst_co subst co1 `mkTransCo` co2)) + go subst (App fun arg) (CC args co) + = go subst fun (CC (subst_arg subst arg : args) co) + go subst (Lam var body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst var arg) body (CC args co) + go (Right sub) (Var v) cont + = go (Left (substInScope sub)) + (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + cont + + go (Left in_scope) (Var fun) cont@(CC args co) + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args + = dealWithCoercion co (con, stripTypeArgs univ_ty_args, rest_args) + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding dfun_nargs con ops <- unfolding + , length args == dfun_nargs -- See Note [DFun arity check] + , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) + mk_arg e = mkApps e args + = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops) + + -- Look through unfoldings, but only cheap ones, because + -- we are effectively duplicating the unfolding + | Just rhs <- expandUnfolding_maybe unfolding + = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $ + let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + res = go (Left in_scope') rhs cont + in WARN( unfoldingArity unfolding > 0 && isJust res, + text "Interesting! exprIsConApp_maybe:" + <+> ppr fun <+> ppr expr) + res + where + unfolding = id_unf fun + + go _ _ _ = Nothing + + ---------------------------- + -- Operations on the (Either InScopeSet CoreSubst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = CoreSubst.substCo s co -exprIsConApp_maybe id_unf (Note note expr) - | notSccNote note - = exprIsConApp_maybe id_unf expr - -- We ignore all notes except SCCs. For example, - -- case _scc_ "foo" (C a b) of - -- C a b -> e - -- should not be optimised away, because we'll lose the - -- entry count on 'foo'; see Trac #4414 + subst_arg (Left {}) e = e + subst_arg (Right s) e = substExpr (text "exprIsConApp") s e + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + +dealWithCoercion :: Coercion + -> (DataCon, [Type], [CoreExpr]) + -> Maybe (DataCon, [Type], [CoreExpr]) +dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args) + | isReflCo co + = Just stuff + + | Pair _from_ty to_ty <- coercionKind co + , Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it -exprIsConApp_maybe id_unf (Cast expr co) = -- Here we do the KPush reduction rule as described in the FC paper -- The transformation applies iff we have -- (C e1 ... en) `cast` co -- where co :: (T t1 .. tn) ~ to_ty -- The left-hand one must be a T, because exprIsConApp returned True -- but the right-hand one might not be. (Though it usually will.) - - case exprIsConApp_maybe id_unf expr of { - Nothing -> Nothing ; - Just (dc, _dc_univ_args, dc_args) -> - - let Pair _from_ty to_ty = coercionKind co - dc_tc = dataConTyCon dc - in - case splitTyConApp_maybe to_ty of { - Nothing -> Nothing ; - Just (to_tc, to_tc_arg_tys) - | dc_tc /= to_tc -> Nothing - -- These two Nothing cases are possible; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there't nothing wrong with it - - | otherwise -> let - tc_arity = tyConArity dc_tc + tc_arity = tyConArity to_tc dc_univ_tyvars = dataConUnivTyVars dc dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc @@ -1262,71 +1314,27 @@ exprIsConApp_maybe id_unf (Cast expr co) -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ map mkReflCo (stripTypeArgs ex_args)) + theta_subst = liftCoSubstWith + (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ map mkReflCo (stripTypeArgs ex_args)) -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg + cast_arg arg_ty arg = mkCoerce (theta_subst arg_ty) arg in #ifdef DEBUG let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr _dc_univ_args, ppr ex_args, ppr val_args] in - ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc ) ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) #endif - Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) - }} - -exprIsConApp_maybe id_unf expr - = analyse expr [] - where - analyse (App fun arg) args = analyse fun (arg:args) - analyse fun@(Lam {}) args = beta fun [] args - - analyse (Var fun) args - | Just con <- isDataConWorkId_maybe fun - , count isValArg args == idArity fun - , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args - = Just (con, stripTypeArgs univ_ty_args, rest_args) - - -- Look through dictionary functions; see Note [Unfolding DFuns] - | DFunUnfolding dfun_nargs con ops <- unfolding - , let sat = length args == dfun_nargs -- See Note [DFun arity check] - in if sat then True else - pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False - , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) - subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - mk_arg e = mkApps e args - = Just (con, substTys subst dfun_res_tys, map mk_arg ops) - -- Look through unfoldings, but only cheap ones, because - -- we are effectively duplicating the unfolding - | Just rhs <- expandUnfolding_maybe unfolding - = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $ - analyse rhs args - where - unfolding = id_unf fun - - analyse _ _ = Nothing - - ----------- - beta (Lam v body) pairs (arg : args) - | isTyCoArg arg - = beta body ((v,arg):pairs) args - - beta (Lam {}) _ _ -- Un-saturated, or not a type lambda - = Nothing - - beta fun pairs args - = analyse (substExpr (text "subst-expr-is-con-app") subst fun) args - where - subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs - -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] + | otherwise + = Nothing stripTypeArgs :: [CoreExpr] -> [Type] stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs new file mode 100644 index 0000000000..55aba2baec --- /dev/null +++ b/compiler/coreSyn/TrieMap.lhs @@ -0,0 +1,602 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +\begin{code} +{-# LANGUAGE TypeFamilies #-} +module TrieMap( + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + TypeMap, + CoercionMap, + MaybeMap, + ListMap, + TrieMap(..) + ) where + +import CoreSyn +import Coercion +import Literal +import Name +import Type +import TypeRep +import Var +import CostCentre +import UniqFM +import Unique( Unique ) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import VarEnv +import NameEnv +import Outputable +import Control.Monad( (>=>) ) +\end{code} + +This module implements TrieMaps, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +The code is very regular and boilerplate-like, but there is +some neat handling of *binders*. In effect they are deBruijn +numbered on the fly. + +%************************************************************************ +%* * + The TrieMap class +%* * +%************************************************************************ + +\begin{code} +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class TrieMap m where + type Key m :: * + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m +\end{code} + +%************************************************************************ +%* * + IntMaps +%* * +%************************************************************************ + +\begin{code} +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.fold k z m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.fold k z m + +instance TrieMap UniqFM where + type Key UniqFM = Unique + emptyTM = emptyUFM + lookupTM k m = lookupUFM m k + alterTM k f m = alterUFM f m k + foldTM k m z = foldUFM k z m +\end{code} + + +%************************************************************************ +%* * + Lists +%* * +%************************************************************************ + +\begin{code} +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + +lkMaybe :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +-------------------- +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b +\end{code} + + +%************************************************************************ +%* * + Basic maps +%* * +%************************************************************************ + +\begin{code} +lkNamed :: NamedThing n => n -> NameEnv a -> Maybe a +lkNamed n env = lookupNameEnv env (getName n) + +xtNamed :: NamedThing n => n -> XT a -> NameEnv a -> NameEnv a +xtNamed tc f m = alterNameEnv f m (getName tc) + +------------------------ +type LiteralMap a = Map.Map Literal a + +emptyLiteralMap :: LiteralMap a +emptyLiteralMap = emptyTM + +lkLit :: Literal -> LiteralMap a -> Maybe a +lkLit = lookupTM + +xtLit :: Literal -> XT a -> LiteralMap a -> LiteralMap a +xtLit = alterTM +\end{code} + +%************************************************************************ +%* * + CoreMap +%* * +%************************************************************************ + +Note [Binders] +~~~~~~~~~~~~~~ + * In general we check binders as late as possible because types are + less likely to differ than expression structure. That's why + cm_lam :: CoreMap (TypeMap a) + rather than + cm_lam :: TypeMap (CoreMap a) + + * We don't need to look at the type of some binders, notalby + - the case binder in (Case _ b _ _) + - the binders in an alternative + because they are totally fixed by the context + + +\begin{code} +data CoreMap a + = EmptyCM + | CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMap a + , cm_type :: TypeMap a + , cm_cast :: CoreMap (CoercionMap a) + , cm_scc :: CoreMap (CostCentreMap a) + , cm_app :: CoreMap (CoreMap a) + , cm_lam :: CoreMap (TypeMap a) + , cm_letn :: CoreMap (CoreMap (BndrMap a)) + , cm_letr :: ListMap CoreMap (CoreMap (ListMap BndrMap a)) + , cm_case :: CoreMap (ListMap AltMap a) + -- Note [Binders] + } + + +wrapEmptyCM :: CoreMap a +wrapEmptyCM = CM { cm_var = emptyTM, cm_lit = emptyLiteralMap + , cm_co = emptyTM, cm_type = emptyTM + , cm_cast = emptyTM, cm_app = emptyTM + , cm_lam = emptyTM, cm_letn = emptyTM + , cm_letr = emptyTM, cm_case = emptyTM + , cm_scc = emptyTM } + +instance TrieMap CoreMap where + type Key CoreMap = CoreExpr + emptyTM = EmptyCM + lookupTM = lkE emptyCME + alterTM = xtE emptyCME + foldTM = fdE + +-------------------------- +lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a +lookupCoreMap cm e = lkE emptyCME e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = xtE emptyCME e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = fdE k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = EmptyCM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldCoreMap (:) [] m) + +------------------------- +fdE :: (a -> b -> b) -> CoreMap a -> b -> b +fdE _ EmptyCM = \z -> z +fdE k m + = foldTM k (cm_var m) + . foldTM k (cm_lit m) + . foldTM k (cm_co m) + . foldTM k (cm_type m) + . foldTM (foldTM k) (cm_cast m) + . foldTM (foldTM k) (cm_scc m) + . foldTM (foldTM k) (cm_app m) + . foldTM (foldTM k) (cm_lam m) + . foldTM (foldTM (foldTM k)) (cm_letn m) + . foldTM (foldTM (foldTM k)) (cm_letr m) + . foldTM (foldTM k) (cm_case m) + +lkE :: CmEnv -> CoreExpr -> CoreMap a -> Maybe a +-- lkE: lookup in trie for expressions +lkE env expr cm + | EmptyCM <- cm = Nothing + | otherwise = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lkLit l + go (Type t) = cm_type >.> lkT env t + go (Coercion c) = cm_co >.> lkC env c + go (Cast e c) = cm_cast >.> lkE env e >=> lkC env c + go (Note (SCC cc) e) = cm_scc >.> lkE env e >=> lkCC cc + go (Note _ e) = lkE env e + go (App e1 e2) = cm_app >.> lkE env e2 >=> lkE env e1 + go (Lam v e) = cm_lam >.> lkE (extendCME env v) e >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkE env r + >=> lkE (extendCME env b) e >=> lkBndr env b + go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr + >.> lkList (lkE env1) rhss >=> lkE env1 e + >=> lkList (lkBndr env1) bndrs + go (Case e b _ as) = cm_case >.> lkE env e + >=> lkList (lkA (extendCME env b)) as + +xtE :: CmEnv -> CoreExpr -> XT a -> CoreMap a -> CoreMap a +xtE env e f EmptyCM = xtE env e f wrapEmptyCM +xtE env (Var v) f m = m { cm_var = cm_var m |> xtVar env v f } +xtE env (Type t) f m = m { cm_type = cm_type m |> xtT env t f } +xtE env (Coercion c) f m = m { cm_co = cm_co m |> xtC env c f } +xtE _ (Lit l) f m = m { cm_lit = cm_lit m |> xtLit l f } +xtE env (Cast e c) f m = m { cm_cast = cm_cast m |> xtE env e |>> + xtC env c f } +xtE env (Note (SCC cc) e) f m = m { cm_scc = cm_scc m |> xtE env e |>> xtCC cc f } +xtE env (Note _ e) f m = xtE env e f m +xtE env (App e1 e2) f m = m { cm_app = cm_app m |> xtE env e2 |>> xtE env e1 f } +xtE env (Lam v e) f m = m { cm_lam = cm_lam m |> xtE (extendCME env v) e + |>> xtBndr env v f } +xtE env (Let (NonRec b r) e) f m = m { cm_letn = cm_letn m + |> xtE (extendCME env b) e + |>> xtE env r |>> xtBndr env b f } +xtE env (Let (Rec prs) e) f m = m { cm_letr = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtE env1) rhss + |>> xtE env1 e + |>> xtList (xtBndr env1) bndrs f } +xtE env (Case e b _ as) f m = m { cm_case = cm_case m |> xtE env e + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +type CostCentreMap a = Map.Map CostCentre a +lkCC :: CostCentre -> CostCentreMap a -> Maybe a +lkCC = lookupTM + +xtCC :: CostCentre -> XT a -> CostCentreMap a -> CostCentreMap a +xtCC = alterTM + +------------------------ +data AltMap a -- A single alternative + = AM { am_deflt :: CoreMap a + , am_data :: NameEnv (CoreMap a) + , am_lit :: LiteralMap (CoreMap a) } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyNameEnv + , am_lit = emptyLiteralMap } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (DEFAULT, _, rhs) = am_deflt >.> lkE env rhs +lkA env (LitAlt lit, _, rhs) = am_lit >.> lkLit lit >=> lkE env rhs +lkA env (DataAlt dc, bs, rhs) = am_data >.> lkNamed dc >=> lkE (extendCMEs env bs) rhs + +xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a +xtA env (DEFAULT, _, rhs) f m = m { am_deflt = am_deflt m |> xtE env rhs f } +xtA env (LitAlt l, _, rhs) f m = m { am_lit = am_lit m |> xtLit l |>> xtE env rhs f } +xtA env (DataAlt d, bs, rhs) f m = m { am_data = am_data m |> xtNamed d + |>> xtE (extendCMEs env bs) rhs f } + +fdA :: (a -> b -> b) -> AltMap a -> b -> b +fdA k m = foldTM k (am_deflt m) + . foldTM (foldTM k) (am_data m) + . foldTM (foldTM k) (am_lit m) +\end{code} + +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ + +\begin{code} +data CoercionMap a + = EmptyKM + | KM { km_refl :: TypeMap a + , km_tc_app :: NameEnv (ListMap CoercionMap a) + , km_app :: CoercionMap (CoercionMap a) + , km_forall :: CoercionMap (TypeMap a) + , km_var :: VarMap a + , km_axiom :: NameEnv (ListMap CoercionMap a) + , km_unsafe :: TypeMap (TypeMap a) + , km_sym :: CoercionMap a + , km_trans :: CoercionMap (CoercionMap a) + , km_nth :: IntMap.IntMap (CoercionMap a) + , km_inst :: CoercionMap (TypeMap a) } + +wrapEmptyKM :: CoercionMap a +wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv + , km_app = emptyTM, km_forall = emptyTM + , km_var = emptyTM, km_axiom = emptyNameEnv + , km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM + , km_nth = emptyTM, km_inst = emptyTM } + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = EmptyKM + lookupTM = lkC emptyCME + alterTM = xtC emptyCME + foldTM = fdC + +lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a +lkC env co m + | EmptyKM <- m = Nothing + | otherwise = go co m + where + go (Refl ty) = km_refl >.> lkT env ty + go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs + go (AxiomInstCo ax cs) = km_axiom >.> lkNamed ax >=> lkList (lkC env) cs + go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2 + go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2 + go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2 + go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t + go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v + go (CoVarCo v) = km_var >.> lkVar env v + go (SymCo c) = km_sym >.> lkC env c + go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c + +xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a +xtC env co f EmptyKM = xtC env co f wrapEmptyKM +xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f } +xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f } +xtC env (AxiomInstCo ax cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtList (xtC env) cs f } +xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f } +xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f } +xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f } +xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f } +xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c + |>> xtBndr env v f } +xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f } +xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f } +xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f } + +fdC :: (a -> b -> b) -> CoercionMap a -> b -> b +fdC _ EmptyKM = \z -> z +fdC k m = foldTM k (km_refl m) + . foldTM (foldTM k) (km_tc_app m) + . foldTM (foldTM k) (km_app m) + . foldTM (foldTM k) (km_forall m) + . foldTM k (km_var m) + . foldTM (foldTM k) (km_axiom m) + . foldTM (foldTM k) (km_unsafe m) + . foldTM k (km_sym m) + . foldTM (foldTM k) (km_trans m) + . foldTM (foldTM k) (km_nth m) + . foldTM (foldTM k) (km_inst m) +\end{code} + + +%************************************************************************ +%* * + Types +%* * +%************************************************************************ + +\begin{code} +data TypeMap a + = EmptyTM + | TM { tm_var :: VarMap a + , tm_app :: TypeMap (TypeMap a) + , tm_fun :: TypeMap (TypeMap a) + , tm_tc_app :: NameEnv (ListMap TypeMap a) + , tm_forall :: TypeMap (BndrMap a) } + +wrapEmptyTypeMap :: TypeMap a +wrapEmptyTypeMap = TM { tm_var = emptyTM + , tm_app = EmptyTM + , tm_fun = EmptyTM + , tm_tc_app = emptyNameEnv + , tm_forall = EmptyTM } + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = EmptyTM + lookupTM = lkT emptyCME + alterTM = xtT emptyCME + foldTM = fdT + +----------------- +lkT :: CmEnv -> Type -> TypeMap a -> Maybe a +lkT env ty m + | EmptyTM <- m = Nothing + | otherwise = go ty m + where + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2 + go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2 + go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys + go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv + go (PredTy {}) = panic "lkT" -- Dealt with by coreView + +----------------- +xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a +xtT env ty f m + | EmptyTM <- m = xtT env ty f wrapEmptyTypeMap + | Just ty' <- coreView ty = xtT env ty' f m + +xtT env (TyVarTy v) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT env (AppTy t1 t2) f m = m { tm_app = tm_app m |> xtT env t1 |>> xtT env t2 f } +xtT env (FunTy t1 t2) f m = m { tm_fun = tm_fun m |> xtT env t1 |>> xtT env t2 f } +xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME env tv) ty + |>> xtBndr env tv f } +xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc + |>> xtList (xtT env) tys f } +xtT _ (PredTy {}) _ _ = panic "xtT" -- Dealt with by coreView + +fdT :: (a -> b -> b) -> TypeMap a -> b -> b +fdT _ EmptyTM = \z -> z +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM (foldTM k) (tm_fun m) + . foldTM (foldTM k) (tm_tc_app m) + . foldTM (foldTM k) (tm_forall m) +\end{code} + + +%************************************************************************ +%* * + Variables +%* * +%************************************************************************ + +\begin{code} +type BoundVar = Int -- Bound variables are deBruijn numbered +type BoundVarMap a = IntMap.IntMap a + +data CmEnv = CME { cme_next :: BoundVar + , cme_env :: VarEnv BoundVar } + +emptyCME :: CmEnv +emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } + +extendCME :: CmEnv -> Var -> CmEnv +extendCME (CME { cme_next = bv, cme_env = env }) v + = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } + +extendCMEs :: CmEnv -> [Var] -> CmEnv +extendCMEs env vs = foldl extendCME env vs + +lookupCME :: CmEnv -> Var -> Maybe BoundVar +lookupCME (CME { cme_env = env }) v = lookupVarEnv env v + +--------- Variable binders ------------- +type BndrMap = TypeMap + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v m = lkT env (varType v) m + +xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v f = xtT env (varType v) f + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: VarEnv a } -- Free variable + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyVarEnv } + lookupTM = lkVar emptyCME + alterTM = xtVar emptyCME + foldTM = fdVar + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkFreeVar v + +xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a +xtVar env v f m + | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> xtInt bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkFreeVar :: Var -> VarEnv a -> Maybe a +lkFreeVar var env = lookupVarEnv env var + +xtFreeVar :: Var -> XT a -> VarEnv a -> VarEnv a +xtFreeVar v f m = alterVarEnv f m v +\end{code}
\ No newline at end of file diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 8ac0eeae80..cf7420e06e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -259,6 +259,7 @@ Library CorePrep CoreSubst CoreSyn + TrieMap CoreTidy CoreUnfold CoreUtils diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 8b56c4f3ae..9d3a3f7361 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -16,7 +16,10 @@ module Linker ( HValue, getHValue, showLinkerState, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs, linkPackages,initDynLinker,linkModule, - dataConInfoPtrToName, lessUnsafeCoerce + dataConInfoPtrToName, lessUnsafeCoerce, + + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) where #include "HsVersions.h" @@ -86,14 +89,23 @@ import Exception The persistent linker state *must* match the actual state of the C dynamic linker at all times, so we keep it in a private global variable. +The global IORef used for PersistentLinkerState actually contains another MVar. +The reason for this is that we want to allow another loaded copy of the GHC +library to side-effect the PLS and for those changes to be reflected here. The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. \begin{code} -GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState) +GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f + +modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f + data PersistentLinkerState = PersistentLinkerState { @@ -138,19 +150,19 @@ emptyPLS _ = PersistentLinkerState { \begin{code} extendLoadedPkgs :: [PackageId] -> IO () extendLoadedPkgs pkgs = - modifyMVar_ v_PersistentLinkerState $ \s -> + modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } extendLinkEnv :: [(Name,HValue)] -> IO () -- Automatically discards shadowed bindings extendLinkEnv new_bindings = - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let new_closure_env = extendClosureEnv (closure_env pls) new_bindings in return pls{ closure_env = new_closure_env } deleteFromLinkEnv :: [Name] -> IO () deleteFromLinkEnv to_remove = - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let new_closure_env = delListFromNameEnv (closure_env pls) to_remove in return pls{ closure_env = new_closure_env } @@ -267,7 +279,7 @@ dataConInfoPtrToName x = do getHValue :: HscEnv -> Name -> IO HValue getHValue hsc_env name = do initDynLinker (hsc_dflags hsc_env) - pls <- modifyMVar v_PersistentLinkerState $ \pls -> do + pls <- modifyPLS $ \pls -> do if (isExternalName name) then do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] if (failed ok) then ghcError (ProgramError "") @@ -313,7 +325,7 @@ withExtendedLinkEnv new_env action -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ do - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } @@ -337,7 +349,7 @@ filterNameMap mods env -- | Display the persistent linker state. showLinkerState :: IO () showLinkerState - = do pls <- readMVar v_PersistentLinkerState + = do pls <- readIORef v_PersistentLinkerState >>= readMVar printDump (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -374,7 +386,7 @@ showLinkerState -- initDynLinker :: DynFlags -> IO () initDynLinker dflags = - modifyMVar_ v_PersistentLinkerState $ \pls0 -> do + modifyPLS_ $ \pls0 -> do done <- readIORef v_InitLinkerDone if done then return pls0 else do writeIORef v_InitLinkerDone True @@ -512,7 +524,7 @@ linkExpr hsc_env span root_ul_bco ; initDynLinker dflags -- Take lock for the actual work. - ; modifyMVar v_PersistentLinkerState $ \pls0 -> do { + ; modifyPLS $ \pls0 -> do { -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods @@ -711,10 +723,10 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods linkModule :: HscEnv -> Module -> IO () linkModule hsc_env mod = do initDynLinker (hsc_dflags hsc_env) - modifyMVar v_PersistentLinkerState $ \pls -> do + modifyPLS_ $ \pls -> do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] if (failed ok) then ghcError (ProgramError "could not link module") - else return (pls',()) + else return pls' -- | Coerce a value as usual, but: -- @@ -921,7 +933,7 @@ unload dflags linkables initDynLinker dflags new_pls - <- modifyMVar v_PersistentLinkerState $ \pls -> do + <- modifyPLS $ \pls -> do pls1 <- unload_wkr dflags linkables pls return (pls1, pls1) @@ -1034,7 +1046,7 @@ linkPackages dflags new_pkgs = do -- It's probably not safe to try to load packages concurrently, so we take -- a lock. initDynLinker dflags - modifyMVar_ v_PersistentLinkerState $ \pls -> do + modifyPLS_ $ \pls -> do linkPackages' dflags new_pkgs pls linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState @@ -1248,3 +1260,19 @@ maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s | otherwise = return () \end{code} + +%************************************************************************ +%* * + Tunneling global variables into new instance of GHC library +%* * +%************************************************************************ + +\begin{code} +saveLinkerGlobals :: IO (MVar PersistentLinkerState, Bool) +saveLinkerGlobals = liftM2 (,) (readIORef v_PersistentLinkerState) (readIORef v_InitLinkerDone) + +restoreLinkerGlobals :: (MVar PersistentLinkerState, Bool) -> IO () +restoreLinkerGlobals (pls, ild) = do + writeIORef v_PersistentLinkerState pls + writeIORef v_InitLinkerDone ild +\end{code}
\ No newline at end of file diff --git a/compiler/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c index f125d4c4d0..805088e753 100644 --- a/compiler/ghci/keepCAFsForGHCi.c +++ b/compiler/ghci/keepCAFsForGHCi.c @@ -7,9 +7,9 @@ // files. #ifdef DYNAMIC -static void keepCAFsForGHCi() __attribute__((constructor)); +static void keepCAFsForGHCi(void) __attribute__((constructor)); -static void keepCAFsForGHCi() +static void keepCAFsForGHCi(void) { keepCAFs = 1; } diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5d0fb8caac..7a86c8180f 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -95,6 +95,9 @@ failWith m = CvtM (\_ -> Left m) returnL :: a -> CvtM (Located a) returnL x = CvtM (\loc -> Right (L loc x)) +wrapParL :: (Located a -> a) -> a -> CvtM a +wrapParL add_par x = CvtM (\loc -> Right (add_par (L loc x))) + wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing wrapMsg what item (CvtM m) @@ -463,7 +466,9 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } - cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) + cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } + -- Note [Dropping constructors] + -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; @@ -481,17 +486,28 @@ cvtl e = wrapL (cvt e) | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } + + -- Infix expressions cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; e' <- returnL $ OpApp x' s' undefined y' - ; return $ HsPar e' } + ; wrapParL HsPar $ + OpApp (mkLHsPar x') s' undefined (mkLHsPar y') } + -- Parenthesise both arguments and result, + -- to ensure this operator application does + -- does not get re-associated + -- See Note [Operator association] cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y - ; sec <- returnL $ SectionR s' y' - ; return $ HsPar sec } + ; wrapParL HsPar $ SectionR s' y' } + -- See Note [Sections in HsSyn] in HsExpr cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s - ; sec <- returnL $ SectionL x' s' - ; return $ HsPar sec } - cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing? + ; wrapParL HsPar $ SectionL x' s' } + + cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } + -- Can I indicate this is an infix thing? + -- Note [Dropping constructors] + + cvt (UInfixE x s y) = do { x' <- cvtl x; cvtOpApp x' s y } -- Note [Converting UInfix] + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t ; return $ ExprWithTySig e' t' } cvt (RecConE c flds) = do { c' <- cNameL c @@ -501,6 +517,22 @@ cvtl e = wrapL (cvt e) ; flds' <- mapM cvtFld flds ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } +{- Note [Dropping constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we drop constructors from the input (for instance, when we encounter @TupE [e]@) +we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ +could meet @UInfix@ constructors containing the @TupE [e]@. For example: + + UInfixE x * (TupE [UInfixE y + z]) + +If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet +and the above expression would be reassociated to + + OpApp (OpApp x * y) + z + +which we don't want. +-} + cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e @@ -512,6 +544,66 @@ cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } +{- Note [Operator assocation] +We must be quite careful about adding parens: + * Infix (UInfix ...) op arg Needs parens round the first arg + * Infix (Infix ...) op arg Needs parens round the first arg + * UInfix (UInfix ...) op arg No parens for first arg + * UInfix (Infix ...) op arg Needs parens round first arg + + +Note [Converting UInfix] +~~~~~~~~~~~~~~~~~~~~~~~~ +When converting @UInfixE@ and @UInfixP@ values, we want to readjust +the trees to reflect the fixities of the underlying operators: + + UInfixE x * (UInfixE y + z) ---> (x * y) + z + +This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in +RnTypes), which expects that the input will be completely left-biased. +So we left-bias the trees of @UInfixP@ and @UInfixE@ that we come across. + +Sample input: + + UInfixE + (UInfixE x op1 y) + op2 + (UInfixE z op3 w) + +Sample output: + + OpApp + (OpApp + (OpApp x op1 y) + op2 + z) + op3 + w + +The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this +left-biasing. +-} + +{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix expressions will be left-biased, provided @x@ is. + +We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis +is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that +this holds for both branches (of @cvtOpApp@), provided we assume it holds for +the recursive calls to @cvtOpApp@. + +When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased +since we have already run @cvtl@ on it. +-} +cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) +cvtOpApp x op1 (UInfixE y op2 z) + = do { l <- wrapL $ cvtOpApp x op1 y + ; cvtOpApp l op2 z } +cvtOpApp x op y + = do { op' <- cvtl op + ; y' <- cvtl y + ; return (OpApp x op' undefined y') } + ------------------------------------- -- Do notation and statements ------------------------------------- @@ -623,33 +715,52 @@ cvtPat pat = wrapL (cvtp pat) cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName) cvtp (TH.LitP l) - | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat l' Nothing) } + | overloadedLit l = do { l' <- cvtOverLit l + ; return (mkNPat l' Nothing) } -- Not right for negative patterns; -- need to think about that! - | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } -cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } -cvtp (TupP [p]) = cvtp p -cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } + | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } +cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } +cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] +cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void } -cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } -cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; return $ ConPatIn s' (InfixCon p1' p2') } -cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } -cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } -cvtp TH.WildP = return $ WildPat void -cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs - ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } -cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } -cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } -cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } +cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps + ; return $ ConPatIn s' (PrefixCon ps') } +cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 + ; wrapParL ParPat $ + ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) } + -- See Note [Operator association] +cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] +cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' } +cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } +cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } +cvtp TH.WildP = return $ WildPat void +cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs + ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } +cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } +cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } +cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } +{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix patterns will be left-biased, provided @x@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) +cvtOpAppP x op1 (UInfixP y op2 z) + = do { l <- wrapL $ cvtOpAppP x op1 y + ; cvtOpAppP l op2 z } +cvtOpAppP x op y + = do { op' <- cNameL op + ; y' <- cvtPat y + ; return (ConPatIn op' (InfixCon x y')) } + ----------------------------------------------------------- -- Types and type variables diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 35bb17b10b..1b556f3d3c 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -120,11 +120,11 @@ data HsExpr id | NegApp (LHsExpr id) -- negated expr (SyntaxExpr id) -- Name of 'negate' - | HsPar (LHsExpr id) -- parenthesised expr + | HsPar (LHsExpr id) -- Parenthesised expr; see Note [Parens in HsSyn] - | SectionL (LHsExpr id) -- operand + | SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn] (LHsExpr id) -- operator - | SectionR (LHsExpr id) -- operator + | SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn] (LHsExpr id) -- operand | ExplicitTuple -- Used for explicit tuples and sections thereof @@ -300,6 +300,28 @@ type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be -- pasted back in by the desugarer \end{code} +Note [Parens in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~ +HsPar (and ParPat in patterns, HsParTy in types) is used as follows + + * Generally HsPar is optional; the pretty printer adds parens where + necessary. Eg (HsApp f (HsApp g x)) is fine, and prints 'f (g x)' + + * HsPars are pretty printed as '( .. )' regardless of whether + or not they are strictly necssary + + * HsPars are respected when rearranging operator fixities. + So a * (b + c) means what it says (where the parens are an HsPar) + +Note [Sections in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~ +Sections should always appear wrapped in an HsPar, thus + HsPar (SectionR ...) +The parser parses sections in a wider variety of situations +(See Note [Parsing sections]), but the renamer checks for those +parens. This invariant makes pretty-printing easier; we don't need +a special case for adding the parens round sections. + Note [Rebindable if] ~~~~~~~~~~~~~~~~~~~~ The rebindable syntax for 'if' is a bit special, because when @@ -400,8 +422,7 @@ ppr_expr (SectionR op expr) pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")]) 4 ((<>) pp_expr rparen) - pp_infixly v - = (sep [pprHsInfix v, pp_expr]) + pp_infixly v = sep [pprHsInfix v, pp_expr] ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (fcat (ppr_tup_args exprs)) @@ -557,29 +578,33 @@ pprDebugParendExpr expr pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprParendExpr expr - = let - pp_as_was = pprLExpr expr + | hsExprNeedsParens (unLoc expr) = parens (pprLExpr expr) + | otherwise = pprLExpr expr -- Using pprLExpr makes sure that we go 'deeper' -- I think that is usually (always?) right - in - case unLoc expr of - ArithSeq {} -> pp_as_was - PArrSeq {} -> pp_as_was - HsLit {} -> pp_as_was - HsOverLit {} -> pp_as_was - HsVar {} -> pp_as_was - HsIPVar {} -> pp_as_was - ExplicitTuple {} -> pp_as_was - ExplicitList {} -> pp_as_was - ExplicitPArr {} -> pp_as_was - HsPar {} -> pp_as_was - HsBracket {} -> pp_as_was - HsBracketOut _ [] -> pp_as_was - HsDo sc _ _ - | isListCompExpr sc -> pp_as_was - _ -> parens pp_as_was - -isAtomicHsExpr :: HsExpr id -> Bool -- A single token + +hsExprNeedsParens :: HsExpr id -> Bool +-- True of expressions for which '(e)' and 'e' +-- mean the same thing +hsExprNeedsParens (ArithSeq {}) = False +hsExprNeedsParens (PArrSeq {}) = False +hsExprNeedsParens (HsLit {}) = False +hsExprNeedsParens (HsOverLit {}) = False +hsExprNeedsParens (HsVar {}) = False +hsExprNeedsParens (HsIPVar {}) = False +hsExprNeedsParens (ExplicitTuple {}) = False +hsExprNeedsParens (ExplicitList {}) = False +hsExprNeedsParens (ExplicitPArr {}) = False +hsExprNeedsParens (HsPar {}) = False +hsExprNeedsParens (HsBracket {}) = False +hsExprNeedsParens (HsBracketOut _ []) = False +hsExprNeedsParens (HsDo sc _ _) + | isListCompExpr sc = False +hsExprNeedsParens _ = True + + +isAtomicHsExpr :: HsExpr id -> Bool +-- True of a single token isAtomicHsExpr (HsVar {}) = True isAtomicHsExpr (HsLit {}) = True isAtomicHsExpr (HsOverLit {}) = True @@ -919,10 +944,10 @@ data StmtLR idL idR } deriving (Data, Typeable) -data TransForm -- The 'f' below is the 'using' function, 'e' is the by function - = ThenForm -- then f or then f by e - | GroupFormU -- group using f or group using f by e - | GroupFormB -- group by e +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupFormU -- group using f or group using f by e (depending on trS_by) + | GroupFormB -- group by e -- In the GroupByFormB, trS_using is filled in with -- 'groupWith' (list comprehensions) or -- 'groupM' (monad comprehensions) diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 7fb5f72533..71dfe1d969 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -68,6 +68,7 @@ data Pat id | LazyPat (LPat id) -- Lazy pattern | AsPat (Located id) (LPat id) -- As pattern | ParPat (LPat id) -- Parenthesised pattern + -- See Note [Parens in HsSyn] in HsExpr | BangPat (LPat id) -- Bang pattern ------------ Lists, tuples, arrays --------------- @@ -238,17 +239,8 @@ pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc pprParendLPat (L _ p) = pprParendPat p pprParendPat :: (OutputableBndr name) => Pat name -> SDoc -pprParendPat p | patNeedsParens p = parens (pprPat p) - | otherwise = pprPat p - -patNeedsParens :: Pat name -> Bool -patNeedsParens (ConPatIn _ d) = not (null (hsConPatArgs d)) -patNeedsParens (ConPatOut { pat_args = d }) = not (null (hsConPatArgs d)) -patNeedsParens (SigPatIn {}) = True -patNeedsParens (SigPatOut {}) = True -patNeedsParens (ViewPat {}) = True -patNeedsParens (CoPat {}) = True -patNeedsParens _ = False +pprParendPat p | hsPatNeedsParens p = parens (pprPat p) + | otherwise = pprPat p pprPat :: (OutputableBndr name) => Pat name -> SDoc pprPat (VarPat var) = pprPatBndr var @@ -268,8 +260,9 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, = getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a if debugStyle sty then -- typechecked Pat in an error message, -- and we want to make sure it prints nicely - ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts), - ppr binds, pprConArgs details] + ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds]) + <+> pprConArgs details else pprUserCon con details pprPat (LitPat s) = ppr s @@ -438,29 +431,29 @@ isIrrefutableHsPat pat urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat) hsPatNeedsParens :: Pat a -> Bool +hsPatNeedsParens (NPlusKPat {}) = True +hsPatNeedsParens (QuasiQuotePat {}) = True +hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds +hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p) +hsPatNeedsParens (SigPatIn {}) = True +hsPatNeedsParens (SigPatOut {}) = True +hsPatNeedsParens (ViewPat {}) = True +hsPatNeedsParens (CoPat {}) = True hsPatNeedsParens (WildPat {}) = False hsPatNeedsParens (VarPat {}) = False hsPatNeedsParens (LazyPat {}) = False hsPatNeedsParens (BangPat {}) = False -hsPatNeedsParens (CoPat {}) = True hsPatNeedsParens (ParPat {}) = False hsPatNeedsParens (AsPat {}) = False -hsPatNeedsParens (ViewPat {}) = True -hsPatNeedsParens (SigPatIn {}) = True -hsPatNeedsParens (SigPatOut {}) = True hsPatNeedsParens (TuplePat {}) = False hsPatNeedsParens (ListPat {}) = False hsPatNeedsParens (PArrPat {}) = False -hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds -hsPatNeedsParens (ConPatOut {}) = True hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False -hsPatNeedsParens (NPlusKPat {}) = True -hsPatNeedsParens (QuasiQuotePat {}) = True conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon args) = not (null args) -conPatNeedsParens (InfixCon {}) = False -conPatNeedsParens (RecCon {}) = False +conPatNeedsParens (InfixCon {}) = True +conPatNeedsParens (RecCon {}) = True \end{code} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index d565c96d29..35cdb7ee5e 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -161,13 +161,9 @@ data HsType name | HsOpTy (LHsType name) (Located name) (LHsType name) - | HsParTy (LHsType name) + | HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! - -- - -- However, NB that toHsType doesn't add HsParTys (in an effort to keep - -- interface files smaller), so when printing a HsType we may need to - -- add parens. | HsPredTy (HsPred name) -- Only used in the type of an instance -- declaration, eg. Eq [a] -> Eq a diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 6ddbd99bd4..3ae566d935 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -22,6 +22,7 @@ module HsUtils( mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, coToHsWrapper, mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, + mkLHsPar, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -35,7 +36,7 @@ module HsUtils( -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat, - nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, + nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, mkParPat, -- Types mkHsAppTy, userHsTyVarBndrs, @@ -120,15 +121,50 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds unguardedRHS :: LHsExpr id -> [LGRHS id] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] +mkMatchGroup :: [LMatch id] -> MatchGroup id +mkMatchGroup matches = MatchGroup matches placeHolderType + mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) +mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id +mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) + where + matches = mkMatchGroup [mkSimpleMatch pats body] + +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr + +mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id +-- Used for constructing dictionary terms etc, so no locations +mkHsConApp data_con tys args + = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args + where + mk_app f a = noLoc (HsApp f (noLoc a)) + +mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id +-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking +mkSimpleHsAlt pat expr + = mkSimpleMatch [pat] expr + nlHsTyApp :: name -> [Type] -> LHsExpr name nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id)) +--------- Adding parens --------- +mkLHsPar :: LHsExpr name -> LHsExpr name +-- Wrap in parens if hsExprNeedsParens says it needs them +-- So 'f x' becomes '(f x)', but '3' stays as '3' +mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le) + | otherwise = le + +mkParPat :: LPat name -> LPat name +mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) + | otherwise = lp + +--------- HsWrappers: type args, dict args, casts --------- mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) @@ -156,31 +192,9 @@ mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id mkHsWrapPatCo (Refl _) pat _ = pat mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty -mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id -mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) - where - matches = mkMatchGroup [mkSimpleMatch pats body] - -mkMatchGroup :: [LMatch id] -> MatchGroup id -mkMatchGroup matches = MatchGroup matches placeHolderType - -mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id -mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr - mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr -mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id --- Used for constructing dictionary terms etc, so no locations -mkHsConApp data_con tys args - = foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args - where - mk_app f a = noLoc (HsApp f (noLoc a)) - -mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id --- A simple lambda with a single pattern, no binds, no guards; pre-typechecking -mkSimpleHsAlt pat expr - = mkSimpleMatch [pat] expr ------------------------------- -- These are the bits of syntax that contain rebindable names diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 7817b423ae..89cc755876 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -338,15 +338,18 @@ toIfaceKind = toIfaceType --------------------- toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type -toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyCoVar tv) +toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) toIfaceType (PredTy st) = IfacePredTy (toIfacePred toIfaceType st) -toIfaceTyCoVar :: TyCoVar -> FastString -toIfaceTyCoVar = occNameFS . getOccName +toIfaceTyVar :: TyVar -> FastString +toIfaceTyVar = occNameFS . getOccName + +toIfaceCoVar :: CoVar -> FastString +toIfaceCoVar = occNameFS . getOccName ---------------- -- A little bit of (perhaps optional) trickiness here. When @@ -408,7 +411,7 @@ coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1) (coToIfaceType co2) coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v) (coToIfaceType co) -coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceTyCoVar cv) +coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceCoVar cv) coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con)) (map coToIfaceType cos) coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index b328c3fb4d..b1f50acfb8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1666,6 +1666,17 @@ linkBinary dflags o_files dep_packages = do then ["-Wl,--enable-auto-import"] else []) + -- '-no_pie' - On OS X, the linker otherwise complains that it cannot build + -- position independent code due to some offensive code in GMP. + -- '-no_compact_unwind' + -- - C++/Objective-C exceptions cannot use optimised stack + -- unwinding code (the optimised form is the default in Xcode 4 on + -- x86_64). + ++ (if platformOS (targetPlatform dflags) == OSDarwin && + platformArch (targetPlatform dflags) == ArchX86_64 + then ["-Wl,-no_pie", "-Wl,-no_compact_unwind"] + else []) + ++ o_files ++ extra_ld_inputs ++ lib_path_opts diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index afa8a1ca74..dece548043 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2011 @@ -1459,51 +1461,32 @@ multiRootsErr summs@(summ1:_) cyclicModuleErr :: [ModSummary] -> SDoc -- From a strongly connected component we find -- a single cycle to report -cyclicModuleErr ms - = ASSERT( not (null ms) ) - hang (ptext (sLit "Module imports form a cycle:")) - 2 (show_path (shortest [] root_mod)) +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss + Just path -> vcat [ ptext (sLit "Module imports form a cycle:") + , nest 2 (show_path path) ] where - deps :: [(ModuleName, [ModuleName])] - deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ] - - get_deps :: ModSummary -> [ModuleName] - get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m)) - - dep_env :: Map.Map ModuleName [ModuleName] - dep_env = Map.fromList deps - - -- Find the module with fewest imports among the SCC modules - -- This is just a heuristic to find some plausible root module - root_mod :: ModuleName - root_mod = fst (minWith (length . snd) deps) - - shortest :: [ModuleName] -> ModuleName -> [ModuleName] - -- (shortest [v1,v2,..,vn] m) assumes that - -- m is imported by v1 - -- which is imported by v2 - -- ... - -- which is imported by vn - -- It retuns an import chain [w1, w2, ..wm] - -- where w1 imports w2 imports .... imports wm imports w1 - shortest visited m - | m `elem` visited - = m : reverse (takeWhile (/= m) visited) - | otherwise - = minWith length (map (shortest (m:visited)) deps) - where - Just deps = Map.lookup m dep_env + graph :: [Node NodeKey ModSummary] + graph = [(ms, msKey ms, get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ]) show_path [] = panic "show_path" - show_path [m] = ptext (sLit "module") <+> quotes (ppr m) + show_path [m] = ptext (sLit "module") <+> ppr_ms m <+> ptext (sLit "imports itself") - show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1) - <+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2)) - : go ms) + show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1) + : nest 6 (ptext (sLit "imports") <+> ppr_ms m2) + : go ms ) where - go [] = [ptext (sLit "which imports") <+> quotes (ppr m1)] - go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms + go [] = [ptext (sLit "which imports") <+> ppr_ms m1] + go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms -minWith :: Ord b => (a -> b) -> [a] -> a -minWith get_key xs = ASSERT( not (null xs) ) - head (sortWith get_key xs) + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) + diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index b07601bc0f..c7a281cff8 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -70,8 +70,8 @@ getImports dflags buf filename source_filename = do case rdr_module of L _ (HsModule mb_mod _ imps _ _ _) -> let - main_loc = mkSrcLoc (mkFastString source_filename) 1 1 - mod = mb_mod `orElse` L (srcLocSpan main_loc) mAIN_NAME + main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1) + mod = mb_mod `orElse` L main_loc mAIN_NAME (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps -- GHC.Prim doesn't exist physically, so don't go looking for it. @@ -79,18 +79,20 @@ getImports dflags buf filename source_filename = do ord_idecls implicit_prelude = xopt Opt_ImplicitPrelude dflags - implicit_imports = mkPrelImports (unLoc mod) implicit_prelude imps + implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps in return (src_idecls, implicit_imports ++ ordinary_imps, mod) -mkPrelImports :: ModuleName -> Bool -> [LImportDecl RdrName] +mkPrelImports :: ModuleName + -> SrcSpan -- Attribute the "import Prelude" to this location + -> Bool -> [LImportDecl RdrName] -> [LImportDecl RdrName] -- Consruct the implicit declaration "import Prelude" (or not) -- -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance -- declarations, whereas the latter does. -mkPrelImports this_mod implicit_prelude import_decls +mkPrelImports this_mod loc implicit_prelude import_decls | this_mod == pRELUDE_NAME || explicit_prelude_import || not implicit_prelude @@ -112,8 +114,6 @@ mkPrelImports this_mod implicit_prelude import_decls Nothing {- No "as" -} Nothing {- No import list -} - loc = mkGeneralSrcSpan (fsLit "Implicit import declaration") - parseError :: SrcSpan -> Message -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index f1635d1fa7..5ae01766e9 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -309,9 +309,12 @@ hscRnImportDecls -- because tcRnImports will force-load any orphan modules necessary, making extra -- instances/family instances visible (GHC #4832) hscRnImportDecls hsc_env this_mod import_decls - = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ - fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls - + = runHsc hsc_env $ ioMsgMaybe $ + initTc hsc_env HsSrcFile False this_mod $ + fmap tcg_rdr_env $ + tcRnImports hsc_env this_mod loc import_decls + where + loc = mkGeneralSrcSpan (mkFastString "In a call to hscRnImportDecls") #endif -- ----------------------------------------------------------------------------- diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index c542d761f0..307f6f104a 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -85,7 +85,10 @@ module StaticFlags ( opt_Ticky, -- For the parser - addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready + addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready, + + -- Saving/restoring globals + saveStaticFlagGlobals, restoreStaticFlagGlobals ) where #include "HsVersions.h" @@ -96,6 +99,7 @@ import Util import Maybes ( firstJusts, catMaybes ) import Panic +import Control.Monad ( liftM3 ) import Data.Maybe ( listToMaybe ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) @@ -562,3 +566,21 @@ way_details = [ "-XParr" , "-fvectorise"] ] + +----------------------------------------------------------------------------- +-- Tunneling our global variables into a new instance of the GHC library + +-- Ignore the v_Ld_inputs global because: +-- a) It is mutated even once GHC has been initialised, which means that I'd +-- have to add another layer of indirection to truly share the value +-- b) We can get away without sharing it because it only affects the link, +-- and is mutated by the GHC exe. Users who load up a new copy of the GHC +-- library while another is running almost certainly won't actually access it. +saveStaticFlagGlobals :: IO (Bool, [String], [Way]) +saveStaticFlagGlobals = liftM3 (,,) (readIORef v_opt_C_ready) (readIORef v_opt_C) (readIORef v_Ways) + +restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO () +restoreStaticFlagGlobals (c_ready, c, ways) = do + writeIORef v_opt_C_ready c_ready + writeIORef v_opt_C c + writeIORef v_Ways ways diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 05e0222182..d199fb534f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1437,7 +1437,7 @@ texp :: { LHsExpr RdrName } -- Then when converting expr to pattern we unravel it again -- Meanwhile, the renamer checks that real sections appear -- inside parens. - | infixexp qop { LL $ SectionL $1 $2 } + | infixexp qop { LL $ SectionL $1 $2 } | qopm infixexp { LL $ SectionR $1 $2 } -- View patterns get parenthesized above diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index c9fa8eab20..d677c74000 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -6,24 +6,24 @@ Nota Bene: all Names defined in here should come from the base package - - ModuleNames for prelude modules, - e.g. pREL_BASE_Name :: ModuleName + - ModuleNames for prelude modules, + e.g. pREL_BASE_Name :: ModuleName - Modules for prelude modules - e.g. pREL_Base :: Module + e.g. pREL_Base :: Module - - Uniques for Ids, DataCons, TyCons and Classes that the compiler + - Uniques for Ids, DataCons, TyCons and Classes that the compiler "knows about" in some way - e.g. intTyConKey :: Unique - minusClassOpKey :: Unique + e.g. intTyConKey :: Unique + minusClassOpKey :: Unique - - Names for Ids, DataCons, TyCons and Classes that the compiler + - Names for Ids, DataCons, TyCons and Classes that the compiler "knows about" in some way - e.g. intTyConName :: Name - minusName :: Name + e.g. intTyConName :: Name + minusName :: Name One of these Names contains - (a) the module and occurrence name of the thing - (b) its Unique + (a) the module and occurrence name of the thing + (b) its Unique The may way the compiler "knows about" one of these things is where the type checker or desugarer needs to look it up. For example, when desugaring list comprehensions the desugarer @@ -37,26 +37,26 @@ Nota Bene: all Names defined in here should come from the base package \begin{code} module PrelNames ( - Unique, Uniquable(..), hasKey, -- Re-exported for convenience - - ----------------------------------------------------------- - module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName - -- (b) Uniques e.g. intTyConKey - -- (c) Groups of classes and types - -- (d) miscellaneous things - -- So many that we export them all + Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all ) where #include "HsVersions.h" import Module import OccName -import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) -import Unique ( Unique, Uniquable(..), hasKey, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkTupleTyConUnique - ) +import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) +import Unique ( Unique, Uniquable(..), hasKey, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkTupleTyConUnique + ) import BasicTypes ( Boxity(..), Arity ) import Name ( Name, mkInternalName, mkExternalName, mkSystemVarName ) import SrcLoc @@ -65,9 +65,9 @@ import FastString %************************************************************************ -%* * +%* * \subsection{Local Names} -%* * +%* * %************************************************************************ This *local* name is used by the interactive stuff @@ -98,7 +98,7 @@ This section tells what the compiler knows about the association of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. -The names for DPH can come from one of multiple backend packages. At the point where +The names for DPH can come from one of multiple backend packages. At the point where 'basicKnownKeyNames' is used, we don't know which backend it will be. Hence, we list the names for multiple backends. That works out fine, although they use the same uniques, as we are guaranteed to only load one backend; hence, only one of the different names @@ -110,39 +110,37 @@ basicKnownKeyNames = genericTyConNames ++ typeableClassNames ++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId - ++ [ -- Type constructors (synonyms especially) - ioTyConName, ioDataConName, - runMainIOName, - orderingTyConName, - rationalTyConName, - stringTyConName, - ratioDataConName, - ratioTyConName, - integerTyConName, smallIntegerName, - - -- Classes. *Must* include: - -- classes that are grabbed by key (e.g., eqClassKey) - -- classes in "Class.standardClassKeys" (quite a few) - eqClassName, -- mentioned, derivable - ordClassName, -- derivable - boundedClassName, -- derivable - numClassName, -- mentioned, numeric - enumClassName, -- derivable - monadClassName, - functorClassName, - realClassName, -- numeric - integralClassName, -- numeric - fractionalClassName, -- numeric - floatingClassName, -- numeric - realFracClassName, -- numeric - realFloatClassName, -- numeric - dataClassName, - isStringClassName, - applicativeClassName, - foldableClassName, - traversableClassName, - - -- Numeric stuff + ++ [ -- Type constructors (synonyms especially) + ioTyConName, ioDataConName, + runMainIOName, + rationalTyConName, + stringTyConName, + ratioDataConName, + ratioTyConName, + + -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + isStringClassName, + applicativeClassName, + foldableClassName, + traversableClassName, + + -- Numeric stuff negateName, minusName, geName, eqName, -- Conversion functions @@ -152,84 +150,97 @@ basicKnownKeyNames -- String stuff fromStringName, - - -- Enum stuff - enumFromName, enumFromThenName, - enumFromThenToName, enumFromToName, - - -- Monad stuff - thenIOName, bindIOName, returnIOName, failIOName, - failMName, bindMName, thenMName, returnMName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, + failMName, bindMName, thenMName, returnMName, fmapName, - -- MonadRec stuff - mfixName, + -- MonadRec stuff + mfixName, - -- Arrow stuff - arrAName, composeAName, firstAName, - appAName, choiceAName, loopAName, + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, - -- Ix stuff - ixClassName, + -- Ix stuff + ixClassName, - -- Show stuff - showClassName, + -- Show stuff + showClassName, - -- Read stuff - readClassName, + -- Read stuff + readClassName, - -- Stable pointers - newStablePtrName, + -- Stable pointers + newStablePtrName, -- GHC Extensions groupWithName, - -- Strings and lists - unpackCStringName, unpackCStringAppendName, - unpackCStringFoldrName, unpackCStringUtf8Name, + -- Strings and lists + unpackCStringName, + unpackCStringFoldrName, unpackCStringUtf8Name, - -- List operations - concatName, filterName, mapName, - zipName, foldrName, buildName, augmentName, appendName, + -- List operations + concatName, filterName, mapName, + zipName, foldrName, buildName, augmentName, appendName, - dollarName, -- The ($) apply function + dollarName, -- The ($) apply function - -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, - int8TyConName, int16TyConName, int32TyConName, int64TyConName, - wordTyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + wordTyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, - -- Others - otherwiseIdName, inlineIdName, - plusIntegerName, timesIntegerName, - eqStringName, assertName, breakpointName, breakpointCondName, + -- Others + otherwiseIdName, inlineIdName, + eqStringName, assertName, breakpointName, breakpointCondName, breakpointAutoName, opaqueTyConName, assertErrorName, runSTRepName, - printName, fstName, sndName, + printName, fstName, sndName, + + -- Integer + integerTyConName, plusIntegerName, timesIntegerName, smallIntegerName, + integerToWordName, integerToIntName, minusIntegerName, + negateIntegerName, eqIntegerName, neqIntegerName, + absIntegerName, signumIntegerName, + leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, + compareIntegerName, + gcdIntegerName, lcmIntegerName, + andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, + shiftLIntegerName, shiftRIntegerName, - -- MonadFix - monadFixClassName, mfixName, + -- MonadFix + monadFixClassName, mfixName, - -- Other classes - randomClassName, randomGenClassName, monadPlusClassName, + -- Other classes + randomClassName, randomGenClassName, monadPlusClassName, -- Annotation type checking toAnnotationWrapperName - -- The Either type - , eitherTyConName, leftDataConName, rightDataConName + -- The Ordering type + , orderingTyConName, ltDataConName, eqDataConName, gtDataConName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName -- Plugins , pluginTyConName - - -- dotnet interop - , objectTyConName, marshalObjectName, unmarshalObjectName - , marshalStringName, unmarshalStringName, checkDotnetResName - - -- Generics - , genClassName, gen1ClassName - , datatypeClassName, constructorClassName, selectorClassName - + + -- dotnet interop + , objectTyConName, marshalObjectName, unmarshalObjectName + , marshalStringName, unmarshalStringName, checkDotnetResName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + -- Monad comprehensions , guardMName , liftMName @@ -254,31 +265,31 @@ dphKnownKeyNames dphPkg = map ($ dphPkg) [ -- Parallel array operations - nullPName, lengthPName, replicatePName, singletonPName, mapPName, - filterPName, zipPName, crossMapPName, indexPName, - toPName, emptyPName, appPName, - enumFromToPName, enumFromThenToPName + nullPName, lengthPName, replicatePName, singletonPName, mapPName, + filterPName, zipPName, crossMapPName, indexPName, + toPName, emptyPName, appPName, + enumFromToPName, enumFromThenToPName ] \end{code} %************************************************************************ -%* * +%* * \subsection{Module names} -%* * +%* * %************************************************************************ --MetaHaskell Extension Add a new module here \begin{code} pRELUDE :: Module -pRELUDE = mkBaseModule_ pRELUDE_NAME +pRELUDE = mkBaseModule_ pRELUDE_NAME gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, @@ -287,59 +298,58 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module -gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values +gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") -gHC_UNIT = mkPrimModule (fsLit "GHC.Unit") -gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering") -gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") -gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") -gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") - -gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes") -gHC_BASE = mkBaseModule (fsLit "GHC.Base") -gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") -gHC_SHOW = mkBaseModule (fsLit "GHC.Show") -gHC_READ = mkBaseModule (fsLit "GHC.Read") -gHC_NUM = mkBaseModule (fsLit "GHC.Num") -gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") +gHC_UNIT = mkPrimModule (fsLit "GHC.Unit") +gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering") +gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") +gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") +gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") +gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") + +gHC_BASE = mkBaseModule (fsLit "GHC.Base") +gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_SHOW = mkBaseModule (fsLit "GHC.Show") +gHC_READ = mkBaseModule (fsLit "GHC.Read") +gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") gHC_LIST = mkBaseModule (fsLit "GHC.List") gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") -dATA_EITHER = mkBaseModule (fsLit "Data.Either") -dATA_STRING = mkBaseModule (fsLit "Data.String") -dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") +dATA_EITHER = mkBaseModule (fsLit "Data.Either") +dATA_STRING = mkBaseModule (fsLit "Data.String") +dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") -gHC_CONC = mkBaseModule (fsLit "GHC.Conc") -gHC_IO = mkBaseModule (fsLit "GHC.IO") +gHC_CONC = mkBaseModule (fsLit "GHC.Conc") +gHC_IO = mkBaseModule (fsLit "GHC.IO") gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") -gHC_ST = mkBaseModule (fsLit "GHC.ST") -gHC_ARR = mkBaseModule (fsLit "GHC.Arr") -gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") -gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") -gHC_ERR = mkBaseModule (fsLit "GHC.Err") -gHC_REAL = mkBaseModule (fsLit "GHC.Real") -gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") -gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") -sYSTEM_IO = mkBaseModule (fsLit "System.IO") -dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") +gHC_ST = mkBaseModule (fsLit "GHC.ST") +gHC_ARR = mkBaseModule (fsLit "GHC.Arr") +gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") +gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") +gHC_ERR = mkBaseModule (fsLit "GHC.Err") +gHC_REAL = mkBaseModule (fsLit "GHC.Real") +gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") +gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") +sYSTEM_IO = mkBaseModule (fsLit "System.IO") +dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") tYPEABLE = mkBaseModule (fsLit "Data.Typeable") tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") gENERICS = mkBaseModule (fsLit "Data.Data") -dOTNET = mkBaseModule (fsLit "GHC.Dotnet") -rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") -lEX = mkBaseModule (fsLit "Text.Read.Lex") -gHC_INT = mkBaseModule (fsLit "GHC.Int") -gHC_WORD = mkBaseModule (fsLit "GHC.Word") -mONAD = mkBaseModule (fsLit "Control.Monad") -mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") +dOTNET = mkBaseModule (fsLit "GHC.Dotnet") +rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") +lEX = mkBaseModule (fsLit "Text.Read.Lex") +gHC_INT = mkBaseModule (fsLit "GHC.Int") +gHC_WORD = mkBaseModule (fsLit "GHC.Word") +mONAD = mkBaseModule (fsLit "Control.Monad") +mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") mONAD_GROUP = mkBaseModule (fsLit "Control.Monad.Group") mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") -aRROW = mkBaseModule (fsLit "Control.Arrow") +aRROW = mkBaseModule (fsLit "Control.Arrow") cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") -rANDOM = mkBaseModule (fsLit "System.Random") -gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") +rANDOM = mkBaseModule (fsLit "System.Random") +gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") gHC_PARR :: PackageId -> Module @@ -349,13 +359,13 @@ gHC_PARR' :: Module gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") mAIN, rOOT_MAIN :: Module -mAIN = mkMainModule_ mAIN_NAME -rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation +mAIN = mkMainModule_ mAIN_NAME +rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation - -- The ':xxx' makes a module name that the user can never - -- use himself. The z-encoding for ':' is "ZC", so the z-encoded - -- module name still starts with a capital letter, which keeps - -- the z-encoded version consistent. + -- The ':xxx' makes a module name that the user can never + -- use himself. The z-encoding for ':' is "ZC", so the z-encoded + -- module name still starts with a capital letter, which keeps + -- the z-encoded version consistent. iNTERACTIVE :: Module iNTERACTIVE = mkMainModule (fsLit ":Interactive") @@ -389,9 +399,9 @@ mkMainModule_ m = mkModule mainPackageId m \end{code} %************************************************************************ -%* * +%* * \subsection{Constructing the names of tuples -%* * +%* * %************************************************************************ \begin{code} @@ -403,16 +413,16 @@ mkTupleModule Unboxed _ = gHC_PRIM %************************************************************************ -%* * - RdrNames -%* * +%* * + RdrNames +%* * %************************************************************************ \begin{code} main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName (fsLit "main") - -- We definitely don't want an Orig RdrName, because - -- main might, in principle, be imported into module Main +main_RDR_Unqual = mkUnqual varName (fsLit "main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main forall_tv_RDR, dot_tv_RDR :: RdrName forall_tv_RDR = mkUnqual tvName (fsLit "forall") @@ -420,101 +430,101 @@ dot_tv_RDR = mkUnqual tvName (fsLit ".") eq_RDR, ge_RDR, ne_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName -eq_RDR = nameRdrName eqName -ge_RDR = nameRdrName geName -ne_RDR = varQual_RDR gHC_CLASSES (fsLit "/=") -le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") -lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") -gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") -compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") -ltTag_RDR = dataQual_RDR gHC_ORDERING (fsLit "LT") -eqTag_RDR = dataQual_RDR gHC_ORDERING (fsLit "EQ") -gtTag_RDR = dataQual_RDR gHC_ORDERING (fsLit "GT") +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +ne_RDR = varQual_RDR gHC_CLASSES (fsLit "/=") +le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") +lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") +gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") +compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") +ltTag_RDR = dataQual_RDR gHC_ORDERING (fsLit "LT") +eqTag_RDR = dataQual_RDR gHC_ORDERING (fsLit "EQ") +gtTag_RDR = dataQual_RDR gHC_ORDERING (fsLit "GT") eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR :: RdrName -eqClass_RDR = nameRdrName eqClassName -numClass_RDR = nameRdrName numClassName -ordClass_RDR = nameRdrName ordClassName -enumClass_RDR = nameRdrName enumClassName -monadClass_RDR = nameRdrName monadClassName +eqClass_RDR = nameRdrName eqClassName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName map_RDR, append_RDR :: RdrName -map_RDR = varQual_RDR gHC_BASE (fsLit "map") -append_RDR = varQual_RDR gHC_BASE (fsLit "++") +map_RDR = varQual_RDR gHC_BASE (fsLit "map") +append_RDR = varQual_RDR gHC_BASE (fsLit "++") foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR :: RdrName -foldr_RDR = nameRdrName foldrName -build_RDR = nameRdrName buildName -returnM_RDR = nameRdrName returnMName -bindM_RDR = nameRdrName bindMName -failM_RDR = nameRdrName failMName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName left_RDR, right_RDR :: RdrName -left_RDR = nameRdrName leftDataConName -right_RDR = nameRdrName rightDataConName +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName fromEnum_RDR, toEnum_RDR :: RdrName -fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") -toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") +fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") +toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName -enumFrom_RDR = nameRdrName enumFromName -enumFromTo_RDR = nameRdrName enumFromToName -enumFromThen_RDR = nameRdrName enumFromThenName -enumFromThenTo_RDR = nameRdrName enumFromThenToName +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName -ratioDataCon_RDR = nameRdrName ratioDataConName -plusInteger_RDR = nameRdrName plusIntegerName -timesInteger_RDR = nameRdrName timesIntegerName +ratioDataCon_RDR = nameRdrName ratioDataConName +plusInteger_RDR = nameRdrName plusIntegerName +timesInteger_RDR = nameRdrName timesIntegerName ioDataCon_RDR :: RdrName -ioDataCon_RDR = nameRdrName ioDataConName +ioDataCon_RDR = nameRdrName ioDataConName eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR :: RdrName -eqString_RDR = nameRdrName eqStringName -unpackCString_RDR = nameRdrName unpackCStringName -unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName -unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name +eqString_RDR = nameRdrName eqStringName +unpackCString_RDR = nameRdrName unpackCStringName +unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName +unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR, wordDataCon_RDR :: RdrName -newStablePtr_RDR = nameRdrName newStablePtrName -wordDataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W#") +newStablePtr_RDR = nameRdrName newStablePtrName +wordDataCon_RDR = dataQual_RDR gHC_WORD (fsLit "W#") bindIO_RDR, returnIO_RDR :: RdrName -bindIO_RDR = nameRdrName bindIOName -returnIO_RDR = nameRdrName returnIOName +bindIO_RDR = nameRdrName bindIOName +returnIO_RDR = nameRdrName returnIOName fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName -fromInteger_RDR = nameRdrName fromIntegerName -fromRational_RDR = nameRdrName fromRationalName -minus_RDR = nameRdrName minusName -times_RDR = varQual_RDR gHC_NUM (fsLit "*") +fromInteger_RDR = nameRdrName fromIntegerName +fromRational_RDR = nameRdrName fromRationalName +minus_RDR = nameRdrName minusName +times_RDR = varQual_RDR gHC_NUM (fsLit "*") plus_RDR = varQual_RDR gHC_NUM (fsLit "+") fromString_RDR :: RdrName -fromString_RDR = nameRdrName fromStringName +fromString_RDR = nameRdrName fromStringName compose_RDR :: RdrName -compose_RDR = varQual_RDR gHC_BASE (fsLit ".") +compose_RDR = varQual_RDR gHC_BASE (fsLit ".") not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, and_RDR, range_RDR, inRange_RDR, index_RDR, unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName -and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") -not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") -getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") -succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") +and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") +not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") +getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") +succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") range_RDR = varQual_RDR gHC_ARR (fsLit "range") inRange_RDR = varQual_RDR gHC_ARR (fsLit "inRange") -index_RDR = varQual_RDR gHC_ARR (fsLit "index") -unsafeIndex_RDR = varQual_RDR gHC_ARR (fsLit "unsafeIndex") -unsafeRangeSize_RDR = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize") +index_RDR = varQual_RDR gHC_ARR (fsLit "index") +unsafeIndex_RDR = varQual_RDR gHC_ARR (fsLit "unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize") readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR :: RdrName @@ -534,7 +544,7 @@ symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") step_RDR, alt_RDR, reset_RDR, prec_RDR :: RdrName step_RDR = varQual_RDR rEAD_PREC (fsLit "step") -alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") +alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") @@ -542,10 +552,10 @@ showList_RDR, showList___RDR, showsPrec_RDR, showString_RDR, showSpace_RDR, showParen_RDR :: RdrName showList_RDR = varQual_RDR gHC_SHOW (fsLit "showList") showList___RDR = varQual_RDR gHC_SHOW (fsLit "showList__") -showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") +showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") -showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") -showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") +showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") +showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName typeOf_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf") @@ -558,13 +568,6 @@ undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") error_RDR :: RdrName error_RDR = varQual_RDR gHC_ERR (fsLit "error") --- Old Generics (constructors and functions) -crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName -crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") -inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl") -inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr") -genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit") - -- Generics (constructors and functions) u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, @@ -609,11 +612,11 @@ notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName -fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") -pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") -ap_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "<*>") -foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") -traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") +fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") +pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") +ap_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "<*>") +foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") +traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") ---------------------- varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR @@ -625,9 +628,9 @@ dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) \end{code} %************************************************************************ -%* * +%* * \subsection{Known-key names} -%* * +%* * %************************************************************************ Many of these Names are not really "built in", but some parts of the @@ -635,7 +638,7 @@ compiler (notably the deriving mechanism) need to mention their names, and it's convenient to write them all down in one place. --MetaHaskell Extension add the constrs and the lower case case --- guys as well (perhaps) e.g. see trueDataConName below +-- guys as well (perhaps) e.g. see trueDataConName below \begin{code} @@ -645,18 +648,21 @@ wildCardName = mkSystemVarName wildCardKey (fsLit "wild") runMainIOName :: Name runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey -orderingTyConName :: Name +orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name orderingTyConName = tcQual gHC_ORDERING (fsLit "Ordering") orderingTyConKey +ltDataConName = conName gHC_ORDERING (fsLit "LT") ltDataConKey +eqDataConName = conName gHC_ORDERING (fsLit "EQ") eqDataConKey +gtDataConName = conName gHC_ORDERING (fsLit "GT") gtDataConKey eitherTyConName, leftDataConName, rightDataConName :: Name -eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey +eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName, k1TyConName, m1TyConName, sumTyConName, prodTyConName, - compTyConName, rTyConName, pTyConName, dTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, cTyConName, sTyConName, rec0TyConName, par0TyConName, d1TyConName, c1TyConName, s1TyConName, noSelTyConName, repTyConName, rep1TyConName :: Name @@ -689,18 +695,17 @@ repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey -- Base strings Strings -unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName, +unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, stringTyConName :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey -eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey +eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey -- The 'inline' function inlineIdName :: Name -inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey -- The 'undefined' function. Used by supercompilation. undefinedName :: Name @@ -708,20 +713,20 @@ undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey -- Base classes (Eq, Ord, Functor) fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name -eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey -eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey -ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey -geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName, failMName :: Name -monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey -thenMName = methName gHC_BASE (fsLit ">>") thenMClassOpKey -bindMName = methName gHC_BASE (fsLit ">>=") bindMClassOpKey -returnMName = methName gHC_BASE (fsLit "return") returnMClassOpKey -failMName = methName gHC_BASE (fsLit "fail") failMClassOpKey +monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey +thenMName = methName gHC_BASE (fsLit ">>") thenMClassOpKey +bindMName = methName gHC_BASE (fsLit ">>=") bindMClassOpKey +returnMName = methName gHC_BASE (fsLit "return") returnMClassOpKey +failMName = methName gHC_BASE (fsLit "fail") failMClassOpKey -- Classes (Applicative, Foldable, Traversable) applicativeClassName, foldableClassName, traversableClassName :: Name @@ -740,12 +745,12 @@ fromStringName, otherwiseIdName, foldrName, buildName, augmentName, dollarName, opaqueTyConName :: Name fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey -foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey -buildName = varQual gHC_BASE (fsLit "build") buildIdKey -augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey +foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey +buildName = varQual gHC_BASE (fsLit "build") buildIdKey +augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey mapName = varQual gHC_BASE (fsLit "map") mapIdKey -appendName = varQual gHC_BASE (fsLit "++") appendIdKey -dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey +appendName = varQual gHC_BASE (fsLit "++") appendIdKey +dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey assertName = varQual gHC_BASE (fsLit "assert") assertIdKey breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey @@ -773,21 +778,50 @@ breakpointAutoJumpName -- PrelTup fstName, sndName :: Name -fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey -sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey +fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey +sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey -- Module GHC.Num -numClassName, fromIntegerName, minusName, negateName, plusIntegerName, - timesIntegerName, - integerTyConName, smallIntegerName :: Name -numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey +numClassName, fromIntegerName, minusName, negateName :: Name +numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey fromIntegerName = methName gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey -minusName = methName gHC_NUM (fsLit "-") minusClassOpKey -negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey -plusIntegerName = varQual gHC_INTEGER (fsLit "plusInteger") plusIntegerIdKey -timesIntegerName = varQual gHC_INTEGER (fsLit "timesInteger") timesIntegerIdKey -integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey -smallIntegerName = varQual gHC_INTEGER (fsLit "smallInteger") smallIntegerIdKey +minusName = methName gHC_NUM (fsLit "-") minusClassOpKey +negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey + +integerTyConName, plusIntegerName, timesIntegerName, smallIntegerName, + integerToWordName, integerToIntName, minusIntegerName, + negateIntegerName, eqIntegerName, neqIntegerName, + absIntegerName, signumIntegerName, + leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, + compareIntegerName, + gcdIntegerName, lcmIntegerName, + andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, + shiftLIntegerName, shiftRIntegerName :: Name +integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey +plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey +timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey +smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey +integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey +integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey +minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey +negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey +eqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger") eqIntegerIdKey +neqIntegerName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger") neqIntegerIdKey +absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey +signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey +leIntegerName = varQual gHC_INTEGER_TYPE (fsLit "leInteger") leIntegerIdKey +gtIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger") gtIntegerIdKey +ltIntegerName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger") ltIntegerIdKey +geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geIntegerIdKey +compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey +gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey +lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey +andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey +orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey +xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey +complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey +shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey +shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey -- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, @@ -795,9 +829,9 @@ rationalTyConName, ratioTyConName, ratioDataConName, realClassName, fromRationalName, toIntegerName, toRationalName, fromIntegralName, realToFracName :: Name rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey +ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey -realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey +realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey @@ -830,9 +864,9 @@ typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6Clas typeable7ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable7") typeable7ClassKey typeableClassNames :: [Name] -typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName - , typeable3ClassName, typeable4ClassName, typeable5ClassName - , typeable6ClassName, typeable7ClassName ] +typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName + , typeable3ClassName, typeable4ClassName, typeable5ClassName + , typeable6ClassName, typeable7ClassName ] -- Class Data dataClassName :: Name @@ -840,31 +874,31 @@ dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey -- Error module assertErrorName :: Name -assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey +assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey -- Enum module (Enum, Bounded) enumClassName, enumFromName, enumFromToName, enumFromThenName, enumFromThenToName, boundedClassName :: Name -enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey -enumFromName = methName gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey -enumFromToName = methName gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey +enumFromName = methName gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = methName gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey enumFromThenName = methName gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey enumFromThenToName = methName gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey -- List functions concatName, filterName, zipName :: Name -concatName = varQual gHC_LIST (fsLit "concat") concatIdKey -filterName = varQual gHC_LIST (fsLit "filter") filterIdKey -zipName = varQual gHC_LIST (fsLit "zip") zipIdKey +concatName = varQual gHC_LIST (fsLit "concat") concatIdKey +filterName = varQual gHC_LIST (fsLit "filter") filterIdKey +zipName = varQual gHC_LIST (fsLit "zip") zipIdKey -- Class Show showClassName :: Name -showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey +showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey -- Class Read readClassName :: Name -readClassName = clsQual gHC_READ (fsLit "Read") readClassKey +readClassName = clsQual gHC_READ (fsLit "Read") readClassKey -- Classes Generic and Generic1, Datatype, Constructor and Selector genClassName, gen1ClassName, datatypeClassName, constructorClassName, @@ -899,16 +933,16 @@ appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPI -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name -ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey ioDataConName = conName gHC_TYPES (fsLit "IO") ioDataConKey -thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey -bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey -returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey -failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey +thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey -- IO things printName :: Name -printName = varQual sYSTEM_IO (fsLit "print") printIdKey +printName = varQual sYSTEM_IO (fsLit "print") printIdKey -- Int, Word, and Addr things int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name @@ -929,8 +963,8 @@ wordDataConName = conName gHC_WORD (fsLit "W#") wordDataConKey -- PrelPtr module ptrTyConName, funPtrTyConName :: Name -ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey -funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey +ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey -- Foreign objects and weak pointers stablePtrTyConName, newStablePtrName :: Name @@ -939,21 +973,21 @@ newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrI -- PrelST module runSTRepName :: Name -runSTRepName = varQual gHC_ST (fsLit "runSTRep") runSTRepIdKey +runSTRepName = varQual gHC_ST (fsLit "runSTRep") runSTRepIdKey -- Recursive-do notation monadFixClassName, mfixName :: Name monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey -mfixName = methName mONAD_FIX (fsLit "mfix") mfixIdKey +mfixName = methName mONAD_FIX (fsLit "mfix") mfixIdKey -- Arrow notation arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name -arrAName = varQual aRROW (fsLit "arr") arrAIdKey -composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey -firstAName = varQual aRROW (fsLit "first") firstAIdKey -appAName = varQual aRROW (fsLit "app") appAIdKey -choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey -loopAName = varQual aRROW (fsLit "loop") loopAIdKey +arrAName = varQual aRROW (fsLit "arr") arrAIdKey +composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey +firstAName = varQual aRROW (fsLit "first") firstAIdKey +appAName = varQual aRROW (fsLit "app") appAIdKey +choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey +loopAName = varQual aRROW (fsLit "loop") loopAIdKey -- Monad comprehensions guardMName, liftMName, groupMName, mzipName :: Name @@ -977,9 +1011,9 @@ isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- dotnet interop objectTyConName :: Name -objectTyConName = tcQual dOTNET (fsLit "Object") objectTyConKey - -- objectTyConName was "wTcQual", but that's gone now, and - -- I can't see why it was wired in anyway... +objectTyConName = tcQual dOTNET (fsLit "Object") objectTyConKey + -- objectTyConName was "wTcQual", but that's gone now, and + -- I can't see why it was wired in anyway... unmarshalObjectName, marshalObjectName, marshalStringName, unmarshalStringName, checkDotnetResName :: Name unmarshalObjectName = varQual dOTNET (fsLit "unmarshalObject") unmarshalObjectIdKey @@ -996,9 +1030,9 @@ pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey \end{code} %************************************************************************ -%* * +%* * \subsection{Local helpers} -%* * +%* * %************************************************************************ All these are original names; hence mkOrig @@ -1010,7 +1044,7 @@ tcQual = mk_known_key_name tcName clsQual = mk_known_key_name clsName mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name -mk_known_key_name space modu str unique +mk_known_key_name space modu str unique = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan conName :: Module -> FastString -> Unique -> Name @@ -1023,9 +1057,9 @@ methName modu occ unique \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} -%* * +%* * %************************************************************************ --MetaHaskell extension hand allocate keys here @@ -1034,51 +1068,51 @@ boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique -boundedClassKey = mkPreludeClassUnique 1 -enumClassKey = mkPreludeClassUnique 2 -eqClassKey = mkPreludeClassUnique 3 -floatingClassKey = mkPreludeClassUnique 5 -fractionalClassKey = mkPreludeClassUnique 6 -integralClassKey = mkPreludeClassUnique 7 -monadClassKey = mkPreludeClassUnique 8 -dataClassKey = mkPreludeClassUnique 9 -functorClassKey = mkPreludeClassUnique 10 -numClassKey = mkPreludeClassUnique 11 -ordClassKey = mkPreludeClassUnique 12 -readClassKey = mkPreludeClassUnique 13 -realClassKey = mkPreludeClassUnique 14 -realFloatClassKey = mkPreludeClassUnique 15 -realFracClassKey = mkPreludeClassUnique 16 -showClassKey = mkPreludeClassUnique 17 -ixClassKey = mkPreludeClassUnique 18 +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey :: Unique -typeableClassKey = mkPreludeClassUnique 20 -typeable1ClassKey = mkPreludeClassUnique 21 -typeable2ClassKey = mkPreludeClassUnique 22 -typeable3ClassKey = mkPreludeClassUnique 23 -typeable4ClassKey = mkPreludeClassUnique 24 -typeable5ClassKey = mkPreludeClassUnique 25 -typeable6ClassKey = mkPreludeClassUnique 26 -typeable7ClassKey = mkPreludeClassUnique 27 +typeableClassKey = mkPreludeClassUnique 20 +typeable1ClassKey = mkPreludeClassUnique 21 +typeable2ClassKey = mkPreludeClassUnique 22 +typeable3ClassKey = mkPreludeClassUnique 23 +typeable4ClassKey = mkPreludeClassUnique 24 +typeable5ClassKey = mkPreludeClassUnique 25 +typeable6ClassKey = mkPreludeClassUnique 26 +typeable7ClassKey = mkPreludeClassUnique 27 monadFixClassKey :: Unique -monadFixClassKey = mkPreludeClassUnique 28 +monadFixClassKey = mkPreludeClassUnique 28 monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique -monadPlusClassKey = mkPreludeClassUnique 30 -randomClassKey = mkPreludeClassUnique 31 -randomGenClassKey = mkPreludeClassUnique 32 +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 isStringClassKey :: Unique -isStringClassKey = mkPreludeClassUnique 33 +isStringClassKey = mkPreludeClassUnique 33 applicativeClassKey, foldableClassKey, traversableClassKey :: Unique -applicativeClassKey = mkPreludeClassUnique 34 -foldableClassKey = mkPreludeClassUnique 35 -traversableClassKey = mkPreludeClassUnique 36 +applicativeClassKey = mkPreludeClassUnique 34 +foldableClassKey = mkPreludeClassUnique 35 +traversableClassKey = mkPreludeClassUnique 36 genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, selectorClassKey :: Unique @@ -1091,9 +1125,9 @@ selectorClassKey = mkPreludeClassUnique 41 \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} -%* * +%* * %************************************************************************ \begin{code} @@ -1107,39 +1141,39 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, anyTyConKey :: Unique -addrPrimTyConKey = mkPreludeTyConUnique 1 -arrayPrimTyConKey = mkPreludeTyConUnique 3 -boolTyConKey = mkPreludeTyConUnique 4 -byteArrayPrimTyConKey = mkPreludeTyConUnique 5 -charPrimTyConKey = mkPreludeTyConUnique 7 -charTyConKey = mkPreludeTyConUnique 8 -doublePrimTyConKey = mkPreludeTyConUnique 9 -doubleTyConKey = mkPreludeTyConUnique 10 -floatPrimTyConKey = mkPreludeTyConUnique 11 -floatTyConKey = mkPreludeTyConUnique 12 -funTyConKey = mkPreludeTyConUnique 13 -intPrimTyConKey = mkPreludeTyConUnique 14 -intTyConKey = mkPreludeTyConUnique 15 -int8TyConKey = mkPreludeTyConUnique 16 -int16TyConKey = mkPreludeTyConUnique 17 -int32PrimTyConKey = mkPreludeTyConUnique 18 -int32TyConKey = mkPreludeTyConUnique 19 -int64PrimTyConKey = mkPreludeTyConUnique 20 -int64TyConKey = mkPreludeTyConUnique 21 -integerTyConKey = mkPreludeTyConUnique 22 -listTyConKey = mkPreludeTyConUnique 23 -foreignObjPrimTyConKey = mkPreludeTyConUnique 24 -weakPrimTyConKey = mkPreludeTyConUnique 27 -mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 -mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 -orderingTyConKey = mkPreludeTyConUnique 30 -mVarPrimTyConKey = mkPreludeTyConUnique 31 -ratioTyConKey = mkPreludeTyConUnique 32 -rationalTyConKey = mkPreludeTyConUnique 33 -realWorldTyConKey = mkPreludeTyConUnique 34 -stablePtrPrimTyConKey = mkPreludeTyConUnique 35 -stablePtrTyConKey = mkPreludeTyConUnique 36 -anyTyConKey = mkPreludeTyConUnique 37 +addrPrimTyConKey = mkPreludeTyConUnique 1 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +funTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8TyConKey = mkPreludeTyConUnique 16 +int16TyConKey = mkPreludeTyConUnique 17 +int32PrimTyConKey = mkPreludeTyConUnique 18 +int32TyConKey = mkPreludeTyConUnique 19 +int64PrimTyConKey = mkPreludeTyConUnique 20 +int64TyConKey = mkPreludeTyConUnique 21 +integerTyConKey = mkPreludeTyConUnique 22 +listTyConKey = mkPreludeTyConUnique 23 +foreignObjPrimTyConKey = mkPreludeTyConUnique 24 +weakPrimTyConKey = mkPreludeTyConUnique 27 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 28 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 29 +orderingTyConKey = mkPreludeTyConUnique 30 +mVarPrimTyConKey = mkPreludeTyConUnique 31 +ratioTyConKey = mkPreludeTyConUnique 32 +rationalTyConKey = mkPreludeTyConUnique 33 +realWorldTyConKey = mkPreludeTyConUnique 34 +stablePtrPrimTyConKey = mkPreludeTyConUnique 35 +stablePtrTyConKey = mkPreludeTyConUnique 36 +anyTyConKey = mkPreludeTyConUnique 37 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, @@ -1148,42 +1182,42 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique -statePrimTyConKey = mkPreludeTyConUnique 50 -stableNamePrimTyConKey = mkPreludeTyConUnique 51 +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 eqPredPrimTyConKey = mkPreludeTyConUnique 53 mutVarPrimTyConKey = mkPreludeTyConUnique 55 -ioTyConKey = mkPreludeTyConUnique 56 -wordPrimTyConKey = mkPreludeTyConUnique 58 -wordTyConKey = mkPreludeTyConUnique 59 -word8TyConKey = mkPreludeTyConUnique 60 -word16TyConKey = mkPreludeTyConUnique 61 -word32PrimTyConKey = mkPreludeTyConUnique 62 -word32TyConKey = mkPreludeTyConUnique 63 -word64PrimTyConKey = mkPreludeTyConUnique 64 -word64TyConKey = mkPreludeTyConUnique 65 -liftedConKey = mkPreludeTyConUnique 66 -unliftedConKey = mkPreludeTyConUnique 67 -anyBoxConKey = mkPreludeTyConUnique 68 -kindConKey = mkPreludeTyConUnique 69 -boxityConKey = mkPreludeTyConUnique 70 -typeConKey = mkPreludeTyConUnique 71 -threadIdPrimTyConKey = mkPreludeTyConUnique 72 -bcoPrimTyConKey = mkPreludeTyConUnique 73 -ptrTyConKey = mkPreludeTyConUnique 74 -funPtrTyConKey = mkPreludeTyConUnique 75 -tVarPrimTyConKey = mkPreludeTyConUnique 76 +ioTyConKey = mkPreludeTyConUnique 56 +wordPrimTyConKey = mkPreludeTyConUnique 58 +wordTyConKey = mkPreludeTyConUnique 59 +word8TyConKey = mkPreludeTyConUnique 60 +word16TyConKey = mkPreludeTyConUnique 61 +word32PrimTyConKey = mkPreludeTyConUnique 62 +word32TyConKey = mkPreludeTyConUnique 63 +word64PrimTyConKey = mkPreludeTyConUnique 64 +word64TyConKey = mkPreludeTyConUnique 65 +liftedConKey = mkPreludeTyConUnique 66 +unliftedConKey = mkPreludeTyConUnique 67 +anyBoxConKey = mkPreludeTyConUnique 68 +kindConKey = mkPreludeTyConUnique 69 +boxityConKey = mkPreludeTyConUnique 70 +typeConKey = mkPreludeTyConUnique 71 +threadIdPrimTyConKey = mkPreludeTyConUnique 72 +bcoPrimTyConKey = mkPreludeTyConUnique 73 +ptrTyConKey = mkPreludeTyConUnique 74 +funPtrTyConKey = mkPreludeTyConUnique 75 +tVarPrimTyConKey = mkPreludeTyConUnique 76 -- Parallel array type constructor parrTyConKey :: Unique -parrTyConKey = mkPreludeTyConUnique 82 +parrTyConKey = mkPreludeTyConUnique 82 -- dotnet interop objectTyConKey :: Unique -objectTyConKey = mkPreludeTyConUnique 83 +objectTyConKey = mkPreludeTyConUnique 83 eitherTyConKey :: Unique -eitherTyConKey = mkPreludeTyConUnique 84 +eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors tySuperKindTyConKey :: Unique @@ -1218,14 +1252,14 @@ pluginTyConKey = mkPreludeTyConUnique 102 unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, opaqueTyConKey :: Unique -unknownTyConKey = mkPreludeTyConUnique 129 -unknown1TyConKey = mkPreludeTyConUnique 130 -unknown2TyConKey = mkPreludeTyConUnique 131 -unknown3TyConKey = mkPreludeTyConUnique 132 +unknownTyConKey = mkPreludeTyConUnique 129 +unknown1TyConKey = mkPreludeTyConUnique 130 +unknown2TyConKey = mkPreludeTyConUnique 131 +unknown3TyConKey = mkPreludeTyConUnique 132 opaqueTyConKey = mkPreludeTyConUnique 133 stringTyConKey :: Unique -stringTyConKey = mkPreludeTyConUnique 134 +stringTyConKey = mkPreludeTyConUnique 134 -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, @@ -1263,7 +1297,7 @@ repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 ---------------- Template Haskell ------------------- --- USES TyConUniques 200-299 +-- USES TyConUniques 200-299 ----------------------------------------------------- unitTyConKey :: Unique @@ -1271,9 +1305,9 @@ unitTyConKey = mkTupleTyConUnique Boxed 0 \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} -%* * +%* * %************************************************************************ \begin{code} @@ -1281,172 +1315,193 @@ charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, ioDataConKey, integerDataConKey :: Unique -charDataConKey = mkPreludeDataConUnique 1 -consDataConKey = mkPreludeDataConUnique 2 -doubleDataConKey = mkPreludeDataConUnique 3 -falseDataConKey = mkPreludeDataConUnique 4 -floatDataConKey = mkPreludeDataConUnique 5 -intDataConKey = mkPreludeDataConUnique 6 -nilDataConKey = mkPreludeDataConUnique 11 -ratioDataConKey = mkPreludeDataConUnique 12 -stableNameDataConKey = mkPreludeDataConUnique 14 -trueDataConKey = mkPreludeDataConUnique 15 -wordDataConKey = mkPreludeDataConUnique 16 -ioDataConKey = mkPreludeDataConUnique 17 -integerDataConKey = mkPreludeDataConUnique 18 +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +nilDataConKey = mkPreludeDataConUnique 11 +ratioDataConKey = mkPreludeDataConUnique 12 +stableNameDataConKey = mkPreludeDataConUnique 14 +trueDataConKey = mkPreludeDataConUnique 15 +wordDataConKey = mkPreludeDataConUnique 16 +ioDataConKey = mkPreludeDataConUnique 17 +integerDataConKey = mkPreludeDataConUnique 18 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique -crossDataConKey = mkPreludeDataConUnique 20 -inlDataConKey = mkPreludeDataConUnique 21 -inrDataConKey = mkPreludeDataConUnique 22 -genUnitDataConKey = mkPreludeDataConUnique 23 +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 -- Data constructor for parallel arrays parrDataConKey :: Unique -parrDataConKey = mkPreludeDataConUnique 24 +parrDataConKey = mkPreludeDataConUnique 24 leftDataConKey, rightDataConKey :: Unique -leftDataConKey = mkPreludeDataConUnique 25 -rightDataConKey = mkPreludeDataConUnique 26 +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 + +ltDataConKey, eqDataConKey, gtDataConKey :: Unique +ltDataConKey = mkPreludeDataConUnique 27 +eqDataConKey = mkPreludeDataConUnique 28 +gtDataConKey = mkPreludeDataConUnique 29 \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} -%* * +%* * %************************************************************************ \begin{code} -absentErrorIdKey, augmentIdKey, appendIdKey, buildIdKey, errorIdKey, - foldlIdKey, foldrIdKey, recSelErrorIdKey, - integerMinusOneIdKey, integerPlusOneIdKey, - integerPlusTwoIdKey, integerZeroIdKey, - int2IntegerIdKey, seqIdKey, irrefutPatErrorIdKey, eqStringIdKey, +wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, + buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, + seqIdKey, irrefutPatErrorIdKey, eqStringIdKey, noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - runtimeErrorIdKey, parErrorIdKey, parIdKey, patErrorIdKey, - realWorldPrimIdKey, recConErrorIdKey, recUpdErrorIdKey, - traceIdKey, wildCardKey, + runtimeErrorIdKey, patErrorIdKey, + realWorldPrimIdKey, recConErrorIdKey, unpackCStringUtf8IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey :: Unique wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard] absentErrorIdKey = mkPreludeMiscIdUnique 1 -augmentIdKey = mkPreludeMiscIdUnique 3 -appendIdKey = mkPreludeMiscIdUnique 4 -buildIdKey = mkPreludeMiscIdUnique 5 -errorIdKey = mkPreludeMiscIdUnique 6 -foldlIdKey = mkPreludeMiscIdUnique 7 -foldrIdKey = mkPreludeMiscIdUnique 8 -recSelErrorIdKey = mkPreludeMiscIdUnique 9 -integerMinusOneIdKey = mkPreludeMiscIdUnique 10 -integerPlusOneIdKey = mkPreludeMiscIdUnique 11 -integerPlusTwoIdKey = mkPreludeMiscIdUnique 12 -integerZeroIdKey = mkPreludeMiscIdUnique 13 -int2IntegerIdKey = mkPreludeMiscIdUnique 14 -seqIdKey = mkPreludeMiscIdUnique 15 -irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16 -eqStringIdKey = mkPreludeMiscIdUnique 17 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 18 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 19 -runtimeErrorIdKey = mkPreludeMiscIdUnique 20 -parErrorIdKey = mkPreludeMiscIdUnique 21 -parIdKey = mkPreludeMiscIdUnique 22 -patErrorIdKey = mkPreludeMiscIdUnique 23 -realWorldPrimIdKey = mkPreludeMiscIdUnique 24 -recConErrorIdKey = mkPreludeMiscIdUnique 25 -recUpdErrorIdKey = mkPreludeMiscIdUnique 26 -traceIdKey = mkPreludeMiscIdUnique 27 -unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 28 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 29 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 30 -unpackCStringIdKey = mkPreludeMiscIdUnique 31 +augmentIdKey = mkPreludeMiscIdUnique 2 +appendIdKey = mkPreludeMiscIdUnique 3 +buildIdKey = mkPreludeMiscIdUnique 4 +errorIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +irrefutPatErrorIdKey = mkPreludeMiscIdUnique 9 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +runtimeErrorIdKey = mkPreludeMiscIdUnique 13 +patErrorIdKey = mkPreludeMiscIdUnique 14 +realWorldPrimIdKey = mkPreludeMiscIdUnique 15 +recConErrorIdKey = mkPreludeMiscIdUnique 16 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 +unpackCStringIdKey = mkPreludeMiscIdUnique 20 unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, - returnIOIdKey, deRefStablePtrIdKey, newStablePtrIdKey, - smallIntegerIdKey, plusIntegerIdKey, timesIntegerIdKey, + returnIOIdKey, newStablePtrIdKey, printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey, runSTRepIdKey :: Unique -unsafeCoerceIdKey = mkPreludeMiscIdUnique 32 -concatIdKey = mkPreludeMiscIdUnique 33 -filterIdKey = mkPreludeMiscIdUnique 34 -zipIdKey = mkPreludeMiscIdUnique 35 -bindIOIdKey = mkPreludeMiscIdUnique 36 -returnIOIdKey = mkPreludeMiscIdUnique 37 -deRefStablePtrIdKey = mkPreludeMiscIdUnique 38 -newStablePtrIdKey = mkPreludeMiscIdUnique 39 -smallIntegerIdKey = mkPreludeMiscIdUnique 40 -plusIntegerIdKey = mkPreludeMiscIdUnique 41 -timesIntegerIdKey = mkPreludeMiscIdUnique 42 -printIdKey = mkPreludeMiscIdUnique 43 -failIOIdKey = mkPreludeMiscIdUnique 44 -nullAddrIdKey = mkPreludeMiscIdUnique 46 -voidArgIdKey = mkPreludeMiscIdUnique 47 -fstIdKey = mkPreludeMiscIdUnique 49 -sndIdKey = mkPreludeMiscIdUnique 50 -otherwiseIdKey = mkPreludeMiscIdUnique 51 -assertIdKey = mkPreludeMiscIdUnique 53 -runSTRepIdKey = mkPreludeMiscIdUnique 54 +unsafeCoerceIdKey = mkPreludeMiscIdUnique 30 +concatIdKey = mkPreludeMiscIdUnique 31 +filterIdKey = mkPreludeMiscIdUnique 32 +zipIdKey = mkPreludeMiscIdUnique 33 +bindIOIdKey = mkPreludeMiscIdUnique 34 +returnIOIdKey = mkPreludeMiscIdUnique 35 +newStablePtrIdKey = mkPreludeMiscIdUnique 36 +printIdKey = mkPreludeMiscIdUnique 37 +failIOIdKey = mkPreludeMiscIdUnique 38 +nullAddrIdKey = mkPreludeMiscIdUnique 39 +voidArgIdKey = mkPreludeMiscIdUnique 40 +fstIdKey = mkPreludeMiscIdUnique 41 +sndIdKey = mkPreludeMiscIdUnique 42 +otherwiseIdKey = mkPreludeMiscIdUnique 43 +assertIdKey = mkPreludeMiscIdUnique 44 +runSTRepIdKey = mkPreludeMiscIdUnique 45 + +smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey, + plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, + negateIntegerIdKey, + eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey, + leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey, + compareIntegerIdKey, + gcdIntegerIdKey, lcmIntegerIdKey, + andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, + shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique +smallIntegerIdKey = mkPreludeMiscIdUnique 60 +integerToWordIdKey = mkPreludeMiscIdUnique 61 +integerToIntIdKey = mkPreludeMiscIdUnique 62 +plusIntegerIdKey = mkPreludeMiscIdUnique 63 +timesIntegerIdKey = mkPreludeMiscIdUnique 64 +minusIntegerIdKey = mkPreludeMiscIdUnique 65 +negateIntegerIdKey = mkPreludeMiscIdUnique 66 +eqIntegerIdKey = mkPreludeMiscIdUnique 67 +neqIntegerIdKey = mkPreludeMiscIdUnique 68 +absIntegerIdKey = mkPreludeMiscIdUnique 69 +signumIntegerIdKey = mkPreludeMiscIdUnique 70 +leIntegerIdKey = mkPreludeMiscIdUnique 71 +gtIntegerIdKey = mkPreludeMiscIdUnique 72 +ltIntegerIdKey = mkPreludeMiscIdUnique 73 +geIntegerIdKey = mkPreludeMiscIdUnique 74 +compareIntegerIdKey = mkPreludeMiscIdUnique 75 +gcdIntegerIdKey = mkPreludeMiscIdUnique 85 +lcmIntegerIdKey = mkPreludeMiscIdUnique 86 +andIntegerIdKey = mkPreludeMiscIdUnique 87 +orIntegerIdKey = mkPreludeMiscIdUnique 88 +xorIntegerIdKey = mkPreludeMiscIdUnique 89 +complementIntegerIdKey = mkPreludeMiscIdUnique 90 +shiftLIntegerIdKey = mkPreludeMiscIdUnique 91 +shiftRIntegerIdKey = mkPreludeMiscIdUnique 92 rootMainKey, runMainKey :: Unique -rootMainKey = mkPreludeMiscIdUnique 55 -runMainKey = mkPreludeMiscIdUnique 56 +rootMainKey = mkPreludeMiscIdUnique 100 +runMainKey = mkPreludeMiscIdUnique 101 thenIOIdKey, lazyIdKey, assertErrorIdKey :: Unique -thenIOIdKey = mkPreludeMiscIdUnique 59 -lazyIdKey = mkPreludeMiscIdUnique 60 -assertErrorIdKey = mkPreludeMiscIdUnique 61 +thenIOIdKey = mkPreludeMiscIdUnique 102 +lazyIdKey = mkPreludeMiscIdUnique 103 +assertErrorIdKey = mkPreludeMiscIdUnique 104 breakpointIdKey, breakpointCondIdKey, breakpointAutoIdKey, breakpointJumpIdKey, breakpointCondJumpIdKey, breakpointAutoJumpIdKey :: Unique -breakpointIdKey = mkPreludeMiscIdUnique 62 -breakpointCondIdKey = mkPreludeMiscIdUnique 63 -breakpointAutoIdKey = mkPreludeMiscIdUnique 64 -breakpointJumpIdKey = mkPreludeMiscIdUnique 65 -breakpointCondJumpIdKey = mkPreludeMiscIdUnique 66 -breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 67 +breakpointIdKey = mkPreludeMiscIdUnique 110 +breakpointCondIdKey = mkPreludeMiscIdUnique 111 +breakpointAutoIdKey = mkPreludeMiscIdUnique 112 +breakpointJumpIdKey = mkPreludeMiscIdUnique 113 +breakpointCondJumpIdKey = mkPreludeMiscIdUnique 114 +breakpointAutoJumpIdKey = mkPreludeMiscIdUnique 115 inlineIdKey :: Unique -inlineIdKey = mkPreludeMiscIdUnique 68 +inlineIdKey = mkPreludeMiscIdUnique 120 mapIdKey, groupWithIdKey, dollarIdKey :: Unique -mapIdKey = mkPreludeMiscIdUnique 69 -groupWithIdKey = mkPreludeMiscIdUnique 70 -dollarIdKey = mkPreludeMiscIdUnique 71 +mapIdKey = mkPreludeMiscIdUnique 121 +groupWithIdKey = mkPreludeMiscIdUnique 122 +dollarIdKey = mkPreludeMiscIdUnique 123 coercionTokenIdKey :: Unique -coercionTokenIdKey = mkPreludeMiscIdUnique 72 +coercionTokenIdKey = mkPreludeMiscIdUnique 124 -- Parallel array functions singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey, filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey, enumFromToPIdKey, enumFromThenToPIdKey, emptyPIdKey, appPIdKey :: Unique -singletonPIdKey = mkPreludeMiscIdUnique 79 -nullPIdKey = mkPreludeMiscIdUnique 80 -lengthPIdKey = mkPreludeMiscIdUnique 81 -replicatePIdKey = mkPreludeMiscIdUnique 82 -mapPIdKey = mkPreludeMiscIdUnique 83 -filterPIdKey = mkPreludeMiscIdUnique 84 -zipPIdKey = mkPreludeMiscIdUnique 85 -crossMapPIdKey = mkPreludeMiscIdUnique 86 -indexPIdKey = mkPreludeMiscIdUnique 87 -toPIdKey = mkPreludeMiscIdUnique 88 -enumFromToPIdKey = mkPreludeMiscIdUnique 89 -enumFromThenToPIdKey = mkPreludeMiscIdUnique 90 -emptyPIdKey = mkPreludeMiscIdUnique 91 -appPIdKey = mkPreludeMiscIdUnique 92 +singletonPIdKey = mkPreludeMiscIdUnique 130 +nullPIdKey = mkPreludeMiscIdUnique 131 +lengthPIdKey = mkPreludeMiscIdUnique 132 +replicatePIdKey = mkPreludeMiscIdUnique 133 +mapPIdKey = mkPreludeMiscIdUnique 134 +filterPIdKey = mkPreludeMiscIdUnique 135 +zipPIdKey = mkPreludeMiscIdUnique 136 +crossMapPIdKey = mkPreludeMiscIdUnique 137 +indexPIdKey = mkPreludeMiscIdUnique 138 +toPIdKey = mkPreludeMiscIdUnique 139 +enumFromToPIdKey = mkPreludeMiscIdUnique 140 +enumFromThenToPIdKey = mkPreludeMiscIdUnique 141 +emptyPIdKey = mkPreludeMiscIdUnique 142 +appPIdKey = mkPreludeMiscIdUnique 143 -- dotnet interop unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique -unmarshalObjectIdKey = mkPreludeMiscIdUnique 94 -marshalObjectIdKey = mkPreludeMiscIdUnique 95 -marshalStringIdKey = mkPreludeMiscIdUnique 96 -unmarshalStringIdKey = mkPreludeMiscIdUnique 97 -checkDotnetResNameIdKey = mkPreludeMiscIdUnique 98 +unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 +marshalObjectIdKey = mkPreludeMiscIdUnique 151 +marshalStringIdKey = mkPreludeMiscIdUnique 152 +unmarshalStringIdKey = mkPreludeMiscIdUnique 153 +checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 undefinedKey :: Unique -undefinedKey = mkPreludeMiscIdUnique 99 +undefinedKey = mkPreludeMiscIdUnique 155 \end{code} @@ -1455,9 +1510,9 @@ uniques so we can look them up easily when we want to conjure them up during type checking. \begin{code} - -- Just a place holder for unbound variables produced by the renamer: + -- Just a place holder for unbound variables produced by the renamer: unboundKey :: Unique -unboundKey = mkPreludeMiscIdUnique 101 +unboundKey = mkPreludeMiscIdUnique 160 fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, @@ -1465,93 +1520,84 @@ fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey :: Unique -fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 -minusClassOpKey = mkPreludeMiscIdUnique 103 -fromRationalClassOpKey = mkPreludeMiscIdUnique 104 -enumFromClassOpKey = mkPreludeMiscIdUnique 105 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 106 -enumFromToClassOpKey = mkPreludeMiscIdUnique 107 -enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108 -eqClassOpKey = mkPreludeMiscIdUnique 109 -geClassOpKey = mkPreludeMiscIdUnique 110 -negateClassOpKey = mkPreludeMiscIdUnique 111 -failMClassOpKey = mkPreludeMiscIdUnique 112 -bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) -thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) -fmapClassOpKey = mkPreludeMiscIdUnique 115 -returnMClassOpKey = mkPreludeMiscIdUnique 117 +fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 +minusClassOpKey = mkPreludeMiscIdUnique 161 +fromRationalClassOpKey = mkPreludeMiscIdUnique 162 +enumFromClassOpKey = mkPreludeMiscIdUnique 163 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 +enumFromToClassOpKey = mkPreludeMiscIdUnique 165 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 +eqClassOpKey = mkPreludeMiscIdUnique 167 +geClassOpKey = mkPreludeMiscIdUnique 168 +negateClassOpKey = mkPreludeMiscIdUnique 169 +failMClassOpKey = mkPreludeMiscIdUnique 170 +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 173 +returnMClassOpKey = mkPreludeMiscIdUnique 174 -- Recursive do notation mfixIdKey :: Unique -mfixIdKey = mkPreludeMiscIdUnique 118 +mfixIdKey = mkPreludeMiscIdUnique 175 -- Arrow notation arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, loopAIdKey :: Unique -arrAIdKey = mkPreludeMiscIdUnique 119 -composeAIdKey = mkPreludeMiscIdUnique 120 -- >>> -firstAIdKey = mkPreludeMiscIdUnique 121 -appAIdKey = mkPreludeMiscIdUnique 122 -choiceAIdKey = mkPreludeMiscIdUnique 123 -- ||| -loopAIdKey = mkPreludeMiscIdUnique 124 +arrAIdKey = mkPreludeMiscIdUnique 180 +composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 182 +appAIdKey = mkPreludeMiscIdUnique 183 +choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 185 fromStringClassOpKey :: Unique -fromStringClassOpKey = mkPreludeMiscIdUnique 125 +fromStringClassOpKey = mkPreludeMiscIdUnique 186 -- Annotation type checking toAnnotationWrapperIdKey :: Unique -toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 126 +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 -- Conversion functions fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique -fromIntegralIdKey = mkPreludeMiscIdUnique 127 -realToFracIdKey = mkPreludeMiscIdUnique 128 -toIntegerClassOpKey = mkPreludeMiscIdUnique 129 -toRationalClassOpKey = mkPreludeMiscIdUnique 130 +fromIntegralIdKey = mkPreludeMiscIdUnique 190 +realToFracIdKey = mkPreludeMiscIdUnique 191 +toIntegerClassOpKey = mkPreludeMiscIdUnique 192 +toRationalClassOpKey = mkPreludeMiscIdUnique 193 -- Monad comprehensions guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique -guardMIdKey = mkPreludeMiscIdUnique 131 -liftMIdKey = mkPreludeMiscIdUnique 132 -groupMIdKey = mkPreludeMiscIdUnique 133 -mzipIdKey = mkPreludeMiscIdUnique 134 +guardMIdKey = mkPreludeMiscIdUnique 194 +liftMIdKey = mkPreludeMiscIdUnique 195 +groupMIdKey = mkPreludeMiscIdUnique 196 +mzipIdKey = mkPreludeMiscIdUnique 197 ---------------- Template Haskell ------------------- --- USES IdUniques 200-499 +-- USES IdUniques 200-499 ----------------------------------------------------- \end{code} %************************************************************************ -%* * +%* * \subsection{Standard groups of types} -%* * +%* * %************************************************************************ \begin{code} -numericTyKeys :: [Unique] -numericTyKeys = - [ wordTyConKey - , intTyConKey - , integerTyConKey - , doubleTyConKey - , floatTyConKey - ] - -kindKeys :: [Unique] +kindKeys :: [Unique] kindKeys = [ liftedTypeKindTyConKey - , openTypeKindTyConKey - , unliftedTypeKindTyConKey - , ubxTupleKindTyConKey - , argTypeKindTyConKey ] + , openTypeKindTyConKey + , unliftedTypeKindTyConKey + , ubxTupleKindTyConKey + , argTypeKindTyConKey ] \end{code} %************************************************************************ -%* * +%* * \subsection[Class-std-groups]{Standard groups of Prelude classes} -%* * +%* * %************************************************************************ NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ @@ -1561,37 +1607,30 @@ because the list of ambiguous dictionaries hasn't been simplified. \begin{code} numericClassKeys :: [Unique] numericClassKeys = - [ numClassKey - , realClassKey - , integralClassKey - ] - ++ fractionalClassKeys + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys fractionalClassKeys :: [Unique] -fractionalClassKeys = - [ fractionalClassKey - , floatingClassKey - , realFracClassKey - , realFloatClassKey - ] - - -- the strictness analyser needs to know about numeric types - -- (see SaAbsInt.lhs) -needsDataDeclCtxtClassKeys :: [Unique] -needsDataDeclCtxtClassKeys = -- see comments in TcDeriv - [ readClassKey - ] +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] -- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), -- and are: "classes defined in the Prelude or a standard library" standardClassKeys :: [Unique] standardClassKeys = derivableClassKeys ++ numericClassKeys - ++ [randomClassKey, randomGenClassKey, - functorClassKey, - monadClassKey, monadPlusClassKey, - isStringClassKey, - applicativeClassKey, foldableClassKey, traversableClassKey - ] + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey, + isStringClassKey, + applicativeClassKey, foldableClassKey, traversableClassKey + ] \end{code} @derivableClassKeys@ is also used in checking \tr{deriving} constructs diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index e9401d4c9e..f86e6a4a29 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -461,6 +461,12 @@ convFloating l = l trueVal, falseVal :: Expr CoreBndr trueVal = Var trueDataConId falseVal = Var falseDataConId + +ltVal, eqVal, gtVal :: Expr CoreBndr +ltVal = Var ltDataConId +eqVal = Var eqDataConId +gtVal = Var gtDataConId + mkIntVal :: Integer -> Expr CoreBndr mkIntVal i = Lit (mkMachInt i) mkWordVal :: Integer -> Expr CoreBndr @@ -604,8 +610,56 @@ builtinRules BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = match_inline } + ru_nargs = 2, ru_try = match_inline }, + -- TODO: All the below rules need to handle target platform + -- having a different wordsize than the host platform + rule_Integer_convert "integerToWord" integerToWordName mkWordLitWord, + rule_Integer_convert "integerToInt" integerToIntName mkIntLitInt, + rule_Integer_binop "plusInteger" plusIntegerName (+), + rule_Integer_binop "timesInteger" timesIntegerName (*), + rule_Integer_binop "minusInteger" minusIntegerName (-), + rule_Integer_unop "negateInteger" negateIntegerName negate, + rule_Integer_binop_Bool "eqInteger" eqIntegerName (==), + rule_Integer_binop_Bool "neqInteger" neqIntegerName (/=), + rule_Integer_unop "absInteger" absIntegerName abs, + rule_Integer_unop "signumInteger" signumIntegerName signum, + rule_Integer_binop_Bool "leInteger" leIntegerName (<=), + rule_Integer_binop_Bool "gtInteger" gtIntegerName (>), + rule_Integer_binop_Bool "ltInteger" ltIntegerName (<), + rule_Integer_binop_Bool "geInteger" geIntegerName (>=), + rule_Integer_binop_Ordering "compareInteger" compareIntegerName compare, + -- TODO: divMod/quoteRem/quot/rem rules. Due to the 0 check we + -- need rules for the generic functions, rather than the + -- Integer-specific functions + rule_Integer_binop "gcdInteger" gcdIntegerName gcd, + rule_Integer_binop "lcmInteger" lcmIntegerName lcm, + rule_Integer_binop "andInteger" andIntegerName (.&.), + rule_Integer_binop "orInteger" orIntegerName (.|.), + rule_Integer_binop "xorInteger" xorIntegerName xor, + rule_Integer_unop "complementInteger" complementIntegerName complement, + -- TODO: Likewise, these rules currently don't do anything, due to + -- the sign test in shift's definition + rule_Integer_Int_binop "shiftLInteger" shiftLIntegerName shiftL, + rule_Integer_Int_binop "shiftRInteger" shiftRIntegerName shiftR ] + where rule_Integer_convert str name convert + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_convert convert } + rule_Integer_unop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_unop op } + rule_Integer_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop op } + rule_Integer_Int_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_binop op } + rule_Integer_binop_Bool str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Bool op } + rule_Integer_binop_Ordering str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Ordering op } --------------------------------------------------- @@ -667,4 +721,85 @@ match_inline _ (Type _ : e : _) = Just (mkApps unf args1) match_inline _ _ = Nothing + +-- Integer rules + +match_Integer_convert :: Num a + => (a -> Expr CoreBndr) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_convert convert _ [x] + | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, + idName fx == smallIntegerName + = Just (convert (fromIntegral ix)) +match_Integer_convert _ _ _ = Nothing + +match_Integer_unop :: (Integer -> Integer) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_unop unop _ [x] + | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, + idName fx == smallIntegerName, + let iz = unop ix, + iz >= fromIntegral (minBound :: Int), + iz <= fromIntegral (maxBound :: Int) + = Just (Var fx `App` Lit (MachInt iz)) +match_Integer_unop _ _ _ = Nothing + +match_Integer_binop :: (Integer -> Integer -> Integer) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_binop binop _ [x, y] + | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, + (Var fy, [Lit (MachInt iy)]) <- collectArgs y, + idName fx == smallIntegerName, + idName fy == smallIntegerName, + let iz = ix `binop` iy, + iz >= fromIntegral (minBound :: Int), + iz <= fromIntegral (maxBound :: Int) + = Just (Var fx `App` Lit (MachInt iz)) +match_Integer_binop _ _ _ = Nothing + +match_Integer_Int_binop :: (Integer -> Int -> Integer) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_Int_binop binop _ [x, Lit (MachInt iy)] + | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, + idName fx == smallIntegerName, + let iz = ix `binop` fromIntegral iy, + iz >= fromIntegral (minBound :: Int), + iz <= fromIntegral (maxBound :: Int) + = Just (Var fx `App` Lit (MachInt iz)) +match_Integer_Int_binop _ _ _ = Nothing + +match_Integer_binop_Bool :: (Integer -> Integer -> Bool) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_binop_Bool binop _ [x, y] + | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, + (Var fy, [Lit (MachInt iy)]) <- collectArgs y, + idName fx == smallIntegerName, + idName fy == smallIntegerName + = Just (if ix `binop` iy then trueVal else falseVal) +match_Integer_binop_Bool _ _ _ = Nothing + +match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_binop_Ordering binop _ [x, y] + | (Var fx, [Lit (MachInt ix)]) <- collectArgs x, + (Var fy, [Lit (MachInt iy)]) <- collectArgs y, + idName fx == smallIntegerName, + idName fy == smallIntegerName + = Just $ case ix `binop` iy of + LT -> ltVal + EQ -> eqVal + GT -> gtVal +match_Integer_binop_Ordering _ _ _ = Nothing \end{code} diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 8759157f4e..65a0c334d5 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -15,6 +15,11 @@ module TysWiredIn ( trueDataCon, trueDataConId, true_RDR, falseDataCon, falseDataConId, false_RDR, + -- * Ordering + ltDataCon, ltDataConId, + eqDataCon, eqDataConId, + gtDataCon, gtDataConId, + -- * Char charTyCon, charDataCon, charTyCon_RDR, charTy, stringTy, charTyConName, @@ -424,6 +429,20 @@ trueDataCon = pcDataCon trueDataConName [] [] boolTyCon falseDataConId, trueDataConId :: Id falseDataConId = dataConWorkId falseDataCon trueDataConId = dataConWorkId trueDataCon + +orderingTyCon :: TyCon +orderingTyCon = pcTyCon True NonRecursive orderingTyConName + [] [ltDataCon, eqDataCon, gtDataCon] + +ltDataCon, eqDataCon, gtDataCon :: DataCon +ltDataCon = pcDataCon ltDataConName [] [] orderingTyCon +eqDataCon = pcDataCon eqDataConName [] [] orderingTyCon +gtDataCon = pcDataCon gtDataConName [] [] orderingTyCon + +ltDataConId, eqDataConId, gtDataConId :: Id +ltDataConId = dataConWorkId ltDataCon +eqDataConId = dataConWorkId eqDataCon +gtDataConId = dataConWorkId gtDataCon \end{code} %************************************************************************ diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 1a70068210..c6c941c4ca 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -132,16 +132,16 @@ with yes we have gone with no for now. \begin{code} -rnImports :: [LImportDecl RdrName] +rnImports :: SrcSpan -> [LImportDecl RdrName] -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImports imports +rnImports prel_imp_loc imports -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful -- warning for {- SOURCE -} ones that are unnecessary = do this_mod <- getModule implicit_prelude <- xoptM Opt_ImplicitPrelude - let prel_imports = mkPrelImports (moduleName this_mod) + let prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude imports (source, ordinary) = partition is_source_import imports is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot @@ -1393,18 +1393,20 @@ warnUnusedImportDecls gbl_env ; let usage :: [ImportDeclUsage] usage = findImportUsage imports rdr_env (Set.elems uses) - ; traceRn (ptext (sLit "Import usage") <+> ppr usage) + ; traceRn (vcat [ ptext (sLit "Uses:") <+> ppr (Set.elems uses) + , ptext (sLit "Import usage") <+> ppr usage]) ; ifWOptM Opt_WarnUnusedImports $ mapM_ warnUnusedImport usage ; ifDOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } where - explicit_import (L loc _) = case loc of - UnhelpfulSpan _ -> False - RealSrcSpan _ -> True + explicit_import (L _ decl) = unLoc (ideclName decl) /= pRELUDE_NAME -- Filter out the implicit Prelude import -- which we do not want to bleat about + -- This also filters out an *explicit* Prelude import + -- but solving that problem involves more plumbing, and + -- it just doesn't seem worth it \end{code} \begin{code} diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 1f615cb6e8..b5fc41ff1d 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -10,19 +10,33 @@ module CSE ( #include "HsVersions.h" +-- Note [Keep old CSEnv rep] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Temporarily retain code for the old representation for CSEnv +-- Keeping it only so that we can switch back if a bug shows up +-- or we want to do some performance comparisions +-- +-- NB: when you remove this, also delete hashExpr from CoreUtils +#ifdef OLD_CSENV_REP +import CoreUtils ( exprIsBig, hashExpr, eqExpr ) +import StaticFlags ( opt_PprStyle_Debug ) +import Util ( lengthExceeds ) +import UniqFM +import FastString +#else +import TrieMap +#endif + import CoreSubst import Var ( Var ) import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) -import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap ) +import CoreUtils ( mkAltExpr + , exprIsTrivial, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) import CoreSyn import Outputable -import StaticFlags ( opt_PprStyle_Debug ) import BasicTypes ( isAlwaysActive ) -import Util ( lengthExceeds ) -import UniqFM -import FastString import Data.List \end{code} @@ -206,22 +220,21 @@ cseRhs env (id',rhs) -- See Note [CSE for INLINE and NOINLINE] tryForCSE :: CSEnv -> InExpr -> OutExpr -tryForCSE _ (Type t) = Type t -tryForCSE _ (Coercion c) = Coercion c -tryForCSE env expr = case lookupCSEnv env expr' of - Just smaller_expr -> smaller_expr - Nothing -> expr' - where - expr' = cseExpr env expr +tryForCSE env expr + | exprIsTrivial expr' = expr' -- No point + | Just smaller <- lookupCSEnv env expr' = smaller + | otherwise = expr' + where + expr' = cseExpr env expr cseExpr :: CSEnv -> InExpr -> OutExpr -cseExpr _ (Type t) = Type t -cseExpr _ (Coercion co) = Coercion co +cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) +cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = lookupSubst env v cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) cseExpr env (Note n e) = Note n (cseExpr env e) -cseExpr env (Cast e co) = Cast (cseExpr env e) co +cseExpr env (Cast e co) = Cast (cseExpr env e) (substCo (csEnvSubst env) co) cseExpr env (Lam b e) = let (env', b') = addBinder env b in Lam b' (cseExpr env' e) cseExpr env (Let bind e) = let (env', bind') = cseBind env bind @@ -300,28 +313,34 @@ type OutExpr = CoreExpr -- Post-cloning type OutBndr = CoreBndr type OutAlt = CoreAlt -data CSEnv = CS CSEMap Subst +-- See Note [Keep old CsEnv rep] +#ifdef OLD_CSENV_REP +data CSEnv = CS { cs_map :: CSEMap + , cs_subst :: Subst } + type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping -- It maps the hash-code of an expression e to list of (e,e') pairs -- This means that it's good to replace e by e' -- INVARIANT: The expr in the range has already been CSE'd emptyCSEnv :: CSEnv -emptyCSEnv = CS emptyUFM emptySubst +emptyCSEnv = CS { cs_map = emptyUFM, cs_subst = emptySubst } lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr -lookupCSEnv (CS cs sub) expr - = case lookupUFM cs (hashExpr expr) of - Nothing -> Nothing - Just pairs -> lookup_list pairs +lookupCSEnv (CS { cs_map = oldmap, cs_subst = sub}) expr + = case lookupUFM oldmap (hashExpr expr) of + Nothing -> Nothing + Just pairs -> lookup_list pairs where + in_scope = substInScope sub + -- In this lookup we use full expression equality -- Reason: when expressions differ we generally find out quickly -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y), -- and this kind of thing happened in real programs lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr lookup_list ((e,e'):es) - | eqExpr (substInScope sub) e expr = Just e' + | eqExpr in_scope e expr = Just e' | otherwise = lookup_list es lookup_list [] = Nothing @@ -332,8 +351,8 @@ addCSEnvItem env expr expr' | exprIsBig expr = env -- (and are unlikely to be the same anyway) extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv -extendCSEnv (CS cs sub) expr expr' - = CS (addToUFM_C combine cs hash [(expr, expr')]) sub +extendCSEnv cse@(CS { cs_map = oldmap }) expr expr' + = cse { cs_map = addToUFM_C combine oldmap hash [(expr, expr')] } where hash = hashExpr expr combine old new @@ -344,24 +363,55 @@ extendCSEnv (CS cs sub) expr expr' long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result | otherwise = empty +#else +------------ NEW ---------------- + +data CSEnv = CS { cs_map :: CoreMap (OutExpr, OutExpr) -- Key, value + , cs_subst :: Subst } + +emptyCSEnv :: CSEnv +emptyCSEnv = CS { cs_map = emptyCoreMap, cs_subst = emptySubst } + +lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr +lookupCSEnv (CS { cs_map = csmap }) expr + = case lookupCoreMap csmap expr of + Just (_,e) -> Just e + Nothing -> Nothing + +addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv +addCSEnvItem = extendCSEnv + -- We used to avoid trying to CSE big expressions, on the grounds + -- that they are expensive to compare. But now we have CoreMaps + -- we can happily insert them and laziness will mean that the + -- insertions only get fully done if we look up in that part + -- of the trie. No need for a size test. + +extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv +extendCSEnv cse expr expr' + = cse { cs_map = extendCoreMap (cs_map cse) expr (expr,expr') } +#endif + +csEnvSubst :: CSEnv -> Subst +csEnvSubst = cs_subst + lookupSubst :: CSEnv -> Id -> OutExpr -lookupSubst (CS _ sub) x = lookupIdSubst (text "CSE.lookupSubst") sub x +lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x extendCSSubst :: CSEnv -> Id -> Id -> CSEnv -extendCSSubst (CS cs sub) x y = CS cs (extendIdSubst sub x (Var y)) +extendCSSubst cse x y = cse { cs_subst = extendIdSubst (cs_subst cse) x (Var y) } addBinder :: CSEnv -> Var -> (CSEnv, Var) -addBinder (CS cs sub) v = (CS cs sub', v') - where - (sub', v') = substBndr sub v +addBinder cse v = (cse { cs_subst = sub' }, v') + where + (sub', v') = substBndr (cs_subst cse) v addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) -addBinders (CS cs sub) vs = (CS cs sub', vs') - where - (sub', vs') = substBndrs sub vs +addBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substBndrs (cs_subst cse) vs addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders (CS cs sub) vs = (CS cs sub', vs') - where - (sub', vs') = substRecBndrs sub vs +addRecBinders cse vs = (cse { cs_subst = sub' }, vs') + where + (sub', vs') = substRecBndrs (cs_subst cse) vs \end{code} diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 41ecb01b6b..8b4b4e382e 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -35,6 +35,9 @@ module CoreMonad ( liftIO, liftIOWithCount, liftIO1, liftIO2, liftIO3, liftIO4, + -- ** Global initialization + reinitializeGlobals, + -- ** Dealing with annotations getAnnotations, getFirstAnnotations, @@ -96,8 +99,16 @@ import Control.Monad import Prelude hiding ( read ) #ifdef GHCI +import Control.Concurrent.MVar (MVar) +import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) import qualified Language.Haskell.TH as TH +#else +saveLinkerGlobals :: IO () +saveLinkerGlobals = return () + +restoreLinkerGlobals :: () -> IO () +restoreLinkerGlobals () = return () #endif \end{code} @@ -224,7 +235,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoSpecConstr - | CoreDoGlomBinds | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules -- matching this string @@ -261,7 +271,6 @@ coreDumpFlag CorePrep = Just Opt_D_dump_prep coreDumpFlag CoreDoPrintCore = Nothing coreDumpFlag (CoreDoRuleCheck {}) = Nothing coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag CoreDoGlomBinds = Nothing coreDumpFlag (CoreDoPasses {}) = Nothing instance Outputable CoreToDo where @@ -282,7 +291,6 @@ instance Outputable CoreToDo where ppr CorePrep = ptext (sLit "CorePrep") ppr CoreDoPrintCore = ptext (sLit "Print core") ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") - ppr CoreDoGlomBinds = ptext (sLit "Glom binds") ppr CoreDoNothing = ptext (sLit "CoreDoNothing") ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") @@ -691,7 +699,13 @@ newtype CoreState = CoreState { data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, - cr_module :: Module + cr_module :: Module, + cr_globals :: ((Bool, [String], [Way]), +#ifdef GHCI + (MVar PersistentLinkerState, Bool)) +#else + ()) +#endif } data CoreWriter = CoreWriter { @@ -749,13 +763,15 @@ runCoreM :: HscEnv -> Module -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base us mod m = - liftM extract $ runIOEnv reader $ unCoreM m state +runCoreM hsc_env rule_base us mod m = do + glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals + liftM extract $ runIOEnv (reader glbls) $ unCoreM m state where - reader = CoreReader { + reader glbls = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, - cr_module = mod + cr_module = mod, + cr_globals = glbls } state = CoreState { cs_uniq_supply = us @@ -844,6 +860,49 @@ getOrigNameCache = do liftIO $ fmap nsNames $ readIORef nameCacheRef \end{code} +%************************************************************************ +%* * + Initializing globals +%* * +%************************************************************************ + +This is a rather annoying function. When a plugin is loaded, it currently +gets linked against a *newly loaded* copy of the GHC package. This would +not be a problem, except that the new copy has its own mutable state +that is not shared with that state that has already been initialized by +the original GHC package. + +This leads to loaded plugins calling GHC code which pokes the static flags, +and then dying with a panic because the static flags *it* sees are uninitialized. + +There are two possible solutions: + 1. Export the symbols from the GHC executable from the GHC library and link + against this existing copy rather than a new copy of the GHC library + 2. Carefully ensure that the global state in the two copies of the GHC + library matches + +I tried 1. and it *almost* works (and speeds up plugin load times!) except +on Windows. On Windows the GHC library tends to export more than 65536 symbols +(see #5292) which overflows the limit of what we can export from the EXE and +causes breakage. + +(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem, +because we could share the GHC library it links to.) + +We are going to try 2. instead. Unfortunately, this means that every plugin +will have to say `reinitializeGlobals` before it does anything, but never mind. + +I've threaded the cr_globals through CoreM rather than giving them as an +argument to the plugin function so that we can turn this function into +(return ()) without breaking any plugins when we eventually get 1. working. + +\begin{code} +reinitializeGlobals :: CoreM () +reinitializeGlobals = do + (sf_globals, linker_globals) <- read cr_globals + liftIO $ restoreStaticFlagGlobals sf_globals + liftIO $ restoreLinkerGlobals linker_globals +\end{code} %************************************************************************ %* * diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index cf2d7245a7..4f6d7b4690 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -170,12 +170,34 @@ floatBind (Rec pairs) | isTopLvl dest_lvl -- See Note [floatBind for top level] = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> (fs, emptyFloats, addTopFloatPairs (flattenTopFloats rhs_floats) [(name, rhs')])} - | otherwise - = case (floatBody dest_lvl rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, [(name, rhs')]) } + | otherwise -- Note [Floating out of Rec rhss] + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> + case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> + case (splitRecFloats heres) of { (pairs, case_heres) -> + (fs, rhs_floats', (name, installUnderLambdas case_heres rhs') : pairs) }}} where dest_lvl = floatSpecLevel spec +splitRecFloats :: Bag FloatBind -> ([(Id,CoreExpr)], Bag FloatBind) +-- The "tail" begins with a case +-- See Note [Floating out of Rec rhss] +splitRecFloats fs + = go [] (bagToList fs) + where + go prs (FloatLet (NonRec b r) : fs) = go ((b,r):prs) fs + go prs (FloatLet (Rec prs') : fs) = go (prs' ++ prs) fs + go prs fs = (prs, listToBag fs) + +installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr +-- Note [Floating out of Rec rhss] +installUnderLambdas floats e + | isEmptyBag floats = e + | otherwise = go e + where + go (Lam b e) = Lam b (go e) + go (Note n e) | notSccNote n = Note n (go e) + go e = install floats e + --------------- floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) floatList _ [] = (zeroStats, emptyFloats, []) @@ -184,6 +206,27 @@ floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} \end{code} +Note [Floating out of Rec rhss] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider Rec { f<1,0> = \xy. body } +From the body we may get some floats. The ones with level <1,0> must +stay here, since they may mention f. Ideally we'd like to make them +part of the Rec block pairs -- but we can't if there are any +FloatCases involved. + +Nor is it a good idea to dump them in the rhs, but outside the lambda + f = case x of I# y -> \xy. body +because now f's arity might get worse, which is Not Good. (And if +there's an SCC around the RHS it might not get better again. +See Trac #5342.) + +So, gruesomely, we split the floats into + * the outer FloatLets, which can join the Rec, and + * an inner batch starting in a FloatCase, which are then + pushed *inside* the lambdas. +This loses full-laziness the rare situation where there is a +FloatCase and a Rec interacting. + Note [floatBind for top level] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 989144c585..95d1325730 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -35,7 +35,7 @@ import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique import UniqFM -import Util ( mapAndUnzip, filterOut ) +import Util ( mapAndUnzip, filterOut, fstOf3 ) import Bag import Outputable import FastString @@ -334,10 +334,24 @@ That's why we compute not choosen as a loop breaker.) Why not? Because then we drop the binding for 'g', which leaves it out of scope in the RULE! - - We "solve" this by making g a "weak" or "rules-only" loop breaker, - with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker - has IAmLoopBreaker False. So + + Here's a somewhat different example of the same thing + Rec { g = h + ; h = ...f... + ; f = f_rhs + RULE f [] = g } + Here the RULE is "below" g, but we *still* can't postInlineUnconditionally + because the RULE for f is active throughout. So the RHS of h + might rewrite to h = ...g... + So g must remain in scope in the output program! + + We "solve" this by: + + Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff g appears in the LHS or RHS of any rule for the Rec + whether or not the rule is active + + A normal "strong" loop breaker has IAmLoopBreaker False. So Inline postInlineUnconditionally IAmLoopBreaker False no no @@ -345,7 +359,9 @@ That's why we compute other yes yes The **sole** reason for this kind of loop breaker is so that - postInlineUnconditionally does not fire. Ugh. + postInlineUnconditionally does not fire. Ugh. (Typically it'll + inline via the usual callSiteInline stuff, so it'll be dead in the + next pass, so the main Ugh is the tiresome complication.) Note [Rules for imported functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -523,7 +539,9 @@ data Details -- but excluding any RULES -- This is the IdSet that may be used if the Id is inlined - , nd_rule_fvs :: IdSet -- Free variables of the RHS of active RULES + , nd_rule_fvs :: IdSet -- Free variables of LHS or RHS of all RULES + -- whether active or not + , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES -- In the last two fields, we haev already expanded occurrences -- of imported Ids for which we have local RULES, to their local-id sets @@ -531,22 +549,23 @@ data Details makeNode :: OccEnv -> VarSet -> (Var, CoreExpr) -> Node Details makeNode env bndr_set (bndr, rhs) - = (details, varUnique bndr, keysUFM (udFreeVars bndr_set rhs_usage4)) + = (details, varUnique bndr, keysUFM (udFreeVars bndr_set rhs_usage3)) where details = ND { nd_bndr = bndr , nd_rhs = rhs' - , nd_uds = rhs_usage4 + , nd_uds = rhs_usage3 , nd_inl = inl_fvs - , nd_rule_fvs = active_rule_fvs } + , nd_rule_fvs = all_rule_fvs + , nd_active_rule_fvs = active_rule_fvs } -- Constructing the edges for the main Rec computation -- See Note [Forming Rec groups] (rhs_usage1, rhs') = occAnalRhs env Nothing rhs - rhs_usage2 = addIdOccs rhs_usage1 rule_rhs_fvs -- Note [Rules are extra RHSs] - rhs_usage3 = addIdOccs rhs_usage2 rule_lhs_fvs -- Note [Rule dependency info] - rhs_usage4 = case mb_unf_fvs of - Just unf_fvs -> addIdOccs rhs_usage3 unf_fvs - Nothing -> rhs_usage3 + rhs_usage2 = addIdOccs rhs_usage1 all_rule_fvs -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_usage3 = case mb_unf_fvs of + Just unf_fvs -> addIdOccs rhs_usage2 unf_fvs + Nothing -> rhs_usage2 -- Finding the free variables of the rules is_active = occ_rule_act env :: Activation -> Bool @@ -557,7 +576,7 @@ makeNode env bndr_set (bndr, rhs) , let fvs = exprFreeVars (ru_rhs rule) `delVarSetList` ru_bndrs rule , not (isEmptyVarSet fvs) ] - rule_rhs_fvs = foldr (unionVarSet . snd) emptyVarSet rules_w_fvs + all_rule_fvs = foldr (unionVarSet . snd) rule_lhs_fvs rules_w_fvs rule_lhs_fvs = foldr (unionVarSet . (\ru -> exprsFreeVars (ru_args ru) `delVarSetList` ru_bndrs ru)) emptyVarSet rules @@ -620,8 +639,8 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds) --------------------------- -- Now reconstruct the cycle pairs :: [(Id,CoreExpr)] - pairs | any non_boring bndrs = loopBreakNodes 0 bndr_set emptyVarSet loop_breaker_edges [] - | otherwise = reOrderNodes 0 bndr_set emptyVarSet tagged_nodes [] + pairs | any non_boring bndrs = loopBreakNodes 0 bndr_set rule_fvs loop_breaker_edges [] + | otherwise = reOrderNodes 0 bndr_set rule_fvs tagged_nodes [] non_boring bndr = isId bndr && (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr) -- If all are boring, the loop_breaker_edges will be a single Cyclic SCC @@ -632,12 +651,17 @@ occAnalRec (CyclicSCC nodes) (body_uds, binds) = (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs)) ------------------------------------ - rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of active rules - -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fvs :: VarSet + rule_fvs = foldr (unionVarSet . nd_rule_fvs . fstOf3) emptyVarSet nodes + + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- mentioned in RHS of active rules for f + -- Domain is *subset* of bound vars (others have no rule fvs) rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) init_rule_fvs -- See Note [Finding rule RHS free vars] = [ (b, trimmed_rule_fvs) - | (ND { nd_bndr = b, nd_rule_fvs = rule_fvs },_,_) <- nodes + | (ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs },_,_) <- nodes , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set , not (isEmptyVarSet trimmed_rule_fvs)] \end{code} @@ -666,46 +690,38 @@ mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) mk_non_loop_breaker :: VarSet -> Node Details -> Binding -- See Note [Weak loop breakers] -mk_non_loop_breaker used_earlier (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) - | bndr `elemVarSet` used_earlier = (setIdOccInfo bndr weakLoopBreaker, rhs) - | otherwise = (bndr, rhs) +mk_non_loop_breaker used_in_rules (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) + | bndr `elemVarSet` used_in_rules = (setIdOccInfo bndr weakLoopBreaker, rhs) + | otherwise = (bndr, rhs) udFreeVars :: VarSet -> UsageDetails -> VarSet -- Find the subset of bndrs that are mentioned in uds udFreeVars bndrs uds = intersectUFM_C (\b _ -> b) bndrs uds loopBreakNodes :: Int - -> VarSet -> VarSet -- All binders and binders used earlier + -> VarSet -> VarSet -- All binders, and binders used in RULES -> [Node Details] -> [Binding] -- Append these to the end -> [Binding] -- Return the bindings sorted into a plausible order, and marked with loop breakers. -loopBreakNodes depth bndr_set used_earlier nodes binds - = go used_earlier (stronglyConnCompFromEdgedVerticesR nodes) binds +loopBreakNodes depth bndr_set used_in_rules nodes binds + = go (stronglyConnCompFromEdgedVerticesR nodes) binds where - go _ [] binds = binds - go used_earlier (scc:sccs) binds = loop_break_scc used_earlier scc $ - go (used_earlier `unionVarSet` scc_uses scc) sccs binds - - scc_uses :: SCC (Node Details) -> VarSet - scc_uses (AcyclicSCC node) = node_uses node - scc_uses (CyclicSCC nodes) = foldr (unionVarSet . node_uses) emptyVarSet nodes - - node_uses :: Node Details -> VarSet - node_uses (nd,_,_) = udFreeVars bndr_set (nd_uds nd) + go [] binds = binds + go (scc:sccs) binds = loop_break_scc scc (go sccs binds) - loop_break_scc used_earlier scc binds + loop_break_scc scc binds = case scc of - AcyclicSCC node -> mk_non_loop_breaker used_earlier node : binds + AcyclicSCC node -> mk_non_loop_breaker used_in_rules node : binds CyclicSCC [node] -> mk_loop_breaker node : binds - CyclicSCC nodes -> reOrderNodes depth bndr_set used_earlier nodes binds + CyclicSCC nodes -> reOrderNodes depth bndr_set used_in_rules nodes binds reOrderNodes :: Int -> VarSet -> VarSet -> [Node Details] -> [Binding] -> [Binding] -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out reOrderNodes _ _ _ [] _ = panic "reOrderNodes" -reOrderNodes depth bndr_set used_earlier (node : nodes) binds - = loopBreakNodes new_depth bndr_set used_earlier unchosen $ +reOrderNodes depth bndr_set used_in_rules (node : nodes) binds + = loopBreakNodes new_depth bndr_set used_in_rules unchosen $ (map mk_loop_breaker chosen_nodes ++ binds) where (chosen_nodes, unchosen) = choose_loop_breaker (score node) [node] [] nodes diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 226c9c4137..20425db8f6 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -247,7 +247,6 @@ getCoreToDo dflags runWhen strictness (CoreDoPasses [ CoreDoStrictness, CoreDoWorkerWrapper, - CoreDoGlomBinds, simpl_phase 0 ["post-worker-wrapper"] max_iter ]), @@ -391,7 +390,6 @@ doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} vectorise -doCorePass CoreDoGlomBinds = doPassDM glomBinds doCorePass CoreDoPrintCore = observe printCore doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat doCorePass CoreDoNothing = return @@ -515,48 +513,6 @@ simplExprGently env expr = do %************************************************************************ %* * -\subsection{Glomming} -%* * -%************************************************************************ - -\begin{code} -glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] --- Glom all binds together in one Rec, in case any --- transformations have introduced any new dependencies --- --- NB: the global invariant is this: --- *** the top level bindings are never cloned, and are always unique *** --- --- We sort them into dependency order, but applying transformation rules may --- make something at the top refer to something at the bottom: --- f = \x -> p (q x) --- h = \y -> 3 --- --- RULE: p (q x) = h x --- --- Applying this rule makes f refer to h, --- although it doesn't appear to in the source program. --- This pass lets us control where it happens. --- --- NOTICE that this cannot happen for rules whose head is a locally-defined --- function. It only happens for rules whose head is an imported function --- (p in the example above). So, for example, the rule had been --- RULE: f (p x) = h x --- then the rule for f would be attached to f itself (in its IdInfo) --- by prepareLocalRuleBase and h would be regarded by the occurrency --- analyser as free in f. - -glomBinds dflags binds - = do { Err.showPass dflags "GlomBinds" ; - let { recd_binds = [Rec (flattenBinds binds)] } ; - return recd_binds } - -- Not much point in printing the result... - -- just consumes output bandwidth -\end{code} - - -%************************************************************************ -%* * \subsection{The driver for the simplifier} %* * %************************************************************************ diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 2d416d7fb6..862bc8dccc 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -110,9 +110,9 @@ data SimplEnv seCC :: CostCentreStack, -- The enclosing CCS (when profiling) -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion - seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seCvSubst :: CvSubstEnv, -- InCoVar |--> OutCoercion + seIdSubst :: SimplIdSubst, -- InId |--> OutExpr ----------- Dynamic part of the environment ----------- -- Dynamic in the sense of describing the setup where diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index 29f683f2d4..d59e460c03 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -11,7 +11,7 @@ import StgSyn import Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import Id ( Id, idType, isLocalId ) import VarSet -import DataCon ( DataCon, dataConInstArgTys, dataConRepType ) +import DataCon import CoreSyn ( AltCon(..) ) import PrimOp ( primOpType ) import Literal ( literalType ) @@ -19,15 +19,15 @@ import Maybes import Name ( getSrcLoc ) import ErrUtils ( Message, mkLocMessage ) import TypeRep -import Type ( mkFunTys, splitFunTy_maybe, splitTyConApp_maybe, - isUnLiftedType, isTyVarTy, dropForAlls - ) -import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) -import Util ( zipEqual, equalLength ) +import Type +import TyCon +import Util import SrcLoc import Outputable import FastString import Control.Monad + +#include "HsVersions.h" \end{code} Checks for @@ -107,18 +107,21 @@ lint_binds_help :: (Id, StgRhs) -> LintM () lint_binds_help (binder, rhs) = addLoc (RhsOf binder) $ do -- Check the rhs - maybe_rhs_ty <- lintStgRhs rhs + _maybe_rhs_ty <- lintStgRhs rhs -- Check binder doesn't have unlifted type checkL (not (isUnLiftedType binder_ty)) (mkUnLiftedTyMsg binder rhs) -- Check match to RHS type - case maybe_rhs_ty of - Nothing -> return () - Just rhs_ty -> checkTys binder_ty - rhs_ty - (mkRhsMsg binder rhs_ty) + -- Actually we *can't* check the RHS type, because + -- unsafeCoerce means it really might not match at all + -- notably; eg x::Int = (error @Bool "urk") |> unsafeCoerce... + -- case maybe_rhs_ty of + -- Nothing -> return () + -- Just rhs_ty -> checkTys binder_ty + -- rhs_ty + --- (mkRhsMsg binder rhs_ty) return () where @@ -126,7 +129,7 @@ lint_binds_help (binder, rhs) \end{code} \begin{code} -lintStgRhs :: StgRhs -> LintM (Maybe Type) +lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr) = lintStgExpr expr @@ -145,7 +148,7 @@ lintStgRhs (StgRhsCon _ con args) = runMaybeT $ do \end{code} \begin{code} -lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Nothing if error found +lintStgExpr :: StgExpr -> LintM (Maybe Type) -- Just ty => type is exact lintStgExpr (StgLit l) = return (Just (literalType l)) @@ -160,18 +163,18 @@ lintStgExpr e@(StgConApp con args) = runMaybeT $ do where con_ty = dataConRepType con -lintStgExpr (StgOpApp (StgFCallOp _ _) args res_ty) = runMaybeT $ do - -- We don't have enough type information to check - -- the application; ToDo - _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args - return res_ty - lintStgExpr e@(StgOpApp (StgPrimOp op) args _) = runMaybeT $ do arg_tys <- mapM (MaybeT . lintStgArg) args MaybeT $ checkFunApp op_ty arg_tys (mkFunAppMsg op_ty arg_tys e) where op_ty = primOpType op +lintStgExpr (StgOpApp _ args res_ty) = runMaybeT $ do + -- We don't have enough type information to check + -- the application for StgFCallOp and StgPrimCallOp; ToDo + _maybe_arg_tys <- mapM (MaybeT . lintStgArg) args + return res_ty + lintStgExpr (StgLam _ bndrs _) = do addErrL (ptext (sLit "Unexpected StgLam") <+> ppr bndrs) return Nothing @@ -190,7 +193,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do lintStgExpr (StgSCC _ expr) = lintStgExpr expr -lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do +lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do _ <- MaybeT $ lintStgExpr scrut MaybeT $ liftM Just $ @@ -200,28 +203,21 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do UbxTupAlt tc -> check_bndr tc PolyAlt -> return () - MaybeT $ do - -- we only allow case of tail-call or primop. - case scrut of - StgApp _ _ -> return () - StgConApp _ _ -> return () - StgOpApp _ _ _ -> return () - _ -> addErrL (mkCaseOfCaseMsg e) - - addInScopeVars [bndr] $ - lintStgAlts alts scrut_ty + MaybeT $ addInScopeVars [bndr] $ + lintStgAlts alts scrut_ty where scrut_ty = idType bndr - bad_bndr = mkDefltMsg bndr - check_bndr tc = case splitTyConApp_maybe scrut_ty of + check_bndr tc = case splitTyConApp_maybe (repType scrut_ty) of Just (bndr_tc, _) -> checkL (tc == bndr_tc) bad_bndr Nothing -> addErrL bad_bndr + where + bad_bndr = mkDefltMsg bndr tc lintStgExpr e = pprPanic "lintStgExpr" (ppr e) lintStgAlts :: [StgAlt] -> Type -- Type of scrutinee - -> LintM (Maybe Type) -- Type of alternatives + -> LintM (Maybe Type) -- Just ty => type is accurage lintStgAlts alts scrut_ty = do maybe_result_tys <- mapM (lintAlt scrut_ty) alts @@ -230,10 +226,12 @@ lintStgAlts alts scrut_ty = do case catMaybes (maybe_result_tys) of [] -> return Nothing - (first_ty:tys) -> do mapM_ check tys + (first_ty:_tys) -> do -- mapM_ check tys return (Just first_ty) where - check ty = checkTys first_ty ty (mkCaseAltMsg alts) + -- check ty = checkTys first_ty ty (mkCaseAltMsg alts) + -- We can't check that the alternatives have the + -- same type, becuase they don't, with unsafeCoerce# lintAlt :: Type -> (AltCon, [Id], [Bool], StgExpr) -> LintM (Maybe Type) lintAlt _ (DEFAULT, _, _, rhs) @@ -250,11 +248,12 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do let cons = tyConDataCons tycon arg_tys = dataConInstArgTys con tys_applied - -- This almost certainly does not work for existential constructors + -- This does not work for existential constructors checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) - checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args) - mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args) + checkL (length args == dataConRepArity con) (mkAlgAltMsg3 con args) + when (isVanillaDataCon con) $ + mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args) return () _ -> addErrL (mkAltMsg1 scrut_ty) @@ -381,30 +380,80 @@ have long since disappeared. \begin{code} checkFunApp :: Type -- The function type -> [Type] -- The arg type(s) - -> Message -- Error messgae - -> LintM (Maybe Type) -- The result type - -checkFunApp fun_ty arg_tys msg = LintM checkFunApp' + -> Message -- Error message + -> LintM (Maybe Type) -- Just ty => result type is accurate + +checkFunApp fun_ty arg_tys msg + = do { case mb_msg of + Just msg -> addErrL msg + Nothing -> return () + ; return mb_ty } where - checkFunApp' loc _scope errs - = cfa fun_ty arg_tys - where - cfa fun_ty [] -- Args have run out; that's fine - = (Just fun_ty, errs) - - cfa fun_ty (_:arg_tys) - | Just (_arg_ty, res_ty) <- splitFunTy_maybe (dropForAlls fun_ty) - = cfa res_ty arg_tys - - | isTyVarTy fun_ty -- Expected arg tys ran out first; - = (Just fun_ty, errs) -- first see if fun_ty is a tyvar template; - -- otherwise, maybe fun_ty is a - -- dictionary type which is actually a function? + (mb_ty, mb_msg) = cfa True fun_ty arg_tys + + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe Message) -- Errors? + + cfa accurate fun_ty [] -- Args have run out; that's fine + = (if accurate then Just fun_ty else Nothing, Nothing) + + cfa accurate fun_ty arg_tys@(arg_ty':arg_tys') + | Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty + = if accurate && not (arg_ty `stgEqType` arg_ty') + then (Nothing, Just msg) -- Arg type mismatch + else cfa accurate res_ty arg_tys' + + | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty + = cfa False fun_ty' arg_tys + + | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty + , isNewTyCon tc + = if length tc_args < tyConArity tc + then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg ) + (Nothing, Nothing) -- This is odd, but I've seen it + else cfa False (newTyConInstRhs tc tc_args) arg_tys + + | Just (tc,_) <- splitTyConApp_maybe fun_ty + , not (isSynFamilyTyCon tc) -- Definite error + = (Nothing, Just msg) -- Too many args + | otherwise - = (Nothing, addErr errs msg loc) -- Too many args + = (Nothing, Nothing) \end{code} \begin{code} +stgEqType :: Type -> Type -> Bool +-- Compare types, but crudely because we have discarded +-- both casts and type applications, so types might look +-- different but be the same. So reply "True" if in doubt. +-- "False" means that the types are definitely different. +-- +-- Fundamentally this is a losing battle because of unsafeCoerce + +stgEqType orig_ty1 orig_ty2 + = go rep_ty1 rep_ty2 + where + rep_ty1 = deepRepType orig_ty1 + rep_ty2 = deepRepType orig_ty2 + go ty1 ty2 + | Just (tc1, tc_args1) <- splitTyConApp_maybe ty1 + , Just (tc2, tc_args2) <- splitTyConApp_maybe ty2 + , let res = if tc1 == tc2 + then equalLength tc_args1 tc_args2 + && and (zipWith go tc_args1 tc_args2) + else -- TyCons don't match; but don't bleat if either is a + -- family TyCon because a coercion might have made it + -- equal to something else + (isFamilyTyCon tc1 || isFamilyTyCon tc2) + = if res then True + else + pprTrace "stgEqType: unequal" (vcat [ppr orig_ty1, ppr orig_ty2, ppr rep_ty1 + , ppr rep_ty2, ppr ty1, ppr ty2]) + False + + | otherwise = True -- Conservatively say "fine". + -- Type variables in particular + checkInScope :: Id -> LintM () checkInScope id = LintM $ \loc scope errs -> if isLocalId id && not (id `elemVarSet` scope) then @@ -413,22 +462,22 @@ checkInScope id = LintM $ \loc scope errs ((), errs) checkTys :: Type -> Type -> Message -> LintM () -checkTys _ty1 _ty2 _msg = LintM $ \_loc _scope errs - -> -- if (ty1 == ty2) then - ((), errs) - -- else ((), addErr errs msg loc) +checkTys ty1 ty2 msg = LintM $ \loc _scope errs + -> if (ty1 `stgEqType` ty2) + then ((), errs) + else ((), addErr errs msg loc) \end{code} \begin{code} -mkCaseAltMsg :: [StgAlt] -> Message -mkCaseAltMsg _alts +_mkCaseAltMsg :: [StgAlt] -> Message +_mkCaseAltMsg _alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (empty) -- LATER: ppr alts -mkDefltMsg :: Id -> Message -mkDefltMsg _bndr +mkDefltMsg :: Id -> TyCon -> Message +mkDefltMsg bndr tc = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) - (panic "mkDefltMsg") + (ppr bndr $$ ppr (idType bndr) $$ ppr tc) mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message mkFunAppMsg fun_ty arg_tys expr @@ -472,12 +521,8 @@ mkAlgAltMsg4 ty arg ppr arg ] -mkCaseOfCaseMsg :: StgExpr -> Message -mkCaseOfCaseMsg e - = text "Case of non-tail-call:" $$ ppr e - -mkRhsMsg :: Id -> Type -> Message -mkRhsMsg binder ty +_mkRhsMsg :: Id -> Type -> Message +_mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index d2c4c7da9e..7bc5d8c2e5 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1372,21 +1372,7 @@ inferInstanceContexts oflag infer_specs , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ addErrCtxt (derivInstCtxt the_pred) $ - do { -- Check for a bizarre corner case, when the derived instance decl should - -- have form instance C a b => D (T a) where ... - -- Note that 'b' isn't a parameter of T. This gives rise to all sorts - -- of problems; in particular, it's hard to compare solutions for - -- equality when finding the fixpoint. Moreover, simplifyDeriv - -- has an assert failure because it finds a TyVar when it expects - -- only TcTyVars. So I just rule it out for now. I'm not - -- even sure how it can arise. - - ; let tv_set = mkVarSet tyvars - weird_preds = [pred | pred <- deriv_rhs - , not (tyVarsOfPred pred `subVarSet` tv_set)] - ; mapM_ (addErrTc . badDerivedPred) weird_preds - - ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs + do { theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify @@ -1745,10 +1731,4 @@ standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for" derivInstCtxt :: PredType -> Message derivInstCtxt pred = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) - -badDerivedPred :: PredType -> Message -badDerivedPred pred - = vcat [ptext (sLit "Can't derive instances where the instance context mentions"), - ptext (sLit "type variables that are not data type parameters"), - nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)] \end{code} diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 277d94941e..7ed7145863 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -123,10 +123,8 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli -- Only report ambiguity if no other errors (at all) happened -- See Note [Avoiding spurious errors] in TcSimplify - ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs } + ; ifErrsM (return ()) $ reportAmbigErrs ctxt ambigs } where - skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt) - -- Report equalities of form (a~ty) first. They are usually -- skolem-equalities, and they cause confusing knock-on -- effects in other errors; see test T4093b. @@ -138,9 +136,9 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli -- (a) it is a class constraint -- (b) it constrains only type variables -- (else we'd prefer to report it as "no instance for...") - -- (c) it mentions type variables that are not skolems + -- (c) it mentions a (presumably un-filled-in) meta type variable is_ambiguous d = isTyVarClassPred pred - && not (tyVarsOfPred pred `subVarSet` skols) + && any isAmbiguousTyVar (varSetElems (tyVarsOfPred pred)) where pred = evVarOfPred d @@ -217,13 +215,13 @@ pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) pprWithArising [] = panic "pprWithArising" pprWithArising [EvVarX ev loc] - = (loc, pprEvVarTheta [ev] <+> pprArising (ctLocOrigin loc)) + = (loc, hang (pprEvVarTheta [ev]) 2 (pprArising (ctLocOrigin loc))) pprWithArising ev_vars = (first_loc, vcat (map ppr_one ev_vars)) where first_loc = evVarX (head ev_vars) ppr_one (EvVarX v loc) - = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc + = hang (parens (pprPredTy (evVarPred v))) 2 (pprArisingAt loc) addErrorReport :: ReportErrCtxt -> SDoc -> TcM () addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) @@ -684,59 +682,58 @@ that match such things. And flattening under a for-all is problematic anyway; consider C (forall a. F a) \begin{code} -reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM () -reportAmbigErrs ctxt skols ambigs +reportAmbigErrs :: ReportErrCtxt -> [WantedEvVar] -> TcM () +reportAmbigErrs ctxt ambigs -- Divide into groups that share a common set of ambiguous tyvars - = mapM_ report (equivClasses cmp ambigs_w_tvs) - where - ambigs_w_tvs = [ (d, varSetElems (tyVarsOfEvVarX d `minusVarSet` skols)) + = mapM_ (reportAmbigGroup ctxt) (equivClasses cmp ambigs_w_tvs) + where + ambigs_w_tvs = [ (d, filter isAmbiguousTyVar (varSetElems (tyVarsOfEvVarX d))) | d <- ambigs ] cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 - report :: [(WantedEvVar, [TcTyVar])] -> TcM () - report pairs - = setCtLoc loc $ - do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs - <+> pprQuotedList tvs - <+> text "in the constraint" <> plural pairs <> colon - , nest 2 pp_wanteds ] - ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs - ; addErrTcM (tidy_env, main_msg $$ mono_msg) } - where - (_, tvs) : _ = pairs - (loc, pp_wanteds) = pprWithArising (map fst pairs) - -mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc) --- There's an error with these Insts; if they have free type variables --- it's probably caused by the monomorphism restriction. --- Try to identify the offending variable --- ASSUMPTION: the Insts are fully zonked -mkMonomorphismMsg ctxt inst_tvs - = do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) - ; return (tidy_env, mk_msg dflags docs) } + +reportAmbigGroup :: ReportErrCtxt -> [(WantedEvVar, [TcTyVar])] -> TcM () +-- The pairs all have the same [TcTyVar] +reportAmbigGroup ctxt pairs + = setCtLoc loc $ + do { dflags <- getDOpts + ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet tvs) + ; addErrTcM (tidy_env, main_msg $$ mk_msg dflags docs) } where - mk_msg _ _ | any isRuntimeUnkSkol inst_tvs -- See Note [Runtime skolems] + (wev, tvs) : _ = pairs + (loc, pp_wanteds) = pprWithArising (map fst pairs) + main_msg = sep [ text "Ambiguous type variable" <> plural tvs + <+> pprQuotedList tvs + <+> text "in the constraint" <> plural pairs <> colon + , nest 2 pp_wanteds ] + + mk_msg dflags docs + | any isRuntimeUnkSkol tvs -- See Note [Runtime skolems] = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> - (pprWithCommas ppr inst_tvs), - ptext (sLit "Use :print or :force to determine these types")] - mk_msg _ [] = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") + (pprWithCommas ppr tvs), + ptext (sLit "Use :print or :force to determine these types")] + + | DerivOrigin <- ctLocOrigin (evVarX wev) + = ptext (sLit "Probable fix: use a 'standalone deriving' declaration instead") + + | null docs + = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") -- where monomorphism doesn't play any role - mk_msg dflags docs + | otherwise = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"), nest 2 (vcat docs), - monomorphism_fix dflags] - -monomorphism_fix :: DynFlags -> SDoc -monomorphism_fix dflags - = ptext (sLit "Probable fix:") <+> vcat - [ptext (sLit "give these definition(s) an explicit type signature"), - if xopt Opt_MonomorphismRestriction dflags - then ptext (sLit "or use -XNoMonomorphismRestriction") - else empty] -- Only suggest adding "-XNoMonomorphismRestriction" - -- if it is not already set! + mono_fix dflags] + + mono_fix :: DynFlags -> SDoc + mono_fix dflags + = ptext (sLit "Probable fix:") <+> vcat + [ptext (sLit "give these definition(s) an explicit type signature"), + if xopt Opt_MonomorphismRestriction dflags + then ptext (sLit "or use -XNoMonomorphismRestriction") + else empty] -- Only suggest adding "-XNoMonomorphismRestriction" + -- if it is not already set! getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo getSkolemInfo [] tv diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 4ab3523b3f..b7a3a50649 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -59,11 +59,9 @@ import MonadUtils import Outputable import FastString import Bag -import Binary hiding (get,put) import Fingerprint import Constants -import System.IO.Unsafe ( unsafePerformIO ) import Data.List ( partition, intersperse ) \end{code} @@ -1197,11 +1195,8 @@ gen_Typeable_binds loc tycon HsString modl_fs, HsString name_fs]) - Fingerprint high low = unsafePerformIO $ -- ugh - computeFingerprint (error "gen_typeable_binds") - (unpackFS pkg_fs ++ - unpackFS modl_fs ++ - unpackFS name_fs) + hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs] + Fingerprint high low = fingerprintString hashThis int64 | wORD_SIZE == 4 = HsWord64Prim . fromIntegral diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index 5ad5dca363..983df3c503 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -35,10 +35,10 @@ import TcErrors import TcSMonad import Maybes( orElse ) import Bag -import qualified Data.Map as Map import Control.Monad( when ) - +import Unique +import UniqFM import FastString ( sLit ) import DynFlags \end{code} @@ -89,52 +89,51 @@ implication constraint (when in top-level inference mode). \begin{code} -data CCanMap a = CCanMap { cts_given :: Map.Map a CanonicalCts +data CCanMap a = CCanMap { cts_given :: UniqFM CanonicalCts -- Invariant: all Given - , cts_derived :: Map.Map a CanonicalCts + , cts_derived :: UniqFM CanonicalCts -- Invariant: all Derived - , cts_wanted :: Map.Map a CanonicalCts } + , cts_wanted :: UniqFM CanonicalCts } -- Invariant: all Wanted -cCanMapToBag :: Ord a => CCanMap a -> CanonicalCts -cCanMapToBag cmap = Map.fold unionBags rest_wder (cts_given cmap) - where rest_wder = Map.fold unionBags rest_der (cts_wanted cmap) - rest_der = Map.fold unionBags emptyCCan (cts_derived cmap) +cCanMapToBag :: CCanMap a -> CanonicalCts +cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap) + where rest_wder = foldUFM unionBags rest_der (cts_wanted cmap) + rest_der = foldUFM unionBags emptyCCan (cts_derived cmap) emptyCCanMap :: CCanMap a -emptyCCanMap = CCanMap { cts_given = Map.empty - , cts_derived = Map.empty, cts_wanted = Map.empty } +emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wanted = emptyUFM } -updCCanMap:: Ord a => (a,CanonicalCt) -> CCanMap a -> CCanMap a +updCCanMap:: Uniquable a => (a,CanonicalCt) -> CCanMap a -> CCanMap a updCCanMap (a,ct) cmap = case cc_flavor ct of - Wanted {} - -> cmap { cts_wanted = Map.insertWith unionBags a this_ct (cts_wanted cmap) } - Given {} - -> cmap { cts_given = Map.insertWith unionBags a this_ct (cts_given cmap) } - Derived {} - -> cmap { cts_derived = Map.insertWith unionBags a this_ct (cts_derived cmap) } - where this_ct = singleCCan ct - -getRelevantCts :: Ord a => a -> CCanMap a -> (CanonicalCts, CCanMap a) + Wanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } + Given {} -> cmap { cts_given = insert_into (cts_given cmap) } + Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } + where + insert_into m = addToUFM_C (flip unionBags) m a (singleCCan ct) + +getRelevantCts :: Uniquable a => a -> CCanMap a -> (CanonicalCts, CCanMap a) -- Gets the relevant constraints and returns the rest of the CCanMap getRelevantCts a cmap - = let relevant = unionManyBags [ Map.findWithDefault emptyCCan a (cts_wanted cmap) - , Map.findWithDefault emptyCCan a (cts_given cmap) - , Map.findWithDefault emptyCCan a (cts_derived cmap) ] - residual_map = cmap { cts_wanted = Map.delete a (cts_wanted cmap) - , cts_given = Map.delete a (cts_given cmap) - , cts_derived = Map.delete a (cts_derived cmap) } + = let relevant = lookup (cts_wanted cmap) `unionBags` + lookup (cts_given cmap) `unionBags` + lookup (cts_derived cmap) + residual_map = cmap { cts_wanted = delFromUFM (cts_wanted cmap) a + , cts_given = delFromUFM (cts_given cmap) a + , cts_derived = delFromUFM (cts_derived cmap) a } in (relevant, residual_map) + where + lookup map = lookupUFM map a `orElse` emptyCCan -extractUnsolvedCMap :: Ord a => CCanMap a -> (CanonicalCts, CCanMap a) +extractUnsolvedCMap :: CCanMap a -> (CanonicalCts, CCanMap a) -- Gets the wanted or derived constraints and returns a residual -- CCanMap with only givens. extractUnsolvedCMap cmap = - let wntd = Map.fold unionBags emptyCCan (cts_wanted cmap) - derd = Map.fold unionBags emptyCCan (cts_derived cmap) + let wntd = foldUFM unionBags emptyCCan (cts_wanted cmap) + derd = foldUFM unionBags emptyCCan (cts_derived cmap) in (wntd `unionBags` derd, - cmap { cts_wanted = Map.empty, cts_derived = Map.empty }) + cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) -- See Note [InertSet invariants] @@ -2111,8 +2110,8 @@ matchClassInst inerts clas tys loc } where givens_for_this_clas :: CanonicalCts - givens_for_this_clas = Map.lookup clas (cts_given (inert_dicts inerts)) - `orElse` emptyBag + givens_for_this_clas = lookupUFM (cts_given (inert_dicts inerts)) clas + `orElse` emptyCCan given_overlap :: TcsUntouchables -> Bool given_overlap untch = anyBag (matchable untch) givens_for_this_clas diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index ef7ecdc64e..627fc02f95 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -42,10 +42,10 @@ module TcMType ( -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, - checkValidInstHead, checkValidInstance, + checkValidInstHead, checkValidInstance, validDerivPred, checkInstTermination, checkValidTypeInst, checkTyFamFreeness, arityErr, - growPredTyVars, growThetaTyVars, validDerivPred, + growPredTyVars, growThetaTyVars, -------------------------------- -- Zonking @@ -1385,6 +1385,29 @@ instTypeErr pp_ty msg nest 2 msg] \end{code} +validDeivPred checks for OK 'deriving' context. See Note [Exotic +derived instance contexts] in TcSimplify. However the predicate is +here because it uses sizeTypes, fvTypes. + +Also check for a bizarre corner case, when the derived instance decl +would look like + instance C a b => D (T a) where ... +Note that 'b' isn't a parameter of T. This gives rise to all sorts of +problems; in particular, it's hard to compare solutions for equality +when finding the fixpoint, and that means the inferContext loop does +not converge. See Trac #5287. + +\begin{code} +validDerivPred :: TyVarSet -> PredType -> Bool +validDerivPred tv_set (ClassP _ tys) + = hasNoDups fvs + && sizeTypes tys == length fvs + && all (`elemVarSet` tv_set) fvs + where + fvs = fvTypes tys +validDerivPred _ _ = False +\end{code} + %************************************************************************ %* * @@ -1464,17 +1487,6 @@ smallerMsg = ptext (sLit "Constraint is no smaller than the instance head") undecidableMsg = ptext (sLit "Use -XUndecidableInstances to permit this") \end{code} -validDeivPred checks for OK 'deriving' context. See Note [Exotic -derived instance contexts] in TcSimplify. However the predicate is -here because it uses sizeTypes, fvTypes. - -\begin{code} -validDerivPred :: PredType -> Bool -validDerivPred (ClassP _ tys) = hasNoDups fvs && sizeTypes tys == length fvs - where fvs = fvTypes tys -validDerivPred _ = False -\end{code} - %************************************************************************ %* * diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 4a4d55634e..cdd614299e 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -121,15 +121,18 @@ tcRnModule hsc_env hsc_src save_rn_syntax = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; - this_mod = case maybe_mod of - Nothing -> mAIN -- 'module M where' is omitted - Just (L _ mod) -> mkModule this_pkg mod } ; - -- The normal case + (this_mod, prel_imp_loc) + = case maybe_mod of + Nothing -- 'module M where' is omitted + -> (mAIN, srcLocSpan (srcSpanStart loc)) + + Just (L mod_loc mod) -- The normal case + -> (mkModule this_pkg mod, mod_loc) } ; initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ do { -- Deal with imports; - tcg_env <- tcRnImports hsc_env this_mod import_decls ; + tcg_env <- tcRnImports hsc_env this_mod prel_imp_loc import_decls ; setGblEnv tcg_env $ do { -- Load the hi-boot interface for this module, if any @@ -199,9 +202,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax %************************************************************************ \begin{code} -tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv -tcRnImports hsc_env this_mod import_decls - = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; +tcRnImports :: HscEnv -> Module + -> SrcSpan -- Location for the implicit prelude import + -> [LImportDecl RdrName] -> TcM TcGblEnv +tcRnImports hsc_env this_mod prel_imp_loc import_decls + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports prel_imp_loc import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) -- Make sure we record the dependencies from the DynFlags in the EPS or we diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 6fb09c569d..1935883cee 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -582,11 +582,7 @@ addMessages (m_warns, m_errs) discardWarnings :: TcRn a -> TcRn a -- Ignore warnings inside the thing inside; -- used to ignore-unused-variable warnings inside derived code --- With -dppr-debug, the effects is switched off, so you can still see --- what warnings derived code would give discardWarnings thing_inside - | opt_PprStyle_Debug = thing_inside - | otherwise = do { errs_var <- newTcRef emptyMessages ; result <- setErrsVar errs_var thing_inside ; (_warns, errs) <- readTcRef errs_var diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index bed09325ac..07493dca45 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -94,6 +94,7 @@ simplifyDeriv orig pred tvs theta ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + skol_set = mkVarSet tvs_skols doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) @@ -106,8 +107,8 @@ simplifyDeriv orig pred tvs theta ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] get_good :: WantedEvVar -> Either PredType WantedEvVar - get_good wev | validDerivPred p = Left p - | otherwise = Right wev + get_good wev | validDerivPred skol_set p = Left p + | otherwise = Right wev where p = evVarOfPred wev ; reportUnsolved (residual_wanted { wc_flat = bad }) diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a825d23b04..e32ca92f96 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -28,7 +28,7 @@ module TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isSigTyVar, isOverlappableTyVar, isTyConableTyVar, - metaTvRef, + isAmbiguousTyVar, metaTvRef, isFlexi, isIndirect, isRuntimeUnkSkol, -------------------------------- @@ -573,7 +573,7 @@ isImmutableTyVar tv | otherwise = True isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, - isMetaTyVar :: TcTyVar -> Bool + isMetaTyVar, isAmbiguousTyVar :: TcTyVar -> Bool isTyConableTyVar tv -- True of a meta-type variable that can be filled in @@ -601,8 +601,20 @@ isOverlappableTyVar tv isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of - MetaTv _ _ -> True - _ -> False + MetaTv {} -> True + _ -> False + +-- isAmbiguousTyVar is used only when reporting type errors +-- It picks out variables that are unbound, namely meta +-- type variables and the RuntimUnk variables created by +-- RtClosureInspect.zonkRTTIType. These are "ambiguous" in +-- the sense that they stand for an as-yet-unknown type +isAmbiguousTyVar tv + = ASSERT2( isTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv {} -> True + RuntimeUnk {} -> True + _ -> False isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv @@ -1197,7 +1209,7 @@ checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- Should work even for recursive newtypes -- eg Manuel had: newtype T = MkT (Ptr T) checkRepTyCon check_tc ty - = go [] ty + = go emptyNameSet ty where go rec_nts ty | Just (tc,tys) <- splitTyConApp_maybe ty diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index a462cc0d35..a162255794 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -62,7 +62,7 @@ module Coercion ( substTyVarBndr, substCoVarBndr, -- ** Lifting - liftCoMatch, liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, + liftCoMatch, liftCoSubstTyVar, liftCoSubstWith, -- ** Comparison coreEqCoercion, coreEqCoercion2, @@ -80,7 +80,7 @@ module Coercion ( #include "HsVersions.h" -import Unify ( MatchEnv(..), ruleMatchTyX, matchList ) +import Unify ( MatchEnv(..), matchList ) import TypeRep import qualified Type import Type hiding( substTy, substTyVarBndr, extendTvSubst ) @@ -90,7 +90,6 @@ import TyCon import Var import VarEnv import VarSet -import UniqFM ( minusUFM ) import Maybes ( orElse ) import Name ( Name, NamedThing(..), nameUnique ) import OccName ( isSymOcc ) @@ -546,7 +545,7 @@ mkTyConAppCo :: TyCon -> [Coercion] -> Coercion mkTyConAppCo tc cos -- Expand type synonyms | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos - = mkAppCos (liftCoSubst (mkTopCvSubst tv_co_prs) rhs_ty) leftover_cos + = mkAppCos (liftCoSubst tv_co_prs rhs_ty) leftover_cos | Just tys <- traverse isReflCo_maybe cos = Refl (mkTyConApp tc tys) -- See Note [Refl invariant] @@ -812,9 +811,6 @@ zipOpenCvSubst vs cos | otherwise = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos) -mkTopCvSubst :: [(Var,Coercion)] -> CvSubst -mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs) - substCoWithTy :: InScopeSet -> TyVar -> Type -> Coercion -> Coercion substCoWithTy in_scope tv ty = substCoWithTys in_scope [tv] [ty] @@ -887,26 +883,33 @@ lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v %************************************************************************ \begin{code} +data LiftCoSubst = LCS InScopeSet LiftCoEnv + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions* + -- That's the whole point of this function! + liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion -liftCoSubstWith tvs cos = liftCoSubst (zipOpenCvSubst tvs cos) +liftCoSubstWith tvs cos ty + = liftCoSubst (zipEqual "liftCoSubstWith" tvs cos) ty + +liftCoSubst :: [(TyVar,Coercion)] -> Type -> Coercion +liftCoSubst prs ty + | null prs = Refl ty + | otherwise = ty_co_subst (LCS (mkInScopeSet (tyCoVarsOfCos (map snd prs))) + (mkVarEnv prs)) ty -- | The \"lifting\" operation which substitutes coercions for type -- variables in a type to produce a coercion. -- -- For the inverse operation, see 'liftCoMatch' -liftCoSubst :: CvSubst -> Type -> Coercion --- The CvSubst maps TyVar -> Type (mainly for cloning foralls) --- TyVar -> Coercion (this is the payload) --- The unusual thing is that the *coercion* substitution maps --- some *type* variables. That's the whole point of this function! -liftCoSubst subst ty | isEmptyCvSubst subst = Refl ty - | otherwise = ty_co_subst subst ty - -ty_co_subst :: CvSubst -> Type -> Coercion +ty_co_subst :: LiftCoSubst -> Type -> Coercion ty_co_subst subst ty = go ty where go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv) + -- A type variable from a non-cloned forall + -- won't be in the substitution go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2) go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2) @@ -915,84 +918,53 @@ ty_co_subst subst ty (subst', v') = liftCoSubstTyVarBndr subst v go (PredTy p) = mkPredCo (go <$> p) -liftCoSubstTyVar :: CvSubst -> TyVar -> Maybe Coercion -liftCoSubstTyVar subst@(CvSubst _ tenv cenv) tv - = case (lookupVarEnv tenv tv, lookupVarEnv cenv tv) of - (Nothing, Nothing) -> Nothing - (Just ty, Nothing) -> Just (Refl ty) - (Nothing, Just co) -> Just co - (Just {}, Just {}) -> pprPanic "ty_co_subst" (ppr tv $$ ppr subst) - -liftCoSubstTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) -liftCoSubstTyVarBndr (CvSubst in_scope tenv cenv) old_var - = (CvSubst (in_scope `extendInScopeSet` new_var) - new_tenv - (delVarEnv cenv old_var) -- See Note [Lifting substitutions] - , new_var) +liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv + +liftCoSubstTyVarBndr :: LiftCoSubst -> TyVar -> (LiftCoSubst, TyVar) +liftCoSubstTyVarBndr (LCS in_scope cenv) old_var + = (LCS (in_scope `extendInScopeSet` new_var) new_cenv, new_var) where - new_tenv | no_change = delVarEnv tenv old_var - | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (Refl (TyVarTy new_var)) no_change = new_var == old_var new_var = uniqAway in_scope old_var \end{code} -Note [Lifting substitutions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider liftCoSubstWith [a] [co] (a, forall a. a) -Then we want to substitute for the free 'a', but obviously not for -the bound 'a'. hence the (delVarEnv cent old_var) in liftCoSubstTyVarBndr. - -This also why we need a full CvSubst when doing lifting substitutions. - \begin{code} -- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if -- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@. -- That is, it matches a type against a coercion of the same -- "shape", and returns a lifting substitution which could have been -- used to produce the given coercion from the given type. -liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe CvSubst +liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe LiftCoSubst liftCoMatch tmpls ty co - = case ty_co_match menv (emptyVarEnv, emptyVarEnv) ty co of - Just (tv_env, cv_env) -> Just (CvSubst in_scope tv_env cv_env) - Nothing -> Nothing + = case ty_co_match menv emptyVarEnv ty co of + Just cenv -> Just (LCS in_scope cenv) + Nothing -> Nothing where menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) -- Like tcMatchTy, assume all the interesting variables -- in ty are in tmpls -type TyCoSubstEnv = (TvSubstEnv, CvSubstEnv) - -- Used locally inside ty_co_match only - -- | 'ty_co_match' does all the actual work for 'liftCoMatch'. -ty_co_match :: MatchEnv -> TyCoSubstEnv -> Type -> Coercion -> Maybe TyCoSubstEnv -ty_co_match menv subst ty co | Just ty' <- coreView ty = ty_co_match menv subst ty' co - - -- Deal with the Refl case by delegating to type matching -ty_co_match menv (tenv, cenv) ty co - | Just ty' <- isReflCo_maybe co - = case ruleMatchTyX ty_menv tenv ty ty' of - Just tenv' -> Just (tenv', cenv) - Nothing -> Nothing - where - ty_menv = menv { me_tmpls = me_tmpls menv `minusUFM` cenv } - -- Remove from the template set any variables already bound to non-refl coercions +ty_co_match :: MatchEnv -> LiftCoEnv -> Type -> Coercion -> Maybe LiftCoEnv +ty_co_match menv subst ty co + | Just ty' <- coreView ty = ty_co_match menv subst ty' co -- Match a type variable against a non-refl coercion -ty_co_match menv subst@(tenv, cenv) (TyVarTy tv1) co - | Just {} <- lookupVarEnv tenv tv1' -- tv1' is already bound to (Refl ty) - = Nothing -- The coercion 'co' is not Refl - +ty_co_match menv cenv (TyVarTy tv1) co | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1 = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co - then Just subst + then Just cenv else Nothing -- no match since tv1 matches two different coercions | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co)) then Nothing -- occurs check failed - else return (tenv, extendVarEnv cenv tv1' co) + else return (extendVarEnv cenv tv1' co) -- BAY: I don't think we need to do any kind matching here yet -- (compare 'match'), but we probably will when moving to SHE. @@ -1021,10 +993,19 @@ ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) where menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } -ty_co_match _ _ _ _ = Nothing +ty_co_match menv subst ty co + | Just co' <- pushRefl co = ty_co_match menv subst ty co' + | otherwise = Nothing -ty_co_matches :: MatchEnv -> TyCoSubstEnv -> [Type] -> [Coercion] -> Maybe TyCoSubstEnv +ty_co_matches :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEnv ty_co_matches menv = matchList (ty_co_match menv) + +pushRefl :: Coercion -> Maybe Coercion +pushRefl (Refl (AppTy ty1 ty2)) = Just (AppCo (Refl ty1) (Refl ty2)) +pushRefl (Refl (FunTy ty1 ty2)) = Just (TyConAppCo funTyCon [Refl ty1, Refl ty2]) +pushRefl (Refl (TyConApp tc tys)) = Just (TyConAppCo tc (map Refl tys)) +pushRefl (Refl (ForAllTy tv ty)) = Just (ForAllCo tv (Refl ty)) +pushRefl _ = Nothing \end{code} %************************************************************************ diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index d6784b9020..5d0eb58f4e 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -239,15 +239,17 @@ opt_trans_rule is co1 co2@(TyConAppCo tc cos2) opt_trans_rule is co1 co2 | Just (tv1,r1) <- splitForAllCo_maybe co1 , Just (tv2,r2) <- etaForAllCo_maybe co2 - , let r2' = substCoWithTy is tv2 (mkTyVarTy tv1) r2 + , let r2' = substCoWithTy is' tv2 (mkTyVarTy tv1) r2 + is' = is `extendInScopeSet` tv1 = fireTransRule "EtaAllL" co1 co2 $ - mkForAllCo tv1 (opt_trans2 (extendInScopeSet is tv1) r1 r2') + mkForAllCo tv1 (opt_trans2 is' r1 r2') | Just (tv2,r2) <- splitForAllCo_maybe co2 , Just (tv1,r1) <- etaForAllCo_maybe co1 - , let r1' = substCoWithTy is tv1 (mkTyVarTy tv2) r1 + , let r1' = substCoWithTy is' tv1 (mkTyVarTy tv2) r1 + is' = is `extendInScopeSet` tv2 = fireTransRule "EtaAllR" co1 co2 $ - mkForAllCo tv1 (opt_trans2 (extendInScopeSet is tv2) r1' r2) + mkForAllCo tv1 (opt_trans2 is' r1' r2) -- Push transitivity inside axioms opt_trans_rule is co1 co2 diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 58d29a0515..bf595ef10e 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -93,7 +93,7 @@ module Type ( -- * Other views onto Types coreView, tcView, - repType, + repType, deepRepType, -- * Type representation for the code generator PrimRep(..), @@ -148,6 +148,7 @@ import TysPrim import Unique ( Unique ) import BasicTypes ( IPName ) import Name ( Name ) +import NameSet import StaticFlags import Util import Outputable @@ -567,36 +568,58 @@ newtype at outermost level; and bale out if we see it again. -- -- It's useful in the back end of the compiler. repType :: Type -> Type --- Only applied to types of kind *; hence tycons are saturated repType ty - = go [] ty + = go emptyNameSet ty where - go :: [TyCon] -> Type -> Type - go rec_nts (ForAllTy _ ty) -- Look through foralls + go :: NameSet -> Type -> Type + go rec_nts ty -- Expand predicates and synonyms + | Just ty' <- coreView ty + = go rec_nts ty' + + go rec_nts (ForAllTy _ ty) -- Drop foralls = go rec_nts ty - go rec_nts (PredTy p) -- Expand predicates - = go rec_nts (predTypeRep p) + go rec_nts (TyConApp tc tys) -- Expand newtypes + | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys + = go rec_nts' ty' + + go _ ty = ty + +deepRepType :: Type -> Type +-- Same as repType, but looks recursively +deepRepType ty + = go emptyNameSet ty + where + go rec_nts ty -- Expand predicates and synonyms + | Just ty' <- coreView ty + = go rec_nts ty' - go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms - | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys - = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + go rec_nts (ForAllTy _ ty) -- Drop foralls + = go rec_nts ty + go rec_nts (TyConApp tc tys) -- Expand newtypes | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys = go rec_nts' ty' - go _ ty = ty + -- Apply recursively; this is the "deep" bit + go rec_nts (TyConApp tc tys) = mkTyConApp tc (map (go rec_nts) tys) + go rec_nts (AppTy ty1 ty2) = mkAppTy (go rec_nts ty1) (go rec_nts ty2) + go rec_nts (FunTy ty1 ty2) = FunTy (go rec_nts ty1) (go rec_nts ty2) + go _ ty = ty -carefullySplitNewType_maybe :: [TyCon] -> TyCon -> [Type] -> Maybe ([TyCon],Type) +carefullySplitNewType_maybe :: NameSet -> TyCon -> [Type] -> Maybe (NameSet,Type) -- Return the representation of a newtype, unless -- we've seen it already: see Note [Expanding newtypes] +-- Assumes the newtype is saturated carefullySplitNewType_maybe rec_nts tc tys | isNewTyCon tc - , not (tc `elem` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys) - | otherwise = Nothing + , tys `lengthAtLeast` tyConArity tc + , not (tc_name `elemNameSet` rec_nts) = Just (rec_nts', newTyConInstRhs tc tys) + | otherwise = Nothing where - rec_nts' | isRecursiveTyCon tc = tc:rec_nts + tc_name = tyConName tc + rec_nts' | isRecursiveTyCon tc = addOneToNameSet rec_nts tc_name | otherwise = rec_nts @@ -1266,7 +1289,7 @@ getTvInScope (TvSubst in_scope _) = in_scope isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope -notElemTvSubst :: TyCoVar -> TvSubst -> Bool +notElemTvSubst :: CoVar -> TvSubst -> Bool notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index db41403a4b..e0a567055a 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -150,7 +150,7 @@ data Type -- See Note [Equality-constrained types] | ForAllTy - TyCoVar -- Type variable + TyVar -- Type variable Type -- ^ A polymorphic type | PredTy @@ -301,10 +301,10 @@ isCoercionKind _ = False %************************************************************************ \begin{code} -tyVarsOfPred :: PredType -> TyCoVarSet +tyVarsOfPred :: PredType -> TyVarSet tyVarsOfPred = varsOfPred tyVarsOfType -tyVarsOfTheta :: ThetaType -> TyCoVarSet +tyVarsOfTheta :: ThetaType -> TyVarSet tyVarsOfTheta = varsOfTheta tyVarsOfType tyVarsOfType :: Type -> VarSet diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index ec65cded94..b9d2da37d2 100644 --- a/compiler/utils/Digraph.lhs +++ b/compiler/utils/Digraph.lhs @@ -3,10 +3,11 @@ % \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, - SCC(..), flattenSCC, flattenSCCs, + SCC(..), Node, flattenSCC, flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, reachableG, transposeG, @@ -14,6 +15,8 @@ module Digraph( vertexGroupsG, emptyG, componentsG, + findCycle, + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -37,7 +40,7 @@ module Digraph( ------------------------------------------------------------------------------ -import Util ( sortLe ) +import Util ( sortLe, minWith, count ) import Outputable import Maybes ( expectJust ) import MonadUtils ( allM ) @@ -51,6 +54,8 @@ import Data.Maybe import Data.Array import Data.List ( (\\) ) import Data.Array.ST +import qualified Data.Map as Map +import qualified Data.Set as Set \end{code} %************************************************************************ @@ -78,6 +83,13 @@ data Graph node = Graph { data Edge node = Edge node node +type Node key payload = (payload, key, [key]) + -- The payload is user data, just carried around in this module + -- The keys are ordered + -- The [key] are the dependencies of the node; + -- it's ok to have extra keys in the dependencies that + -- are not the key of any Node in the graph + emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -101,10 +113,10 @@ graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vert graphFromEdgedVertices :: Ord key - => [(node, key, [key])] -- The graph; its ok for the + => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored - -> Graph (node, key, [key]) + -> Graph (Node key payload) graphFromEdgedVertices [] = emptyGraph graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor) where key_extractor (_, k, _) = k @@ -147,6 +159,63 @@ reduceNodesIntoVertices nodes key_extractor = (bounds, (!) vertex_map, key_verte %************************************************************************ \begin{code} +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) deps) + | node@(_,_,deps) <- graph ]) + (root_payload,root_key,root_deps) = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((payload,key,deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] +\end{code} + +%************************************************************************ +%* * +%* SCC +%* * +%************************************************************************ + +\begin{code} data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] @@ -194,8 +263,8 @@ stronglyConnCompG (Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } -- The following two versions are provided for backwards compatability: stronglyConnCompFromEdgedVertices :: Ord key - => [(node, key, [key])] - -> [SCC node] + => [Node key payload] + -> [SCC payload] stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR where get_node (n, _, _) = n @@ -203,8 +272,8 @@ stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEd -- the (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompFromEdgedVerticesR :: Ord key - => [(node, key, [key])] - -> [SCC (node, key, [key])] + => [Node key payload] + -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices \end{code} diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index 8c487f665e..735bf23628 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -9,9 +9,10 @@ -- ---------------------------------------------------------------------------- module Fingerprint ( - Fingerprint(..), fingerprint0, + Fingerprint(..), fingerprint0, readHexFingerprint, - fingerprintData + fingerprintData, + fingerprintString ) where #include "md5.h" @@ -28,8 +29,10 @@ import GHC.Fingerprint ##endif ##if __GLASGOW_HASKELL__ < 701 +import Data.Char import Foreign import Foreign.C +import GHC.IO (unsafeDupablePerformIO) -- Using 128-bit MD5 fingerprints for now. @@ -63,6 +66,19 @@ fingerprintData buf len = do c_MD5Final pdigest pctxt peekFingerprint (castPtr pdigest) +-- This is duplicated in libraries/base/GHC/Fingerprint.hs +fingerprintString :: String -> Fingerprint +fingerprintString str = unsafeDupablePerformIO $ + withArrayLen word8s $ \len p -> + fingerprintData p len + where word8s = concatMap f str + f c = let w32 :: Word32 + w32 = fromIntegral (ord c) + in [fromIntegral (w32 `shiftR` 24), + fromIntegral (w32 `shiftR` 16), + fromIntegral (w32 `shiftR` 8), + fromIntegral w32] + data MD5Context foreign import ccall unsafe "MD5Init" diff --git a/compiler/utils/FiniteMap.lhs b/compiler/utils/FiniteMap.lhs index 3acadf137c..94d1eef94e 100644 --- a/compiler/utils/FiniteMap.lhs +++ b/compiler/utils/FiniteMap.lhs @@ -1,3 +1,4 @@ +Some extra functions to extend Data.Map \begin{code} module FiniteMap ( diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 7f8a3a67ff..be6a9cf84d 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -599,7 +599,10 @@ keyword = bold class Outputable a where ppr :: a -> SDoc pprPrec :: Rational -> a -> SDoc - + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals + ppr = pprPrec 0 pprPrec _ = ppr diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 7cbc3dbcfb..0cd9235cad 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -36,7 +36,7 @@ module UniqFM ( addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, - adjustUFM, + adjustUFM, alterUFM, adjustUFM_Directly, delFromUFM, delFromUFM_Directly, @@ -108,6 +108,12 @@ addToUFM_Acc :: Uniquable key => -> key -> elt -- new -> UniqFM elts -- result +alterUFM :: Uniquable key => + (Maybe elt -> Maybe elt) -- How to adjust + -> UniqFM elt -- old + -> key -- new + -> UniqFM elt -- result + addListToUFM_C :: Uniquable key => (elt -> elt -> elt) -> UniqFM elt -> [(key,elt)] -> UniqFM elt @@ -182,7 +188,8 @@ listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM -addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) addListToUFM = foldl (\m (k, v) -> addToUFM m k v) addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v) addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index dc4f32ec5e..c5f1c0c2ed 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -41,7 +41,7 @@ module Util ( nTimes, -- * Sorting - sortLe, sortWith, on, + sortLe, sortWith, minWith, on, -- * Comparisons isEqual, eqListBy, @@ -74,7 +74,7 @@ module Util ( doesDirNameExist, modificationTimeIfExists, - global, consIORef, globalMVar, globalEmptyMVar, + global, consIORef, globalM, -- * Filenames and paths Suffix, @@ -99,7 +99,6 @@ import Data.Data import Data.IORef ( IORef, newIORef, atomicModifyIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) -import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar ) #ifdef DEBUG import FastTypes @@ -543,6 +542,10 @@ sortWith get_key xs = sortLe le xs where x `le` y = get_key x < get_key y +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + on :: (a -> a -> c) -> (b -> a) -> b -> b -> c on cmp sel = \x y -> sel x `cmp` sel y @@ -853,11 +856,8 @@ consIORef var x = do \end{code} \begin{code} -globalMVar :: a -> MVar a -globalMVar a = unsafePerformIO (newMVar a) - -globalEmptyMVar :: MVar a -globalEmptyMVar = unsafePerformIO newEmptyMVar +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) \end{code} Module names: diff --git a/configure.ac b/configure.ac index 2ab11c9914..74c190b97d 100644 --- a/configure.ac +++ b/configure.ac @@ -403,25 +403,6 @@ then fi fi -dnl ** Which gcc to use? -dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) -export CC -WhatGccIsCalled="$CC" -AC_SUBST(WhatGccIsCalled) - -dnl ** Which ld to use? -dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([LD], [ld]) -LdCmd="$LD" -AC_SUBST([LdCmd]) - -dnl ** Which nm to use? -dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([NM], [nm]) -NmCmd="$NM" -AC_SUBST([NmCmd]) - SplitObjsBroken=NO if test "$TargetOS_CPP" = "darwin" then @@ -457,6 +438,33 @@ changequote([, ])dnl fi AC_SUBST([SplitObjsBroken]) +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +if test "$TargetOS_CPP" = "darwin" && + test "$XCodeVersion1" -ge 4 +then + # From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy backend (instead of the LLVM + # backend) + FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2]) +else + FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) +fi +export CC +WhatGccIsCalled="$CC" +AC_SUBST(WhatGccIsCalled) + +dnl ** Which ld to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([LD], [ld]) +LdCmd="$LD" +AC_SUBST([LdCmd]) + +dnl ** Which nm to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([NM], [nm]) +NmCmd="$NM" +AC_SUBST([NmCmd]) + dnl ** Mac OS X: explicit deployment target dnl -------------------------------------------------------------- AC_ARG_WITH([macosx-deployment-target], diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index facba914c2..a37800458b 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -50,7 +50,36 @@ AC_PATH_PROG(SedCmd,gsed sed,sed) # dnl ** How to invoke gcc/cpp ** # -FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) +if test "$TargetOS_CPP" = "darwin" +then + AC_MSG_CHECKING(XCode version) + XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` + # Old XCode versions don't actually give the XCode version + if test "$XCodeVersion" = "" + then + AC_MSG_RESULT(not found (too old?)) + else + AC_MSG_RESULT($XCodeVersion) + XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` +changequote(, )dnl + XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` +changequote([, ])dnl + AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1) + AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2) + fi +fi + +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +if test "$TargetOS_CPP" = "darwin" && + test "$XCodeVersion1" -ge 4 +then + # From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy backend (instead of the LLVM + # backend) + FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2]) +else + FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) +fi export CC WhatGccIsCalled="$CC" AC_SUBST(WhatGccIsCalled) diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index ea90a631a1..32581875d8 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1382,13 +1382,15 @@ D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] >>= \(Qv,Rv) -> D -- Transform comprehensions D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ] -D[ e | Q then f by b, R ] = f b D[ Qv | Q ] >>= \Qv -> D[ e | R ] +D[ e | Q then f by b, R ] = f (\Qv -> b) D[ Qv | Q ] >>= \Qv -> D[ e | R ] D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys -> case (fmap selQv1 ys, ..., fmap selQvn ys) of Qv -> D[ e | R ] -D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys -> +D[ e | Q then group by b, R ] = D[ e | Q then group by b using mgroupWith, R ] + +D[ e | Q then group by b using f, R ] = f (\Qv -> b) D[ Qv | Q ] >>= \ys -> case (fmap selQv1 ys, ..., fmap selQvn ys) of Qv -> D[ e | R ] @@ -5052,7 +5054,7 @@ type instance F t1 .. tn = t </sect4> </sect3> - <sect3 id-="equality-constraints"> + <sect3 id="equality-constraints"> <title>Equality constraints</title> <para> Type context can include equality constraints of the form <literal>t1 ~ @@ -5094,7 +5096,7 @@ class (F a ~ b) => C a b where </para> </sect3> - <sect3 id-="ty-fams-in-instances"> + <sect3 id="ty-fams-in-instances"> <title>Type families and instance declarations</title> <para>Type families require us to extend the rules for the form of instance heads, which are given @@ -7958,8 +7960,8 @@ itself, so an INLINE pragma is always ignored.</para> {-# INLINE returnUs #-} </programlisting> - <para>See also the <literal>NOINLINE</literal> (<xref linkend="inlinable-pragma"/>) - and <literal>INLINABLE</literal> (<xref linkend="noinline-pragma"/>) + <para>See also the <literal>NOINLINE</literal> (<xref linkend="noinline-pragma"/>) + and <literal>INLINABLE</literal> (<xref linkend="inlinable-pragma"/>) pragmas.</para> <para>Note: the HBC compiler doesn't like <literal>INLINE</literal> pragmas, @@ -9165,30 +9167,16 @@ Using a combination of <option>-XDeriveGeneric</option> <option>-XDefaultSignatures</option> (<xref linkend="class-default-signatures"/>), you can easily do datatype-generic programming using the <literal>GHC.Generics</literal> framework. This section -gives a very brief overview of how to do it. For more detail please refer to the -<ulink url="http://www.haskell.org/haskellwiki/Generics">HaskellWiki page</ulink> -or the original paper: +gives a very brief overview of how to do it. </para> -<itemizedlist> -<listitem> <para> -Jos� Pedro Magalh�es, Atze Dijkstra, Johan Jeuring, and Andres L�h. -<ulink url="http://dreixel.net/research/pdf/gdmh.pdf"> - A generic deriving mechanism for Haskell</ulink>. -<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle> -(Haskell'2010), pp. 37-48, ACM, 2010. +Generic programming support in GHC allows defining classes with methods that +do not need a user specification when instantiating: the method body is +automatically derived by GHC. This is similar to what happens for standard +classes such as <literal>Read</literal> and <literal>Show</literal>, for +instance, but now for user-defined classes. </para> -</listitem> -</itemizedlist> - -<emphasis>Note</emphasis>: the current support for generic programming in GHC -is preliminary. In particular, we only allow deriving instances for the -<literal>Generic</literal> class. Support for deriving -<literal>Generic1</literal> (and thus enabling generic functions of kind -<literal>* -> *</literal> such as <literal>fmap</literal>) will come at a -later stage. - <sect2> <title>Deriving representations</title> @@ -9196,7 +9184,7 @@ later stage. <para> The first thing we need is generic representations. The <literal>GHC.Generics</literal> module defines a couple of primitive types -that can be used to represent most Haskell datatypes: +that are used to represent Haskell datatypes: <programlisting> -- | Unit: used for constructors without arguments @@ -9216,7 +9204,28 @@ data (:+:) f g p = L1 (f p) | R1 (g p) infixr 6 :*: data (:*:) f g p = f p :*: g p </programlisting> +</para> + +<para> +The <literal>Generic</literal> class mediates between user-defined datatypes +and their internal representation as a sum-of-products: + +<programlisting> +class Generic a where + -- Encode the representation of a user datatype + type Rep a :: * -> * + -- Convert from the datatype to its representation + from :: a -> (Rep a) x + -- Convert from the representation to the datatype + to :: (Rep a) x -> a +</programlisting> +Instances of this class can be derived by GHC with the +<option>-XDeriveGeneric</option> (<xref linkend="deriving-typeable"/>), and are +necessary to be able to define generic instances automatically. +</para> + +<para> For example, a user-defined datatype of trees <literal>data UserTree a = Node a (UserTree a) (UserTree a) | Leaf</literal> gets the following representation: @@ -9258,6 +9267,7 @@ This representation is generated automatically if a <link linkend="stand-alone-deriving">Standalone deriving</link> can also be used. </para> + </sect2> <sect2> @@ -9277,7 +9287,7 @@ instance GSerialize U1 where gput U1 = [] instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where - gput (a :*: b) = gput a ++ gput b + gput (x :*: y) = gput x ++ gput y instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where gput (L1 x) = O : gput x @@ -9286,7 +9296,7 @@ instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where instance (GSerialize a) => GSerialize (M1 i c a) where gput (M1 x) = gput x -instance (Serialize a) => GSerialize (K1 i c a) where +instance (Serialize a) => GSerialize (K1 i a) where gput (K1 x) = put x </programlisting> @@ -9323,6 +9333,36 @@ generic implementation of serialization. </para> </sect2> + +<sect2> +<title>More information</title> + +<para> +For more detail please refer to the +<ulink url="http://www.haskell.org/haskellwiki/Generics">HaskellWiki page</ulink> +or the original paper: +</para> + +<itemizedlist> +<listitem> +<para> +Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. +<ulink url="http://dreixel.net/research/pdf/gdmh.pdf"> + A generic deriving mechanism for Haskell</ulink>. +<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle> +(Haskell'2010), pp. 37-48, ACM, 2010. +</para> +</listitem> +</itemizedlist> + +<emphasis>Note</emphasis>: the current support for generic programming in GHC +is preliminary. In particular, we only allow deriving instances for the +<literal>Generic</literal> class. Support for deriving +<literal>Generic1</literal> (and thus enabling generic functions of kind +<literal>* -> *</literal> such as <literal>fmap</literal>) will come at a +later stage. +</sect2> + </sect1> @@ -889,9 +889,11 @@ install_packages: libffi/package.conf.install rts/package.conf.install "$(INSTALLED_GHC_PKG_REAL)" \ --global-conf "$(INSTALLED_PACKAGE_CONF)" hide $p)) # when we install the packages above, ghc-pkg obeys umask when creating -# package.cache, but for everything else we specify the permissions. We -# therefore now fix the permissions of package.cache - $(CREATE_DATA) '$(INSTALLED_PACKAGE_CONF)/package.cache' +# the package.conf files, but for everything else we specify the +# permissions. We therefore now fix the permissions of package.cache. +# This means "sudo make install" does the right thing even if it runs +# with an 077 umask. + for f in '$(INSTALLED_PACKAGE_CONF)'/*; do $(CREATE_DATA) "$$f"; done # ----------------------------------------------------------------------------- # Binary distributions diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h index 3c6e6f6e26..e57ffd23cf 100644 --- a/includes/rts/storage/GC.h +++ b/includes/rts/storage/GC.h @@ -181,6 +181,50 @@ void setKeepCAFs (void); Stats -------------------------------------------------------------------------- */ +typedef struct _GCStats { + StgWord64 bytes_allocated; + StgWord64 num_gcs; + StgWord64 num_byte_usage_samples; + StgWord64 max_bytes_used; + StgWord64 cumulative_bytes_used; + StgWord64 bytes_copied; + StgWord64 current_bytes_used; + StgWord64 current_bytes_slop; + StgWord64 max_bytes_slop; + StgWord64 peak_megabytes_allocated; + StgWord64 par_avg_bytes_copied; + StgWord64 par_max_bytes_copied; + StgDouble mutator_cpu_seconds; + StgDouble mutator_wall_seconds; + StgDouble gc_cpu_seconds; + StgDouble gc_wall_seconds; +} GCStats; +void getGCStats (GCStats *s); + +// These don't change over execution, so do them elsewhere +// StgDouble init_cpu_seconds; +// StgDouble init_wall_seconds; + +typedef struct _ParGCStats { + StgWord64 avg_copied; + StgWord64 max_copied; +} ParGCStats; +void getParGCStats (ParGCStats *s); + +/* +typedef struct _TaskStats { + StgWord64 mut_time; + StgWord64 mut_etime; + StgWord64 gc_time; + StgWord64 gc_etime; +} TaskStats; +// would need to allocate arbitrarily large amount of memory +// because it's a linked list of results +void getTaskStats (TaskStats **s); +// Need to stuff SparkCounters in a public header file... +void getSparkStats (SparkCounters *s); +*/ + // Returns the total number of bytes allocated since the start of the program. HsInt64 getAllocations (void); diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 9f06417ea8..f4c5162607 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -54,6 +54,11 @@ endif ###################################################################### # Disable some warnings in packages we use +# Cabal doesn't promise to be warning-free +utils/ghc-cabal_dist_EXTRA_HC_OPTS += -w +libraries/Cabal/cabal_dist-boot_EXTRA_HC_OPTS += -w +libraries/Cabal/cabal_dist-install_EXTRA_HC_OPTS += -w + # Temporarily turn off incomplete-pattern warnings for containers libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-incomplete-patterns diff --git a/rts/Linker.c b/rts/Linker.c index 781f705536..f5b90d41b9 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -793,6 +793,7 @@ typedef struct _RtsSymbolVal { SymI_HasProto(getOrSetGHCConcWindowsProddingStore) \ SymI_HasProto(getOrSetSystemEventThreadEventManagerStore) \ SymI_HasProto(getOrSetSystemEventThreadIOManagerThreadStore) \ + SymI_HasProto(getGCStats) \ SymI_HasProto(genSymZh) \ SymI_HasProto(genericRaise) \ SymI_HasProto(getProgArgv) \ diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index e88d7042ed..9d95b4ccc0 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -1071,14 +1071,14 @@ heapCensusChain( Census *census, bdescr *bd ) } void -heapCensus( void ) +heapCensus( Ticks t ) { nat g, n; Census *census; gen_workspace *ws; census = &censuses[era]; - census->time = mut_user_time(); + census->time = mut_user_time_until(t); // calculate retainer sets if necessary #ifdef PROFILING diff --git a/rts/ProfHeap.h b/rts/ProfHeap.h index c4a92e200b..cf09c59231 100644 --- a/rts/ProfHeap.h +++ b/rts/ProfHeap.h @@ -9,9 +9,11 @@ #ifndef PROFHEAP_H #define PROFHEAP_H +#include "GetTime.h" // for Ticks + #include "BeginPrivate.h" -void heapCensus (void); +void heapCensus (Ticks t); nat initHeapProfiling (void); void endHeapProfiling (void); rtsBool strMatchesSelector (char* str, char* sel); diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index fcc1f49a36..eda327dd50 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -236,6 +236,7 @@ usage_text[] = { " -I<sec> Perform full GC after <sec> idle time (default: 0.3, 0 == off)", #endif "", +" -T Collect GC statistics (useful for in-program statistics access)" " -t[<file>] One-line GC statistics (if <file> omitted, uses stderr)", " -s[<file>] Summary GC statistics (if <file> omitted, uses stderr)", " -S[<file>] Detailed GC statistics (if <file> omitted, uses stderr)", @@ -841,6 +842,10 @@ error = rtsTrue; } break; + case 'T': + RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS; + break; /* Don't initialize statistics file. */ + case 'S': RtsFlags.GcFlags.giveStats = VERBOSE_GC_STATS; goto stats; diff --git a/rts/Stats.c b/rts/Stats.c index 7c02b5a7d9..ebe239f06e 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -56,9 +56,12 @@ static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time #define PROF_VAL(x) 0 #endif -static lnat max_residency = 0; // in words; for stats only -static lnat avg_residency = 0; +// current = current as of last GC +static lnat current_residency = 0; // in words; for stats only +static lnat max_residency = 0; +static lnat cumulative_residency = 0; static lnat residency_samples = 0; // for stats only +static lnat current_slop = 0; static lnat max_slop = 0; static lnat GC_end_faults = 0; @@ -84,11 +87,17 @@ Ticks stat_getElapsedTime(void) ------------------------------------------------------------------------ */ double +mut_user_time_until( Ticks t ) +{ + return TICK_TO_DBL(t - GC_tot_cpu - PROF_VAL(RP_tot_time)); +} + +double mut_user_time( void ) { Ticks cpu; cpu = getProcessCPUTime(); - return TICK_TO_DBL(cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time)); + return mut_user_time_until(cpu); } #ifdef PROFILING @@ -99,13 +108,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 - HC_tot_time); + return TICK_TO_DBL(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 - HC_tot_time); + return TICK_TO_DBL(HC_start_time - GC_tot_cpu - RP_tot_time); } #endif /* PROFILING */ @@ -145,7 +154,7 @@ initStats0(void) #endif max_residency = 0; - avg_residency = 0; + cumulative_residency = 0; residency_samples = 0; max_slop = 0; @@ -361,8 +370,9 @@ stat_endGC (gc_thread *gct, if (live > max_residency) { max_residency = live; } + current_residency = live; residency_samples++; - avg_residency += live; + cumulative_residency += live; } if (slop > max_slop) max_slop = slop; @@ -504,6 +514,9 @@ 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; } + void stat_exit(int alloc) { @@ -547,8 +560,8 @@ stat_exit(int alloc) gc_elapsed += GC_coll_elapsed[i]; } - init_cpu = end_init_cpu - start_init_cpu; - init_elapsed = end_init_elapsed - start_init_elapsed; + init_cpu = get_init_cpu(); + init_elapsed = get_init_elapsed(); exit_cpu = end_exit_cpu - start_exit_cpu; exit_elapsed = end_exit_elapsed - start_exit_elapsed; @@ -739,7 +752,7 @@ stat_exit(int alloc) statsPrintf(fmt2, total_collections, residency_samples == 0 ? 0 : - avg_residency*sizeof(W_)/residency_samples, + cumulative_residency*sizeof(W_)/residency_samples, max_residency*sizeof(W_), residency_samples, (unsigned long)(peak_mblocks_allocated * MBLOCK_SIZE / (1024L * 1024L)), @@ -838,6 +851,70 @@ statDescribeGens(void) extern HsInt64 getAllocations( void ) { return (HsInt64)GC_tot_alloc * sizeof(W_); } +/* EZY: I'm not convinced I got all the casting right. */ + +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; + + getProcessTimes(¤t_cpu, ¤t_elapsed); + + /* EZY: static inline'ify these */ + for (g = 0; g < RtsFlags.GcFlags.generations; g++) + total_collections += generations[g].collections; + + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + gc_cpu += GC_coll_cpu[g]; + gc_elapsed += GC_coll_elapsed[g]; + } + + s->bytes_allocated = GC_tot_alloc*(StgWord64)sizeof(W_); + s->num_gcs = total_collections; + s->num_byte_usage_samples = residency_samples; + s->max_bytes_used = max_residency*sizeof(W_); + s->cumulative_bytes_used = cumulative_residency*(StgWord64)sizeof(W_); + s->peak_megabytes_allocated = (StgWord64)(peak_mblocks_allocated * MBLOCK_SIZE / (1024L * 1024L)); + s->bytes_copied = GC_tot_copied*(StgWord64)sizeof(W_); + s->max_bytes_slop = max_slop*(StgWord64)sizeof(W_); + 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->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->par_avg_bytes_copied = GC_par_avg_copied*(StgWord64)sizeof(W_); + s->par_max_bytes_copied = GC_par_max_copied*(StgWord64)sizeof(W_); +} +// extern void getTaskStats( TaskStats **s ) {} +#if 0 +extern void getSparkStats( SparkCounters *s ) { + nat i; + s->created = 0; + s->dud = 0; + s->overflowed = 0; + s->converted = 0; + s->gcd = 0; + s->fizzled = 0; + for (i = 0; i < n_capabilities; i++) { + s->created += capabilities[i].spark_stats.created; + s->dud += capabilities[i].spark_stats.dud; + s->overflowed+= capabilities[i].spark_stats.overflowed; + s->converted += capabilities[i].spark_stats.converted; + s->gcd += capabilities[i].spark_stats.gcd; + s->fizzled += capabilities[i].spark_stats.fizzled; + } +} +#endif + /* ----------------------------------------------------------------------------- Dumping stuff in the stats file, or via the debug message interface -------------------------------------------------------------------------- */ diff --git a/rts/Stats.h b/rts/Stats.h index 0c5178723c..f0060bdf4a 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_during_GC(void); +double mut_user_time_until(Ticks t); double mut_user_time(void); #ifdef PROFILING diff --git a/rts/Trace.h b/rts/Trace.h index 40a4522a26..f896c0e7a2 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -512,7 +512,6 @@ INLINE_HEADER void traceSparkCounters(Capability *cap STG_UNUSED) if (RTS_UNLIKELY(TRACE_spark_sampled)) { traceSparkCounters_(cap, cap->spark_stats, sparkPoolSize(cap->sparks)); } -#endif dtraceSparkCounters((EventCapNo)cap->no, cap->spark_stats.created, cap->spark_stats.dud, @@ -521,6 +520,7 @@ INLINE_HEADER void traceSparkCounters(Capability *cap STG_UNUSED) cap->spark_stats.gcd, cap->spark_stats.fizzled, sparkPoolSize(cap->sparks)); +#endif } INLINE_HEADER void traceEventSparkCreate(Capability *cap STG_UNUSED) diff --git a/rts/hooks/OnExit.c b/rts/hooks/OnExit.c index e8019c046b..30764acba2 100644 --- a/rts/hooks/OnExit.c +++ b/rts/hooks/OnExit.c @@ -15,6 +15,6 @@ */ void -OnExitHook () +OnExitHook (void) { } diff --git a/rts/posix/OSThreads.c b/rts/posix/OSThreads.c index 29cb23eb6d..cc3baeb1bb 100644 --- a/rts/posix/OSThreads.c +++ b/rts/posix/OSThreads.c @@ -101,14 +101,14 @@ waitCondition ( Condition* pCond, Mutex* pMut ) } void -yieldThread() +yieldThread(void) { sched_yield(); return; } void -shutdownThread() +shutdownThread(void) { pthread_exit(NULL); } @@ -123,7 +123,7 @@ createOSThread (OSThreadId* pId, OSThreadProc *startProc, void *param) } OSThreadId -osThreadId() +osThreadId(void) { return pthread_self(); } diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 2b9ee9d234..2252cfcd63 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -669,7 +669,7 @@ GarbageCollect (rtsBool force_major_gc, if (do_heap_census) { debugTrace(DEBUG_sched, "performing heap census"); RELEASE_SM_LOCK; - heapCensus(); + heapCensus(gct->gc_start_cpu); ACQUIRE_SM_LOCK; } diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk index bb28a3a2f9..39a26f07d3 100644 --- a/utils/ghc-cabal/ghc.mk +++ b/utils/ghc-cabal/ghc.mk @@ -34,7 +34,8 @@ $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs | $ -hidir bootstrapping \ -ilibraries/Cabal/cabal \ -ilibraries/filepath \ - -ilibraries/hpc + -ilibraries/hpc \ + $(utils/ghc-cabal_dist_EXTRA_HC_OPTS) touch $@ # touch is required, because otherwise if mkdirhier is newer, we diff --git a/utils/hp2ps/AreaBelow.c b/utils/hp2ps/AreaBelow.c index ec80e1ed48..0ce2077772 100644 --- a/utils/hp2ps/AreaBelow.c +++ b/utils/hp2ps/AreaBelow.c @@ -15,7 +15,7 @@ */ floatish -AreaBelow() +AreaBelow(void) { intish i; intish j; diff --git a/utils/hp2ps/AuxFile.c b/utils/hp2ps/AuxFile.c index 9998d3fc13..39add0fcde 100644 --- a/utils/hp2ps/AuxFile.c +++ b/utils/hp2ps/AuxFile.c @@ -15,8 +15,7 @@ static void GetAuxLine PROTO((FILE *)); /* forward */ static void GetAuxTok PROTO((FILE *)); /* forward */ void -GetAuxFile(auxfp) - FILE* auxfp; +GetAuxFile(FILE *auxfp) { ch = ' '; endfile = 0; @@ -39,8 +38,7 @@ GetAuxFile(auxfp) */ static void -GetAuxLine(auxfp) - FILE* auxfp; +GetAuxLine(FILE *auxfp) { switch (thetok) { case X_RANGE_TOK: @@ -108,8 +106,7 @@ GetAuxLine(auxfp) * in the case of identifiers it is assigned to "theident". */ -static void GetAuxTok(auxfp) -FILE* auxfp; +static void GetAuxTok(FILE *auxfp) { while (isspace(ch)) { /* skip whitespace */ @@ -147,8 +144,7 @@ FILE* auxfp; } void -PutAuxFile(auxfp) - FILE* auxfp; +PutAuxFile(FILE *auxfp) { int i; diff --git a/utils/hp2ps/Axes.c b/utils/hp2ps/Axes.c index a2641cd676..4c2e4f5e95 100644 --- a/utils/hp2ps/Axes.c +++ b/utils/hp2ps/Axes.c @@ -21,15 +21,14 @@ static void YAxisMark PROTO((floatish, floatish, mkb)); /* forward */ static floatish Round PROTO((floatish)); /* forward */ void -Axes() +Axes(void) { XAxis(); YAxis(); } static void -XAxisMark(x, num) - floatish x; floatish num; +XAxisMark(floatish x, floatish num) { /* calibration mark */ fprintf(psfp, "%f %f moveto\n", xpage(x), ypage(0.0)); @@ -54,7 +53,7 @@ extern floatish xrange; extern char *sampleunitstring; static void -XAxis() +XAxis(void) { floatish increment, i; floatish t, x; @@ -93,8 +92,7 @@ XAxis() } static void -YAxisMark(y, num, unit) - floatish y; floatish num; mkb unit; +YAxisMark(floatish y, floatish num, mkb unit) { /* calibration mark */ fprintf(psfp, "%f %f moveto\n", xpage(0.0), ypage(y)); @@ -141,7 +139,7 @@ extern floatish yrange; extern char *valueunitstring; static void -YAxis() +YAxis(void) { floatish increment, i; floatish t, y; @@ -200,8 +198,7 @@ YAxis() static floatish OneTwoFive PROTO((floatish)); /* forward */ static floatish -Round(y) - floatish y; +Round(floatish y) { int i; @@ -228,8 +225,7 @@ Round(y) */ static floatish -OneTwoFive(y) - floatish y; +OneTwoFive(floatish y) { if (y > 4.0) { return (5.0); diff --git a/utils/hp2ps/Curves.c b/utils/hp2ps/Curves.c index ec05c98336..03952743f2 100644 --- a/utils/hp2ps/Curves.c +++ b/utils/hp2ps/Curves.c @@ -20,7 +20,7 @@ static void ShadeCurve PROTO((floatish *x, floatish *y, floatish *py, floatish shade)); void -Curves() +Curves(void) { intish i; @@ -35,8 +35,7 @@ Curves() */ static void -Curve(e) - struct entry* e; +Curve(struct entry *e) { struct chunk* ch; int j; @@ -61,8 +60,7 @@ static void SaveCurve PROTO((floatish *, floatish *)); /* forward */ */ floatish -xpage(x) - floatish x; +xpage(floatish x) { return (x + graphx0); } @@ -74,8 +72,7 @@ xpage(x) */ floatish -ypage(y) - floatish y; +ypage(floatish y) { return (y + graphy0); } @@ -87,8 +84,7 @@ ypage(y) */ static void -ShadeCurve(x, y, py, shade) - floatish *x; floatish *y; floatish *py; floatish shade; +ShadeCurve(floatish *x, floatish *y, floatish *py, floatish shade) { fprintf(psfp, "%f %f moveto\n", xpage(x[0]), ypage(py[0])); PlotCurveLeftToRight(x, py); @@ -111,8 +107,7 @@ ShadeCurve(x, y, py, shade) } static void -PlotCurveLeftToRight(x,y) - floatish *x; floatish *y; +PlotCurveLeftToRight(floatish *x, floatish *y) { intish i; @@ -122,8 +117,7 @@ PlotCurveLeftToRight(x,y) } static void -PlotCurveRightToLeft(x,y) - floatish *x; floatish *y; +PlotCurveRightToLeft(floatish *x, floatish *y) { intish i; @@ -137,8 +131,7 @@ PlotCurveRightToLeft(x,y) */ static void -SaveCurve(y, py) - floatish *y; floatish* py; +SaveCurve(floatish *y, floatish *py) { intish i; @@ -150,7 +143,7 @@ SaveCurve(y, py) extern floatish xrange; void -CurvesInit() +CurvesInit(void) { intish i; diff --git a/utils/hp2ps/Deviation.c b/utils/hp2ps/Deviation.c index ecf7faba16..fe1be70fcf 100644 --- a/utils/hp2ps/Deviation.c +++ b/utils/hp2ps/Deviation.c @@ -18,7 +18,7 @@ */ void -Deviation() +Deviation(void) { intish i; intish j; @@ -96,8 +96,7 @@ Deviation() } void -Identorder(iflag) - int iflag; /* a funny three-way flag ? WDP 95/03 */ +Identorder(int iflag) /* iflag is a funny three-way flag ? WDP 95/03 */ { int i; int j; diff --git a/utils/hp2ps/Dimensions.c b/utils/hp2ps/Dimensions.c index 878dd4efe2..a13ca33617 100644 --- a/utils/hp2ps/Dimensions.c +++ b/utils/hp2ps/Dimensions.c @@ -31,7 +31,7 @@ floatish graphwidth; static floatish KeyWidth PROTO((void)); /* forward */ void -Dimensions() +Dimensions(void) { boolish keyOnGraph; @@ -63,7 +63,7 @@ Dimensions() */ static floatish -KeyWidth() +KeyWidth(void) { intish i; floatish c; @@ -193,8 +193,7 @@ floatish fonttab[] = { #define FUDGE (2.834646 * 0.6) floatish -StringSize(s) - char* s; +StringSize(char *s) { floatish r; diff --git a/utils/hp2ps/Error.c b/utils/hp2ps/Error.c index 68f88d8c91..346e267eb1 100644 --- a/utils/hp2ps/Error.c +++ b/utils/hp2ps/Error.c @@ -37,8 +37,7 @@ Disaster(const char *fmt, ...) } void -Usage(str) - const char *str; +Usage(const char *str) { if (str) printf("error: %s\n", str); printf("usage: %s -b -d -ef -g -i -p -mn -p -s -tf -y [file[.hp]]\n", programname); diff --git a/utils/hp2ps/HpFile.c b/utils/hp2ps/HpFile.c index 787a268229..86cbfb2049 100644 --- a/utils/hp2ps/HpFile.c +++ b/utils/hp2ps/HpFile.c @@ -66,8 +66,7 @@ floatish *markmap; /* sample marks */ */ void -GetHpFile(infp) - FILE *infp; +GetHpFile(FILE *infp) { nsamples = 0; nmarks = 0; @@ -117,8 +116,7 @@ GetHpFile(infp) */ static void -GetHpLine(infp) - FILE* infp; +GetHpLine(FILE *infp) { static intish nmarkmax = 0, nsamplemax = 0; @@ -246,8 +244,7 @@ GetHpLine(infp) char * -TokenToString(t) - token t; +TokenToString(token t) { switch (t) { case EOF_TOK: return "EOF"; @@ -280,8 +277,7 @@ TokenToString(t) */ static void -GetHpTok(infp) - FILE* infp; +GetHpTok(FILE *infp) { while (isspace(ch)) { /* skip whitespace */ @@ -339,8 +335,7 @@ GetHpTok(infp) static char numberstring[ NUMBER_LENGTH - 1 ]; token -GetNumber(infp) - FILE* infp; +GetNumber(FILE *infp) { int i; int containsdot; @@ -374,8 +369,7 @@ GetNumber(infp) */ void -GetIdent(infp) - FILE *infp; +GetIdent(FILE *infp) { unsigned int i; char idbuffer[5000]; @@ -400,8 +394,7 @@ GetIdent(infp) */ void -GetString(infp) - FILE *infp; +GetString(FILE *infp) { unsigned int i; char *stringbuffer; @@ -436,8 +429,7 @@ GetString(infp) } boolish -IsIdChar(ch) - int ch; +IsIdChar(int ch) { return (!isspace(ch)); } @@ -454,8 +446,7 @@ IsIdChar(ch) static struct entry* hashtable[ N_HASH ]; static intish -Hash(s) - char *s; +Hash(char *s) { int r; @@ -474,7 +465,7 @@ Hash(s) */ static struct chunk* -MakeChunk() +MakeChunk(void) { struct chunk* ch; struct datapoint* d; @@ -496,8 +487,7 @@ MakeChunk() */ struct entry * -MakeEntry(name) - char *name; +MakeEntry(char *name) { struct entry* e; @@ -513,8 +503,7 @@ MakeEntry(name) */ static struct entry * -GetEntry(name) - char* name; +GetEntry(char *name) { intish h; struct entry* e; @@ -544,8 +533,7 @@ GetEntry(name) */ void -StoreSample(en, bucket, value) - struct entry* en; intish bucket; floatish value; +StoreSample(struct entry *en, intish bucket, floatish value) { struct chunk* chk; @@ -575,7 +563,7 @@ struct entry** identtable; */ static void -MakeIdentTable() +MakeIdentTable(void) { intish i; intish j; diff --git a/utils/hp2ps/Key.c b/utils/hp2ps/Key.c index 314a682dd6..5fa76ab6d7 100644 --- a/utils/hp2ps/Key.c +++ b/utils/hp2ps/Key.c @@ -12,7 +12,7 @@ static void KeyEntry PROTO((floatish, char *, floatish)); -void Key() +void Key(void) { intish i; floatish c; @@ -39,8 +39,7 @@ void Key() static void -KeyEntry(centreline, name, colour) - floatish centreline; char* name; floatish colour; +KeyEntry(floatish centreline, char *name, floatish colour) { floatish namebase; floatish keyboxbase; diff --git a/utils/hp2ps/Main.c b/utils/hp2ps/Main.c index 947ff46731..1c21d2b2cb 100644 --- a/utils/hp2ps/Main.c +++ b/utils/hp2ps/Main.c @@ -63,9 +63,7 @@ intish nidents; floatish THRESHOLD_PERCENT = DEFAULT_THRESHOLD; int TWENTY = DEFAULT_TWENTY; -int main(argc, argv) -int argc; -char* argv[]; +int main(int argc, char *argv[]) { programname = copystring(Basename(argv[0])); @@ -195,8 +193,7 @@ typedef enum {POINTS, INCHES, MILLIMETRES} pim; static pim Units PROTO((char *)); /* forward */ static floatish -WidthInPoints(wstr) - char *wstr; +WidthInPoints(char *wstr) { floatish result; @@ -221,8 +218,7 @@ WidthInPoints(wstr) static pim -Units(wstr) - char* wstr; +Units(char *wstr) { int i; @@ -240,8 +236,7 @@ int i; } static FILE * -Fp(rootname, filename, suffix, mode) - char* rootname; char** filename; char* suffix; char* mode; +Fp(char *rootname, char **filename, char *suffix, char *mode) { *filename = copystring2(rootname, suffix); diff --git a/utils/hp2ps/Marks.c b/utils/hp2ps/Marks.c index 8d6f924e17..feb341ee03 100644 --- a/utils/hp2ps/Marks.c +++ b/utils/hp2ps/Marks.c @@ -10,7 +10,7 @@ static void Caret PROTO((floatish, floatish, floatish)); void -Marks() +Marks(void) { intish i; floatish m; @@ -27,8 +27,7 @@ Marks() */ static void -Caret(x,y,d) - floatish x; floatish y; floatish d; +Caret(floatish x, floatish y, floatish d) { fprintf(psfp, "%f %f moveto\n", x - d, y); fprintf(psfp, "%f %f rlineto\n", d, -d); diff --git a/utils/hp2ps/PsFile.c b/utils/hp2ps/PsFile.c index 1324da6f08..6013a073e4 100644 --- a/utils/hp2ps/PsFile.c +++ b/utils/hp2ps/PsFile.c @@ -21,7 +21,7 @@ static void TitleOutlineBox PROTO((void)); /* forward */ static void BigTitleText PROTO((void)); /* forward */ static void TitleText PROTO((void)); /* forward */ -static void DoTitleAndBox() +static void DoTitleAndBox(void) { BorderOutlineBox(); @@ -37,14 +37,14 @@ static void DoTitleAndBox() static void Landscape PROTO((void)); /* forward */ static void Portrait PROTO((void)); /* forward */ -void NextPage() { +void NextPage(void) { fprintf(psfp, "showpage\n"); if (gflag) Portrait(); else Landscape(); DoTitleAndBox(); } void -PutPsFile() +PutPsFile(void) { Prologue(); Variables(); @@ -75,7 +75,7 @@ static void EPSFSpecialComments PROTO((floatish)); /* forward */ static void Scaling PROTO((floatish)); /* forward */ static void -Prologue() +Prologue(void) { if (eflag) { floatish epsfscale = epsfwidth / (floatish) borderwidth; @@ -91,7 +91,7 @@ extern char *jobstring; extern char *datestring; static void -StandardSpecialComments() +StandardSpecialComments(void) { fprintf(psfp, "%%!PS-Adobe-2.0\n"); fprintf(psfp, "%%%%Title: %s\n", jobstring); @@ -101,8 +101,7 @@ StandardSpecialComments() } static void -EPSFSpecialComments(epsfscale) - floatish epsfscale; +EPSFSpecialComments(floatish epsfscale) { fprintf(psfp, "%%!PS-Adobe-2.0\n"); fprintf(psfp, "%%%%Title: %s\n", jobstring); @@ -117,7 +116,7 @@ EPSFSpecialComments(epsfscale) static void -Landscape() +Landscape(void) { fprintf(psfp, "-90 rotate\n"); fprintf(psfp, "%f %f translate\n", -(borderwidth + (floatish) START_Y), @@ -125,21 +124,20 @@ Landscape() } static void -Portrait() +Portrait(void) { fprintf(psfp, "%f %f translate\n", (floatish) START_X, (floatish) START_Y); } static void -Scaling(epsfscale) - floatish epsfscale; +Scaling(floatish epsfscale) { fprintf(psfp, "%f %f scale\n", epsfscale, epsfscale); } static void -Variables() +Variables(void) { fprintf(psfp, "/HE%d /Helvetica findfont %d scalefont def\n", NORMAL_FONT, NORMAL_FONT); @@ -150,7 +148,7 @@ Variables() static void -BorderOutlineBox() +BorderOutlineBox(void) { fprintf(psfp, "newpath\n"); fprintf(psfp, "0 0 moveto\n"); @@ -163,7 +161,7 @@ BorderOutlineBox() } static void -BigTitleOutlineBox() +BigTitleOutlineBox(void) { fprintf(psfp, "newpath\n"); fprintf(psfp, "%f %f moveto\n", borderspace, @@ -183,7 +181,7 @@ BigTitleOutlineBox() static void -TitleOutlineBox() +TitleOutlineBox(void) { fprintf(psfp, "newpath\n"); fprintf(psfp, "%f %f moveto\n", borderspace, @@ -199,7 +197,7 @@ TitleOutlineBox() static void EscapePrint PROTO((char *, int)); /* forward */ static void -BigTitleText() +BigTitleText(void) { floatish x, y; @@ -238,7 +236,7 @@ BigTitleText() static void -TitleText() +TitleText(void) { floatish x, y; @@ -283,8 +281,7 @@ TitleText() */ static void -EscapePrint(s,w) - char* s; int w; +EscapePrint(char *s, int w) { for ( ; *s && w > 0; s++, w--) { if (*s == '(') { /* escape required */ diff --git a/utils/hp2ps/Reorder.c b/utils/hp2ps/Reorder.c index afeed52d85..2a7fb98375 100644 --- a/utils/hp2ps/Reorder.c +++ b/utils/hp2ps/Reorder.c @@ -20,9 +20,7 @@ static int ordermapindex = 0; void -OrderFor(ident, order) - char* ident; - int order; +OrderFor(char *ident, int order) { if (! ordermap) { ordermapmax = (nidents > TWENTY ? nidents : TWENTY) * 2; @@ -46,8 +44,7 @@ OrderFor(ident, order) */ int -OrderOf(ident) - char* ident; +OrderOf(char *ident) { int i; @@ -65,7 +62,7 @@ OrderOf(ident) */ void -Reorder() +Reorder(void) { intish i; intish j; diff --git a/utils/hp2ps/Scale.c b/utils/hp2ps/Scale.c index 32120407b3..a471bde47e 100644 --- a/utils/hp2ps/Scale.c +++ b/utils/hp2ps/Scale.c @@ -18,7 +18,7 @@ */ floatish -MaxCombinedHeight() +MaxCombinedHeight(void) { intish i; intish j; @@ -64,7 +64,7 @@ extern floatish xrange; extern floatish yrange; void -Scale() +Scale(void) { intish i; intish j; diff --git a/utils/hp2ps/Shade.c b/utils/hp2ps/Shade.c index 9e3274bf69..d67faee92f 100644 --- a/utils/hp2ps/Shade.c +++ b/utils/hp2ps/Shade.c @@ -22,9 +22,7 @@ static int shademapindex = 0; */ void -ShadeFor(ident, shade) - char* ident; - floatish shade; +ShadeFor(char *ident, floatish shade) { if (! shademap) { shademapmax = (nidents > TWENTY ? nidents : TWENTY) * 2; @@ -51,8 +49,7 @@ ShadeFor(ident, shade) static floatish ThinkOfAShade PROTO((void)); /* forward */ floatish -ShadeOf(ident) - char* ident; +ShadeOf(char *ident) { int i; floatish shade; @@ -93,7 +90,7 @@ static floatish c_shades[ N_COLOUR_SHADES ] = { }; static floatish -ThinkOfAShade() +ThinkOfAShade(void) { static int thisshade = -1; @@ -104,9 +101,7 @@ ThinkOfAShade() } static floatish -extract_colour(shade,factor) - floatish shade; - intish factor; +extract_colour(floatish shade, intish factor) { intish i,j; @@ -116,8 +111,7 @@ extract_colour(shade,factor) } void -SetPSColour(shade) - floatish shade; +SetPSColour(floatish shade) { if (cflag) { fprintf(psfp, "%f %f %f setrgbcolor\n", diff --git a/utils/hp2ps/TopTwenty.c b/utils/hp2ps/TopTwenty.c index bbb6be4390..b47d55a9cb 100644 --- a/utils/hp2ps/TopTwenty.c +++ b/utils/hp2ps/TopTwenty.c @@ -19,7 +19,7 @@ */ void -TopTwenty() +TopTwenty(void) { intish i; intish j; diff --git a/utils/hp2ps/TraceElement.c b/utils/hp2ps/TraceElement.c index c14062dced..eec17e839d 100644 --- a/utils/hp2ps/TraceElement.c +++ b/utils/hp2ps/TraceElement.c @@ -19,7 +19,7 @@ extern floatish thresholdpercent; -void TraceElement() +void TraceElement(void) { intish i; intish j; diff --git a/utils/hp2ps/Utilities.c b/utils/hp2ps/Utilities.c index c9fb612f0e..5139144d53 100644 --- a/utils/hp2ps/Utilities.c +++ b/utils/hp2ps/Utilities.c @@ -6,8 +6,7 @@ extern void* malloc(); char* -Basename(name) - char* name; +Basename(char *name) { char* t; @@ -24,8 +23,7 @@ Basename(name) } void -DropSuffix(name, suffix) - char* name; char* suffix; +DropSuffix(char *name, char *suffix) { char* t; @@ -44,8 +42,7 @@ DropSuffix(name, suffix) } FILE* -OpenFile(s, mode) - char* s; char* mode; +OpenFile(char *s, char *mode) { FILE* r; @@ -65,9 +62,7 @@ OpenFile(s, mode) */ void -CommaPrint(fp,n) - FILE* fp; - intish n; +CommaPrint(FILE *fp, intish n) { if (n < ONETHOUSAND) { fprintf(fp, "%d", (int)n); @@ -78,8 +73,7 @@ CommaPrint(fp,n) } void * -xmalloc(n) - size_t n; +xmalloc(size_t n) { void *r; @@ -92,9 +86,7 @@ xmalloc(n) } void * -xrealloc(p, n) - void *p; - size_t n; +xrealloc(void *p, size_t n) { void *r; extern void *realloc(); @@ -108,8 +100,7 @@ xrealloc(p, n) } char * -copystring(s) - char *s; +copystring(char *s) { char *r; @@ -119,8 +110,7 @@ copystring(s) } char * -copystring2(s, t) - char *s, *t; +copystring2(char *s, char *t) { char *r; diff --git a/utils/runghc/runghc.hs b/utils/runghc/runghc.hs index 4424c96096..8eb46b57f1 100644 --- a/utils/runghc/runghc.hs +++ b/utils/runghc/runghc.hs @@ -28,7 +28,6 @@ import System.FilePath import System.IO #if defined(mingw32_HOST_OS) -import Control.Monad import Foreign import Foreign.C.String #endif diff --git a/utils/unlit/unlit.c b/utils/unlit/unlit.c index 1269b81463..76877bec15 100644 --- a/utils/unlit/unlit.c +++ b/utils/unlit/unlit.c @@ -121,8 +121,7 @@ void myputc(char c, FILE *ostream) /* As getc, but does TAB expansion */ int -egetc(istream) -FILE *istream; +egetc(FILE *istream) { static int spleft = 0; static int linepos = 0; @@ -170,8 +169,7 @@ FILE *istream; * stream. */ -line readline(istream,ostream) -FILE *istream, *ostream; { +line readline(FILE *istream, FILE *ostream) { int c, c1; char buf[100]; int i; @@ -89,6 +89,7 @@ thisdir=`utils/ghc-pwd/dist-boot/ghc-pwd` echo "Validating=YES" > mk/are-validating.mk $make -j$threads ValidateHpc=$hpc ValidateSlow=$slow +# For a "debug make", add "--debug=b --debug=m" $make binary-dist-prep $make test_bindist TEST_PREP=YES |