diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-29 07:49:10 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2011-07-29 07:49:10 +0100 |
| commit | 8919b2f73893b4dc8ad572ca15a51a2732be141c (patch) | |
| tree | 1d2619bd8815e9111f057a23733b62f691dca06a | |
| parent | eab7f5ff457e14413641fae9fc7589bf4e93e3ae (diff) | |
| parent | 81c6183dca435a0f03ec3342f8c116d5f9de2ea6 (diff) | |
| download | haskell-8919b2f73893b4dc8ad572ca15a51a2732be141c.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org/ghc
292 files changed, 10551 insertions, 13763 deletions
diff --git a/.gitignore b/.gitignore index ac8c70e59d..2bfec1656b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,9 @@ # ----------------------------------------------------------------------------- # generic generated file patterns +Thumbs.db +.DS_Store + *~ #*# *.bak @@ -233,4 +236,4 @@ _darcs/ /utils/unlit/unlit -/extra-gcc-opts
\ No newline at end of file +/extra-gcc-opts @@ -110,9 +110,9 @@ endif .PHONY: test test: - $(MAKE) -C testsuite/tests/ghc-regress CLEANUP=1 OUTPUT_SUMMARY=../../../testsuite_summary.txt fast + $(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt fast .PHONY: fulltest fulltest: - $(MAKE) -C testsuite/tests/ghc-regress CLEANUP=1 OUTPUT_SUMMARY=../../../testsuite_summary.txt + $(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt diff --git a/aclocal.m4 b/aclocal.m4 index 34265564d8..f8dafaca5f 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -78,6 +78,58 @@ AC_DEFUN([FPTOOLS_SET_PLATFORM_VARS], GHC_CONVERT_VENDOR([$target_vendor], [TargetVendor]) GHC_CONVERT_OS([$target_os], [TargetOS]) fi + + windows=NO + exeext='' + soext='.so' + case $host in + *-unknown-cygwin32) + AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) + AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) + exit 1 + ;; + *-unknown-mingw32) + windows=YES + exeext='.exe' + soext='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + soext='.dylib' + ;; + x86_64-apple-darwin) + soext='.dylib' + ;; + esac +]) + + +# FP_SETTINGS +# ---------------------------------- +# Set the variables used in the settings file +AC_DEFUN([FP_SETTINGS], +[ + if test "$windows" = YES + then + SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe' + SettingsCCompilerFlags='' + SettingsPerlCommand='$topdir/../perl/perl.exe' + SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe' + SettingsWindresCommand='$topdir/../mingw/bin/windres.exe' + SettingsTouchCommand='$topdir/touchy.exe' + else + SettingsCCompilerCommand="$WhatGccIsCalled" + SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" + SettingsPerlCommand="$PerlCmd" + SettingsDllWrapCommand="/bin/false" + SettingsWindresCommand="/bin/false" + SettingsTouchCommand='touch' + fi + AC_SUBST(SettingsCCompilerCommand) + AC_SUBST(SettingsCCompilerFlags) + AC_SUBST(SettingsPerlCommand) + AC_SUBST(SettingsDllWrapCommand) + AC_SUBST(SettingsWindresCommand) + AC_SUBST(SettingsTouchCommand) ]) @@ -690,7 +742,8 @@ if test -z "$GCC" then AC_MSG_ERROR([gcc is required]) fi -GccLT34= +GccLT34=NO +GccLT46=NO AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version], [ fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/g'`" @@ -700,9 +753,11 @@ AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version], # isn't a very good reason for that, but for now just make configure # fail. FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [3.4], GccLT34=YES) + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6], GccLT46=YES) ]) AC_SUBST([GccVersion], [$fp_cv_gcc_version]) AC_SUBST(GccLT34) +AC_SUBST(GccLT46) ])# FP_GCC_VERSION dnl Small feature test for perl version. Assumes PerlCmd @@ -1468,6 +1523,9 @@ AC_DEFUN([GHC_CONVERT_VENDOR],[ pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 $2="unknown" ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + $2="unknown" + ;; *) #pass thru by default $2="$1" @@ -174,6 +174,7 @@ sub boot_pkgs { or die "Opening $package/ghc.mk failed: $!"; print GHCMK "${package}_PACKAGE = ${pkg}\n"; print GHCMK "${package}_dist-install_GROUP = libraries\n"; + print GHCMK "\$(if \$(filter ${dir},\$(PACKAGES_STAGE0)),\$(eval \$(call build-package,${package},dist-boot,0)))\n"; print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n"; close GHCMK or die "Closing $package/ghc.mk failed: $!"; diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 5c931d9d3a..14ef2c5876 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -19,7 +19,9 @@ types that module BasicTypes( Version, bumpVersion, initialVersion, - Arity, + Arity, + + Alignment, FunctionOrData(..), @@ -45,8 +47,8 @@ module BasicTypes( TupCon(..), tupleParens, OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, - nonRuleLoopBreaker, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, + strongLoopBreaker, weakLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -96,6 +98,16 @@ type Arity = Int %************************************************************************ %* * +\subsection[Alignment]{Alignment} +%* * +%************************************************************************ + +\begin{code} +type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). +\end{code} + +%************************************************************************ +%* * \subsection[FunctionOrData]{FunctionOrData} %* * %************************************************************************ @@ -444,24 +456,20 @@ data OccInfo -- | This identifier breaks a loop of mutually recursive functions. The field -- marks whether it is only a loop breaker due to a reference in a rule | IAmALoopBreaker -- Note [LoopBreaker OccInfo] - !RulesOnly -- True <=> This is a weak or rules-only loop breaker - -- See OccurAnal Note [Weak loop breakers] + !RulesOnly type RulesOnly = Bool \end{code} Note [LoopBreaker OccInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -An OccInfo of (IAmLoopBreaker False) is used by the occurrence -analyser in two ways: - (a) to mark loop-breakers in a group of recursive - definitions (hence the name) - (b) to mark binders that must not be inlined in this phase - (perhaps it has a NOINLINE pragma) -Things with (IAmLoopBreaker False) do not get an unfolding -pinned on to them, so they are completely opaque. + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all -See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True). +See OccurAnal Note [Weak loop breakers] \begin{code} @@ -492,16 +500,17 @@ oneBranch, notOneBranch :: OneBranch oneBranch = True notOneBranch = False -isLoopBreaker :: OccInfo -> Bool -isLoopBreaker (IAmALoopBreaker _) = True -isLoopBreaker _ = False +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False +weakLoopBreaker = IAmALoopBreaker True -isNonRuleLoopBreaker :: OccInfo -> Bool -isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle -isNonRuleLoopBreaker _ = False +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker _) = True +isWeakLoopBreaker _ = False -nonRuleLoopBreaker :: OccInfo -nonRuleLoopBreaker = IAmALoopBreaker False +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 312ae943a8..6e02ed9f0a 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -56,6 +56,7 @@ import FastString import Module import qualified Data.Data as Data +import qualified Data.Typeable import Data.Char import Data.Word \end{code} @@ -374,6 +375,7 @@ data DataCon -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere } + deriving Data.Typeable.Typeable -- | Contains the Ids of the data constructor functions data DataConIds @@ -456,9 +458,6 @@ instance Outputable DataCon where instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) -instance Data.Typeable DataCon where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "DataCon") [] - instance Data.Data DataCon where -- don't traverse? toConstr _ = abstractConstr "DataCon" diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index ee618e20ac..0f90bf0327 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -508,8 +508,8 @@ isStrictId id idUnfolding :: Id -> Unfolding -- Do not expose the unfolding of a loop breaker! idUnfolding id - | isNonRuleLoopBreaker (occInfo info) = NoUnfolding - | otherwise = unfoldingInfo info + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info where info = idInfo id diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index 2c7572bed2..815cc7b6f4 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -38,7 +38,7 @@ module IdInfo ( -- ** The OccInfo type OccInfo(..), - isDeadOcc, isLoopBreaker, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, occInfo, setOccInfo, InsideLam, OneBranch, diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index a6260f40cf..7993b05deb 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -487,7 +487,9 @@ mkDictSelId no_unf name clas rhs = mkLams tyvars (Lam dict_id rhs_body) rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, arg_ids, Var the_arg_id)] + [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr @@ -582,7 +584,7 @@ mkProductBox arg_ids ty result_expr | isNewTyCon tycon && not (isRecursiveTyCon tycon) = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args)) - | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids) + | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids) wrap expr = wrapNewTypeBody tycon tycon_args expr diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index bef9e928fd..ebb5b9fd86 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -34,9 +34,6 @@ module NameSet ( import Name import UniqSet -import Util - -import Data.Data \end{code} %************************************************************************ @@ -48,20 +45,7 @@ import Data.Data \begin{code} type NameSet = UniqSet Name --- TODO: These Data/Typeable instances look very dubious. Surely either --- UniqFM should have the instances, or this should be a newtype? - -nameSetTc :: TyCon -nameSetTc = mkTyCon "NameSet" -instance Typeable NameSet where { typeOf _ = mkTyConApp nameSetTc [] } - -instance Data NameSet where - gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly - toConstr _ = abstractConstr "NameSet" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "NameSet" - -emptyNameSet :: NameSet +emptyNameSet :: NameSet unitNameSet :: Name -> NameSet addListToNameSet :: NameSet -> [Name] -> NameSet addOneToNameSet :: NameSet -> Name -> NameSet 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 fca625692f..515f3c10b0 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -35,8 +35,10 @@ module VarEnv ( RnEnv2, -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, + mkRnEnv2, rnBndr2, rnBndrs2, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + delBndrL, delBndrR, delBndrsL, delBndrsR, addRnInScopeSet, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, @@ -283,11 +285,28 @@ rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR where 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 } + +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 } + rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- ^ Look up the renaming of an occurrence in the left or right term rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool -- ^ Tells whether a variable is locally bound inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env @@ -360,7 +379,7 @@ filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a -minusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b 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 3451c7d5a9..8828adb0d0 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -100,6 +100,7 @@ module CLabel ( hasCAF, infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, + localiseLabel, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -278,11 +279,14 @@ pprDebugCLabel lbl _ -> ppr lbl <> (parens $ text "other CLabel)") +-- True if a local IdLabel that we won't mark as exported +type IsLocal = Bool + data IdLabelInfo = Closure -- ^ Label for closure | SRT -- ^ Static reference table - | InfoTable -- ^ Info tables for closures; always read-only - | Entry -- ^ Entry point + | InfoTable IsLocal -- ^ Info tables for closures; always read-only + | Entry IsLocal -- ^ Entry point | Slow -- ^ Slow entry point | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id @@ -356,13 +360,13 @@ 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 -mkLocalEntryLabel name c = IdLabel name c Entry +mkLocalInfoTableLabel name c = IdLabel name c (InfoTable True) +mkLocalEntryLabel name c = IdLabel name c (Entry True) mkLocalClosureTableLabel name c = IdLabel name c ClosureTable mkClosureLabel name c = IdLabel name c Closure -mkInfoTableLabel name c = IdLabel name c InfoTable -mkEntryLabel name c = IdLabel name c Entry +mkInfoTableLabel name c = IdLabel name c (InfoTable False) +mkEntryLabel name c = IdLabel name c (Entry False) mkClosureTableLabel name c = IdLabel name c ClosureTable mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable mkLocalConEntryLabel c con = IdLabel con c ConEntry @@ -498,7 +502,7 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -- Converting between info labels and entry/ret labels. infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry +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 @@ -509,7 +513,7 @@ infoLblToEntryLbl _ entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable +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 @@ -519,8 +523,8 @@ entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) -cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c (InfoTable _)) = 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 @@ -528,13 +532,18 @@ 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 (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? @@ -691,7 +700,7 @@ externallyVisibleCLabel (PlainModuleInitLabel _)= True externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True -externallyVisibleCLabel (IdLabel name _ _) = isExternalName name +externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False @@ -699,6 +708,12 @@ externallyVisibleCLabel (HpcTicksLabel _) = True externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False +externallyVisibleIdLabel :: IdLabelInfo -> Bool +externallyVisibleIdLabel SRT = False +externallyVisibleIdLabel (Entry lcl) = not lcl +externallyVisibleIdLabel (InfoTable lcl) = not lcl +externallyVisibleIdLabel _ = True + -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -744,7 +759,7 @@ labelType _ = DataLabel idInfoLabelType info = case info of - InfoTable -> DataLabel + InfoTable _ -> DataLabel Closure -> GcPtrLabel ConInfoTable -> DataLabel StaticInfoTable -> DataLabel @@ -847,6 +862,8 @@ entry. instance Outputable CLabel where ppr = pprCLabel +instance PlatformOutputable CLabel where + pprPlatform _ = pprCLabel pprCLabel :: CLabel -> SDoc @@ -980,8 +997,8 @@ ppIdFlavor x = pp_cSEP <> (case x of Closure -> ptext (sLit "closure") SRT -> ptext (sLit "srt") - InfoTable -> ptext (sLit "info") - Entry -> ptext (sLit "entry") + InfoTable _ -> ptext (sLit "info") + Entry _ -> ptext (sLit "entry") Slow -> ptext (sLit "slow") RednCounts -> ptext (sLit "ct") ConEntry -> ptext (sLit "con_entry") diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index a6b215b38f..e49d960c17 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -53,8 +53,8 @@ type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff} data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} -type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph -type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph +type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph +type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph ------------------------------------------------- -- Manipulating CmmGraphs diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 3d0d6fb426..e74e502727 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -238,7 +238,7 @@ addCAF caf srt = where last = next_elt srt srtToData :: TopSRT -> Cmm -srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)] +srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) -- Once we have found the CAFs, we need to do two things: @@ -317,7 +317,7 @@ to_SRT top_srt off len bmp = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ - CmmDataLabel srt_desc_lbl : map CmmStaticLit + Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW top_srt off : mkWordCLit (fromIntegral len) : map mkWordCLit bmp) @@ -336,7 +336,7 @@ localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet) localCAFInfo _ (CmmData _ _) = Nothing localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = case info_tbl top_info of - CmmInfoTable False _ _ _ -> + CmmInfoTable _ False _ _ _ -> Just (cvtToClosureLbl top_l, expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) _ -> Nothing @@ -397,8 +397,8 @@ updInfo toVars toSrt (CmmProc top_info top_l g) = updInfo _ _ t = t updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable -updInfoTbl toVars toSrt (CmmInfoTable s p t typeinfo) - = CmmInfoTable s p t typeinfo' +updInfoTbl toVars toSrt (CmmInfoTable l s p t typeinfo) + = CmmInfoTable l s p t typeinfo' where typeinfo' = case typeinfo of t@(ConstrInfo _ _ _) -> t (FunInfo c s a d e) -> FunInfo c (toSrt s) a d e diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 83d72b8f6e..fcb220d74c 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -13,6 +13,7 @@ import CmmExpr import MkGraph import qualified OldCmm as Old import OldPprCmm () +import Platform import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch) import Control.Monad @@ -21,23 +22,23 @@ import Maybes import Outputable import UniqSupply -cmmToZgraph :: Old.Cmm -> UniqSM Cmm -cmmOfZgraph :: Cmm -> Old.Cmm +cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm +cmmOfZgraph :: Cmm -> Old.Cmm -cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops +cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) = - do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g + do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g mapTop (CmmData s ds) = return $ CmmData s ds cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g) mapTop (CmmData s ds) = CmmData s ds -toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) -toZgraph _ (Old.ListGraph []) = +toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) +toZgraph _ _ (Old.ListGraph []) = do g <- lgraphOfAGraph emptyAGraph return (StackInfo {arg_space=0, updfr_space=Nothing}, g) -toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = +toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = let (offset, entry) = mkCallEntry NativeNodeCall [] in do g <- labelAGraph id $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks @@ -64,7 +65,7 @@ toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = mkStmts (last : []) = mkLast last mkStmts [] = bad "fell off end" mkStmts (_ : _ : _) = bad "last node not at end" - bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g) + bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g) mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) = mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) = diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs index 38eda2d1ac..28279f2dca 100644 --- a/compiler/cmm/CmmDecl.hs +++ b/compiler/cmm/CmmDecl.hs @@ -11,7 +11,7 @@ module CmmDecl ( CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, ProfilingInfo(..), ClosureTypeTag, CmmActual, CmmFormal, ForeignHint(..), - CmmStatic(..), Section(..), + CmmStatics(..), CmmStatic(..), Section(..), ) where #include "HsVersions.h" @@ -55,19 +55,12 @@ 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 + CLabel -- Used to generate both info & entry labels (though the info table label is in 'h' in RawCmmTop) g -- Control-flow graph for the procedure's code | CmmData -- Static data Section - [d] - - --- A basic block containing a single label, at the beginning. --- The list of basic blocks in a top-level code block may be re-ordered. --- Fall-through is not allowed: there must be an explicit jump at the --- end of each basic block, but the code generator might rearrange basic --- blocks in order to turn some jumps into fallthroughs. + d ----------------------------------------------------------------------------- @@ -77,12 +70,18 @@ data GenCmmTop d h g -- Info table as a haskell data type data CmmInfoTable = CmmInfoTable + LocalInfoTable 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 @@ -139,10 +138,7 @@ data CmmStatic -- a literal value, size given by cmmLitRep of the literal. | CmmUninitialised Int -- uninitialised data, N bytes long - | CmmAlign Int - -- align to next N-byte boundary (N must be a power of 2). - | CmmDataLabel CLabel - -- label the current position in this section. | CmmString [Word8] -- string of 8-bit values only, not zero terminated. +data CmmStatics = Statics CLabel {- Label of statics -} [CmmStatic] {- The static data itself -} diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index a606da2aec..47d0c8b004 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -28,7 +28,7 @@ import Data.Bits -- When we split at proc points, we need an empty info table. emptyContInfoTable :: CmmInfoTable -emptyContInfoTable = CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL +emptyContInfoTable = CmmInfoTable False False (ProfilingInfo zero zero) rET_SMALL (ContInfo [] NoC_SRT) where zero = CmmInt 0 wordWidth @@ -78,10 +78,10 @@ mkInfoTable _ (CmmData sec dat) = [CmmData sec dat] mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) = case info of -- Code without an info table. Easy. - CmmNonInfoTable -> [CmmProc [] entry_label blocks] + CmmNonInfoTable -> [CmmProc Nothing entry_label blocks] - CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> - let info_label = entryLblToInfoLbl entry_label + 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 cl_prof' = makeRelativeRefTo info_label cl_prof in case type_info of @@ -153,7 +153,7 @@ mkInfoTableAndCode :: CLabel -> [RawCmmTop] mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc - = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) + = [CmmProc (Just (Statics info_lbl $ map CmmStaticLit (reverse extra_bits ++ std_info))) entry_lbl blocks] | ListGraph [] <- blocks -- No code; only the info table is significant @@ -163,7 +163,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code - [CmmProc [] entry_lbl blocks, + [CmmProc Nothing entry_lbl blocks, mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)] mkSRTLit :: CLabel diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 32fead337e..15357ecb94 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -23,6 +23,7 @@ import Outputable import OldPprCmm() import Constants import FastString +import Platform import Data.Maybe @@ -30,21 +31,22 @@ import Data.Maybe -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops + => Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops cmmLintTop :: (Outputable d, Outputable h) - => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop top = runCmmLint lintCmmTop top + => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop platform top = runCmmLint platform lintCmmTop top -runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint l p = +runCmmLint :: PlatformOutputable a + => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint platform l p = case unCL (l p) of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (ppr p)]) - Right _ -> Nothing + Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + nest 2 err, + ptext $ sLit ("Program was:"), + nest 2 (pprPlatform platform p)]) + Right _ -> Nothing lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint () lintCmmTop (CmmProc _ lbl (ListGraph blocks)) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 6e890355a5..aa166847eb 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -30,31 +30,13 @@ import Outputable -- MachOp ----------------------------------------------------------------------------- -{- -Implementation notes: - -It might suffice to keep just a width, without distinguishing between -floating and integer types. However, keeping the distinction will -help the native code generator to assign registers more easily. --} - - {- | Machine-level primops; ones which we can reasonably delegate to the -native code generators to handle. Basically contains C's primops -and no others. - -Nomenclature: all ops indicate width and signedness, where -appropriate. Widths: 8\/16\/32\/64 means the given size, obviously. -Nat means the operation works on STG word sized objects. -Signedness: S means signed, U means unsigned. For operations where -signedness is irrelevant or makes no difference (for example -integer add), the signedness component is omitted. - -An exception: NatP is a ptr-typed native word. From the point of -view of the native code generators this distinction is irrelevant, -but the C code generator sometimes needs this info to emit the -right casts. +native code generators to handle. + +Most operations are parameterised by the 'Width' that they operate on. +Some operations have separate signed and unsigned versions, and float +and integer versions. -} data MachOp diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs index f7950423fe..cf09b5b134 100644 --- a/compiler/cmm/CmmNode.hs +++ b/compiler/cmm/CmmNode.hs @@ -35,12 +35,15 @@ data CmmNode e x where CmmComment :: FastString -> CmmNode O O - CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register + CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O + -- Assign to register - CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. + CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O + -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. - CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls] + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] -- Like a "fat machine instruction"; can occur -- in the middle of a block ForeignTarget -> -- call target diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index dab866e186..5480d9c597 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -24,6 +24,7 @@ module CmmOpt ( #include "HsVersions.h" import OldCmm +import CmmNode (wrapRecExp) import CmmUtils import CLabel import StaticFlags @@ -180,8 +181,7 @@ cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts -- used (foldable to literal): try to inline at all the use sites | Just n <- lookupUFM uses u, - CmmMachOp op es <- expr, - e@(CmmLit _) <- cmmMachOpFold op es + e@(CmmLit _) <- wrapRecExp foldExp expr = #ifdef NCG_DEBUG trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ @@ -200,6 +200,9 @@ cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ #endif cmmMiniInlineStmts uses stmts' + where + foldExp (CmmMachOp op args) = cmmMachOpFold op args + foldExp e = e cmmMiniInlineStmts uses (stmt:stmts) = stmt : cmmMiniInlineStmts uses stmts @@ -670,12 +673,11 @@ exactLog2 x_ -} cmmLoopifyForC :: RawCmmTop -> RawCmmTop -cmmLoopifyForC p@(CmmProc info entry_lbl - (ListGraph blocks@(BasicBlock top_id _ : _))) - | null info = p -- only if there's an info table, ignore case alts - | otherwise = +cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts +cmmLoopifyForC p@(CmmProc (Just info@(Statics info_lbl _)) entry_lbl + (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ - CmmProc info entry_lbl (ListGraph blocks') + CmmProc (Just info) entry_lbl (ListGraph blocks') where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] @@ -683,7 +685,7 @@ cmmLoopifyForC p@(CmmProc info entry_lbl = CmmBranch top_id do_stmt stmt = stmt - jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl + jump_lbl | tablesNextToCode = info_lbl | otherwise = entry_lbl cmmLoopifyForC top = top diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 60f3bb5623..2d59fe751e 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -188,22 +188,24 @@ cmmtop :: { ExtCode } -- * we can derive closure and info table labels from a single NAME cmmdata :: { ExtCode } - : 'section' STRING '{' statics '}' - { do ss <- sequence $4; - code (emitData (section $2) (concat ss)) } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitData (section $2) (Statics lbl $ concat ss)) } + +data_label :: { ExtFCode CLabel } + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } statics :: { [ExtFCode [CmmStatic]] } : {- empty -} { [] } | static statics { $1 : $2 } - + -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. static :: { ExtFCode [CmmStatic] } - : NAME ':' - {% withThisPackage $ \pkg -> - return [CmmDataLabel (mkCmmDataLabel pkg $1)] } - - | type expr ';' { do e <- $2; + : type expr ';' { do e <- $2; return [CmmStaticLit (getLit e)] } | type ';' { return [CmmUninitialised (widthInBytes (typeWidth $1))] } @@ -213,7 +215,6 @@ static :: { ExtFCode [CmmStatic] } | typenot8 '[' INT ']' ';' { return [CmmUninitialised (widthInBytes (typeWidth $1) * fromIntegral $3)] } - | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ @@ -265,7 +266,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable False False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } @@ -274,7 +275,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable False False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral $15)) @@ -289,7 +290,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable False False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (ArgSpec (fromIntegral $15)) zeroCLit), @@ -305,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 prof (fromIntegral $11) + CmmInfoTable False False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } @@ -314,7 +315,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do prof <- profilingInfo $9 $11 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $7) + CmmInfoTable False False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } @@ -323,7 +324,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do let infoLabel = mkCmmInfoLabel pkg $3 return (mkCmmRetLabel pkg $3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } @@ -332,7 +333,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } {% withThisPackage $ \pkg -> do live <- sequence (map (liftM Just) $7) return (mkCmmRetLabel pkg $3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } @@ -873,9 +874,8 @@ foreignCall conv_string results_code expr_code args_code vols safety ret code (emitForeignCall' PlayRisky results (CmmCallee expr' convention) args vols NoC_SRT ret) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmCallee expr' convention) args vols NoC_SRT ret) where - unused = panic "not used by emitForeignCall'" CmmInterruptible -> code (emitForeignCall' PlayInterruptible results (CmmCallee expr' convention) args vols NoC_SRT ret) @@ -910,9 +910,8 @@ primCall results_code name args_code vols safety code (emitForeignCall' PlayRisky results (CmmPrim p) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmPrim p) args vols NoC_SRT CmmMayReturn) where - unused = panic "not used by emitForeignCall'" CmmInterruptible -> code (emitForeignCall' PlayInterruptible results (CmmPrim p) args vols NoC_SRT CmmMayReturn) @@ -1076,7 +1075,7 @@ parseCmmFile dflags filename = do if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 1e4809d2b2..5effa6ca77 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -65,7 +65,7 @@ cmmPipeline hsc_env (topSRT, rst) prog = let topCAFEnv = mkTopCAFInfo (concat cafEnvs) (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops let cmms = Cmm (reverse (concat tops)) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) -- SRT is not affected by control flow optimization pass let prog' = map runCmmContFlowOpts (cmms : rst) return (topSRT, prog') @@ -90,33 +90,33 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ----------- Eliminate common blocks ------------------- g <- return $ elimCommonBlocks g - dump Opt_D_dump_cmmz_cbe "Post common block elimination" g + dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g -- Any work storing block Labels must be performed _after_ elimCommonBlocks ----------- Proc points ------------------- let callPPs = callProcPoints g - procPoints <- run $ minimalProcPointSet callPPs g + procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g g <- run $ addProcPointProtocols callPPs procPoints g - dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g + dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g ----------- Spills and reloads ------------------- g <- run $ dualLivenessWithInsertion procPoints g - dump Opt_D_dump_cmmz_spills "Post spills and reloads" g + dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g ----------- Sink and inline assignments ------------------- g <- runOptimization $ rewriteAssignments g - dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g + dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g ----------- Eliminate dead assignments ------------------- g <- runOptimization $ removeDeadAssignments g - dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g + dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g ----------- Zero dead stack slots (Debug only) --------------- -- Debugging: stubbing slots on death can cause crashes early g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g - dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g + dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g --------------- Stack layout ---------------- slotEnv <- run $ liveSlotAnal g @@ -127,7 +127,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) ------------ Manifest the stack pointer -------- g <- run $ manifestSP spEntryMap areaMap entry_off g - dump Opt_D_dump_cmmz_sp "Post manifestSP" g + dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... @@ -136,7 +136,7 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g) - mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs ------------- More CAFs and foreign calls ------------ cafEnv <- run $ cafAnal g @@ -144,23 +144,26 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) mbpprTrace "localCAFs" (ppr localCAFs) $ return () gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs - mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs - mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs gs <- return $ map (bundleCAFs cafEnv) gs - mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs return (localCAFs, gs) where dflags = hsc_dflags hsc_env + platform = targetPlatform dflags mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z - dump f txt g = do + dump f = dumpWith ppr f + dumpPlatform platform = dumpWith (pprPlatform platform) + dumpWith pprFun f txt g = do -- ToDo: No easy way of say "dump all the cmmz, *and* split -- them into files." Also, -ddump-cmmz doesn't play nicely -- with -ddump-to-file, since the headers get omitted. - dumpIfSet_dyn dflags f txt (ppr g) + dumpIfSet_dyn dflags f txt (pprFun g) when (not (dopt f dflags)) $ - dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g) + dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g) -- Runs a required transformation/analysis run = runInfiniteFuelIO (hsc_OptFuel hsc_env) -- Runs an optional transformation/analysis (and should diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index 0527b6eea0..b608b291d4 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -25,6 +25,7 @@ import MkGraph import Control.Monad import OptimizationFuel import Outputable +import Platform import UniqSet import UniqSupply @@ -139,10 +140,10 @@ callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g CmmForeignCall {succ=k} -> setInsert k set _ -> set -minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet -- Given the set of successors of calls (which must be proc-points) -- figure out the minimal set of necessary proc-points -minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints +minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status) -- Once you know what the proc-points are, figure out @@ -151,8 +152,8 @@ procPointAnalysis procPoints g = liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints] -extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet -extendPPSet g blocks procPoints = +extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet +extendPPSet platform g blocks procPoints = do env <- procPointAnalysis procPoints g let add block pps = let id = entryLabel block in case mapLookup id env of @@ -163,7 +164,7 @@ extendPPSet g blocks procPoints = newPoint = listToMaybe newPoints ppSuccessor b = let nreached id = case mapLookup id env `orElse` - pprPanic "no ppt" (ppr id <+> ppr b) of + pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of ProcPoint -> 1 ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b) @@ -181,7 +182,7 @@ extendPPSet g blocks procPoints = -} case newPoint of Just id -> if setMember id procPoints' then panic "added old proc pt" - else extendPPSet g blocks (setInsert id procPoints') + else extendPPSet platform g blocks (setInsert id procPoints') Nothing -> return procPoints' diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs index 6988ae6905..27277540fe 100644 --- a/compiler/cmm/CmmType.hs +++ b/compiler/cmm/CmmType.hs @@ -49,10 +49,6 @@ instance Outputable CmmType where instance Outputable CmmCat where ppr FloatCat = ptext $ sLit("F") ppr _ = ptext $ sLit("I") --- Temp Jan 08 --- ppr FloatCat = ptext $ sLit("float") --- ppr BitsCat = ptext $ sLit("bits") --- ppr GcPtrCat = ptext $ sLit("gcptr") -- Why is CmmType stratified? For native code generation, -- most of the time you just want to know what sort of register @@ -244,7 +240,7 @@ definition of a function is not visible at all of its call sites, so the compiler cannot infer the hints. Here in Cmm, we're taking a slightly different approach. We include -the int vs. float hint in the MachRep, because (a) the majority of +the int vs. float hint in the CmmType, because (a) the majority of platforms have a strong distinction between float and int registers, and (b) we don't want to do any heavyweight hint-inference in the native code backend in order to get good code. We're treating the @@ -272,7 +268,7 @@ of analysis that propagates hints around. In Cmm we don't want to have to do this, so we plump for having richer types and keeping the type information consistent. -If signed/unsigned hints are missing from MachRep, then the only +If signed/unsigned hints are missing from CmmType, then the only choice we have is (a), because we don't know whether the result of an operation should be sign- or zero-extended. @@ -287,7 +283,7 @@ convention can specify that signed 8-bit quantities are passed as sign-extended 32 bit quantities, for example (this is the case on the PowerPC). So we *do* need sign information on foreign call arguments. -Pros for adding signed vs. unsigned to MachRep: +Pros for adding signed vs. unsigned to CmmType: - It would let us use convention (b) above, and get easier code generation for extending loads. @@ -300,10 +296,10 @@ Cons: - More complexity - - What is the MachRep for a VanillaReg? Currently it is + - What is the CmmType for a VanillaReg? Currently it is always wordRep, but now we have to decide whether it is signed or unsigned. The same VanillaReg can thus have - different MachReps in different parts of the program. + different CmmType in different parts of the program. - Extra coercions cluttering up expressions. diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index de1a8e0dcb..f691183038 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -73,12 +73,15 @@ newtype ListGraph i = ListGraph [GenBasicBlock i] -- across a whole compilation unit. -- | Cmm with the info table as a data type -type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt) -type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt) +type Cmm = GenCmm CmmStatics CmmInfo (ListGraph CmmStmt) +type CmmTop = GenCmmTop CmmStatics CmmInfo (ListGraph CmmStmt) --- | Cmm with the info tables converted to a list of 'CmmStatic' -type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt) -type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt) +-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info +-- table label. If we are building without tables-next-to-code there will be no statics +-- +-- INVARIANT: if there is an info table, it has at least one CmmStatic +type RawCmm = GenCmm CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt) +type RawCmmTop = GenCmmTop CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt) -- A basic block containing a single label, at the beginning. diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 4b0db35bd8..4050359710 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -50,20 +50,23 @@ import PprCmmExpr import BasicTypes import ForeignCall import Outputable +import Platform import FastString import Data.List ----------------------------------------------------------------------------- -instance (Outputable instr) => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) +instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where + pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) -instance (Outputable instr) => Outputable (GenBasicBlock instr) where - ppr b = pprBBlock b +instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where + pprPlatform platform b = pprBBlock platform b instance Outputable CmmStmt where ppr s = pprStmt s +instance PlatformOutputable CmmStmt where + pprPlatform _ = ppr instance Outputable CmmInfo where ppr e = pprInfo e @@ -88,7 +91,7 @@ pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = maybe (ptext (sLit "<none>")) ppr gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame] -pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) = +pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) = vcat [{-ptext (sLit "gc_target: ") <> maybe (ptext (sLit "<none>")) ppr gc_target,-} ptext (sLit "update_frame: ") <> @@ -99,9 +102,9 @@ pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) = -- -------------------------------------------------------------------------- -- Basic blocks look like assembly blocks. -- lbl: stmt ; stmt ; .. -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) +pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc +pprBBlock platform (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 1e11c0c55b..b48d2de3c8 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - ----------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as C, suitable for feeding gcc @@ -23,8 +16,6 @@ -- disappeared from the data type. -- --- ToDo: save/restore volatile registers around calls. - module PprC ( writeCs, pprStringInCStyle @@ -35,21 +26,17 @@ module PprC ( -- Cmm stuff import BlockId import OldCmm -import OldPprCmm () -- Instances only +import OldPprCmm () import CLabel import ForeignCall -import ClosureInfo -- Utils import DynFlags import Unique import UniqSet -import UniqFM import FastString import Outputable import Constants -import BasicTypes -import CLabel import Util -- The rest @@ -77,7 +64,7 @@ pprCs dflags cmms where split_marker | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER") - | otherwise = empty + | otherwise = empty writeCs :: DynFlags -> Handle -> [RawCmm] -> IO () writeCs dflags handle cmms @@ -96,14 +83,14 @@ pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops -- top level procs -- pprTop :: RawCmmTop -> SDoc -pprTop (CmmProc info clbl (ListGraph blocks)) = - (if not (null info) - then pprDataExterns info $$ - pprWordArray (entryLblToInfoLbl clbl) info - else empty) $$ +pprTop (CmmProc mb_info clbl (ListGraph blocks)) = + (case mb_info of + Nothing -> empty + Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ + pprWordArray info_clbl info_dat) $$ (vcat [ - blankLine, - extern_decls, + blankLine, + extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, nest 8 temp_decls, @@ -118,38 +105,28 @@ pprTop (CmmProc info clbl (ListGraph blocks)) = rbrace ] ) where - (temp_decls, extern_decls) = pprTempAndExternDecls blocks + (temp_decls, extern_decls) = pprTempAndExternDecls blocks -- Chunks of static data. -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = +pprTop (CmmData _section (Statics lbl [CmmString str])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, ptext (sLit "[] = "), pprStringInCStyle str, semi ] -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = +pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, brackets (int size), semi ] -pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = +pprTop (CmmData _section (Statics lbl lits)) = pprDataExterns lits $$ - pprWordArray lbl lits - --- Floating info table for safe a foreign call. -pprTop top@(CmmData _section d@(_ : _)) - | CmmDataLabel lbl : lits <- reverse d = - let lits' = reverse lits - in pprDataExterns lits' $$ - pprWordArray lbl lits' - --- these shouldn't appear? -pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" + pprWordArray lbl lits -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. @@ -192,8 +169,9 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ") pprStmt :: CmmStmt -> SDoc pprStmt stmt = case stmt of + CmmReturn _ -> panic "pprStmt: return statement should have been cps'd away" CmmNop -> empty - CmmComment s -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") + CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when -- some debugging option is on. They can get quite @@ -257,9 +235,13 @@ pprStmt stmt = case stmt of -- for a dynamic call, no declaration is necessary. CmmCall (CmmPrim op) results args safety _ret -> - pprCall ppr_fn CCallConv results args safety + pprCall ppr_fn CCallConv results args' safety where ppr_fn = pprCallishMachOp_for_C op + -- The mem primops carry an extra alignment arg, must drop it. + -- We could maybe emit an alignment directive using this info. + args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args + | otherwise = args CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch expr ident @@ -274,6 +256,7 @@ pprCFunType ppr_fn cconv ress args where res_type [] = ptext (sLit "void") res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint + res_type _ = panic "pprCFunType: only void or 1 return value supported" arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint @@ -323,6 +306,8 @@ pprSwitch e maybe_ids hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon , ptext (sLit "goto") , (pprBlockId ident) <> semi ] + caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!" + -- --------------------------------------------------------------------- -- Expressions. -- @@ -354,6 +339,8 @@ pprExpr e = case e of CmmMachOp mop args -> pprMachOpApp mop args + CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" + pprLoad :: CmmExpr -> CmmType -> SDoc pprLoad e ty @@ -411,6 +398,7 @@ machOpNeedsCast mop | isComparisonMachOp mop = Just mkW_ | otherwise = Nothing +pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc pprMachOpApp' mop args = case args of -- dyadic @@ -452,7 +440,7 @@ pprLit lit = case lit of CmmHighStackMark -> panic "PprC printing high stack mark" CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i - CmmLabelDiffOff clbl1 clbl2 i + CmmLabelDiffOff clbl1 _ i -- WARNING: -- * the lit must occur in the info table clbl2 -- * clbl1 must be an SRT, a slow entry point or a large bitmap @@ -461,7 +449,8 @@ pprLit lit = case lit of -- from an info table to an offset. -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i -pprCLabelAddr lbl = char '&' <> pprCLabel lbl + where + pprCLabelAddr lbl = char '&' <> pprCLabel lbl pprLit1 :: CmmLit -> SDoc pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) @@ -481,7 +470,9 @@ pprStatics (CmmStaticLit (CmmFloat f W32) : rest) | wORD_SIZE == 4 = pprLit1 (floatToWord f) : pprStatics rest | otherwise - = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitType l)) rest)) + = pprPanic "pprStatics: float" (vcat (map ppr' rest)) + where ppr' (CmmStaticLit l) = ppr (cmmLitType l) + ppr' _other = ptext (sLit "bad static!") pprStatics (CmmStaticLit (CmmFloat f W64) : rest) = map pprLit1 (doubleToWords f) ++ pprStatics rest pprStatics (CmmStaticLit (CmmInt i W64) : rest) @@ -495,20 +486,18 @@ pprStatics (CmmStaticLit (CmmInt i W64) : rest) #endif where r = i .&. 0xffffffff q = i `shiftR` 32 -pprStatics (CmmStaticLit (CmmInt i w) : rest) +pprStatics (CmmStaticLit (CmmInt _ w) : _) | w /= wordWidth = panic "pprStatics: cannot emit a non-word-sized static literal" pprStatics (CmmStaticLit lit : rest) = pprLit1 lit : pprStatics rest -pprStatics (other : rest) +pprStatics (other : _) = pprPanic "pprWord" (pprStatic other) pprStatic :: CmmStatic -> SDoc pprStatic s = case s of CmmStaticLit lit -> nest 4 (pprLit lit) - CmmAlign i -> nest 4 (ptext (sLit "/* align */") <+> int i) - CmmDataLabel clbl -> pprCLabel clbl <> colon CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc @@ -659,7 +648,12 @@ pprCallishMachOp_for_C mop MO_F32_Log -> ptext (sLit "logf") MO_F32_Exp -> ptext (sLit "expf") MO_F32_Sqrt -> ptext (sLit "sqrtf") - MO_WriteBarrier -> ptext (sLit "write_barrier") + MO_WriteBarrier -> ptext (sLit "write_barrier") + MO_Memcpy -> ptext (sLit "memcpy") + MO_Memset -> ptext (sLit "memset") + MO_Memmove -> ptext (sLit "memmove") + a -> panic $ "pprCallishMachOp_for_C: Unknown callish op! (" + ++ show a ++ ")" -- --------------------------------------------------------------------- -- Useful #defines @@ -721,6 +715,7 @@ pprAssign r1 r2 -- --------------------------------------------------------------------- -- Registers +pprCastReg :: CmmReg -> SDoc pprCastReg reg | isStrangeTypeReg reg = mkW_ <> pprReg reg | otherwise = pprReg reg @@ -737,18 +732,18 @@ isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg n VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg n VNonGcPtr)) = False --if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg -- True if this global reg has type StgPtr isFixedPtrGlobalReg :: GlobalReg -> Bool -isFixedPtrGlobalReg Sp = True -isFixedPtrGlobalReg Hp = True -isFixedPtrGlobalReg HpLim = True -isFixedPtrGlobalReg SpLim = True -isFixedPtrGlobalReg _ = False +isFixedPtrGlobalReg Sp = True +isFixedPtrGlobalReg Hp = True +isFixedPtrGlobalReg HpLim = True +isFixedPtrGlobalReg SpLim = True +isFixedPtrGlobalReg _ = False -- True if in C this register doesn't have the type given by -- (machRepCType (cmmRegType reg)), so it has to be cast. @@ -800,6 +795,7 @@ pprGlobalReg gr = case gr of EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") GCEnter1 -> ptext (sLit "stg_gc_enter_1") GCFun -> ptext (sLit "stg_gc_fun") + other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other pprLocalReg :: LocalReg -> SDoc pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq @@ -811,8 +807,8 @@ pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSaf -> SDoc pprCall ppr_fn cconv results args _ - | not (is_cish cconv) - = panic "pprCall: unknown calling convention" + | not (is_cishCC cconv) + = panic $ "pprCall: unknown calling convention" | otherwise = @@ -836,15 +832,13 @@ pprCall ppr_fn cconv results args _ pprUnHint SignedHint rep = parens (machRepCType rep) pprUnHint _ _ = empty -pprGlobalRegName :: GlobalReg -> SDoc -pprGlobalRegName gr = case gr of - VanillaReg n _ -> char 'R' <> int n -- without the .w suffix - _ -> pprGlobalReg gr - -- Currently we only have these two calling conventions, but this might -- change in the future... -is_cish CCallConv = True -is_cish StdCallConv = True +is_cishCC :: CCallConv -> Bool +is_cishCC CCallConv = True +is_cishCC StdCallConv = True +is_cishCC CmmCallConv = False +is_cishCC PrimCallConv = False -- --------------------------------------------------------------------- -- Find and print local and external declarations for a list of @@ -866,7 +860,7 @@ pprTempDecl l@(LocalReg _ rep) = hcat [ machRepCType rep, space, pprLocalReg l, semi ] pprExternDecl :: Bool -> CLabel -> SDoc -pprExternDecl in_srt lbl +pprExternDecl _in_srt lbl -- do not print anything for "known external" things | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz @@ -915,7 +909,7 @@ te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss te_Lit :: CmmLit -> TE () te_Lit (CmmLabel l) = te_lbl l te_Lit (CmmLabelOff l _) = te_lbl l -te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1 +te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1 te_Lit _ = return () te_Stmt :: CmmStmt -> TE () @@ -934,6 +928,7 @@ te_Expr (CmmLoad e _) = te_Expr e te_Expr (CmmReg r) = te_Reg r te_Expr (CmmMachOp _ es) = mapM_ te_Expr es te_Expr (CmmRegOff r _) = te_Reg r +te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" te_Reg :: CmmReg -> TE () te_Reg (CmmLocal l) = te_temp l @@ -967,7 +962,7 @@ isCmmWordType ty = not (isFloatType ty) -- argument, we always cast the argument to (void *), to avoid warnings from -- the C compiler. machRepHintCType :: CmmType -> ForeignHint -> SDoc -machRepHintCType rep AddrHint = ptext (sLit "void *") +machRepHintCType _ AddrHint = ptext (sLit "void *") machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) machRepHintCType rep _other = machRepCType rep @@ -1017,6 +1012,7 @@ pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -- This is a hack to turn the floating point numbers into ints that we -- can safely initialise to static locations. +big_doubles :: Bool big_doubles | widthInBytes W64 == 2 * wORD_SIZE = True | widthInBytes W64 == wORD_SIZE = False diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index cede69e06f..43e1c5bb2f 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -49,6 +49,7 @@ import PprCmmExpr import Util import BasicTypes +import Platform import Compiler.Hoopl import Data.List import Prelude hiding (succ) @@ -76,20 +77,20 @@ instance Outputable ForeignTarget where ppr = pprForeignTarget -instance Outputable (Block CmmNode C C) where - ppr = pprBlock -instance Outputable (Block CmmNode C O) where - ppr = pprBlock -instance Outputable (Block CmmNode O C) where - ppr = pprBlock -instance Outputable (Block CmmNode O O) where - ppr = pprBlock +instance PlatformOutputable (Block CmmNode C C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode C O) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O O) where + pprPlatform _ = pprBlock -instance Outputable (Graph CmmNode e x) where - ppr = pprGraph +instance PlatformOutputable (Graph CmmNode e x) where + pprPlatform = pprGraph -instance Outputable CmmGraph where - ppr = pprCmmGraph +instance PlatformOutputable CmmGraph where + pprPlatform platform = pprCmmGraph platform ---------------------------------------------------------- -- Outputting types Cmm contains @@ -107,7 +108,8 @@ pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = ---------------------------------------------------------- -- Outputting blocks and graphs -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Block CmmNode e x -> IndexedCO e SDoc SDoc pprBlock block = foldBlockNodesB3 ( ($$) . ppr , ($$) . (nest 4) . ppr , ($$) . (nest 4) . ppr @@ -115,21 +117,22 @@ pprBlock block = foldBlockNodesB3 ( ($$) . ppr block empty -pprGraph :: Graph CmmNode e x -> SDoc -pprGraph GNil = empty -pprGraph (GUnit block) = ppr block -pprGraph (GMany entry body exit) +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph _ GNil = empty +pprGraph platform (GUnit block) = pprPlatform platform block +pprGraph platform (GMany entry body exit) = text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit) + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit) $$ text "}" - where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc + where pprMaybeO :: PlatformOutputable (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc pprMaybeO NothingO = empty - pprMaybeO (JustO block) = ppr block + pprMaybeO (JustO block) = pprPlatform platform block -pprCmmGraph :: CmmGraph -> SDoc -pprCmmGraph g +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g = text "{" <> text "offset" - $$ nest 2 (vcat $ map ppr blocks) + $$ nest 2 (vcat $ map (pprPlatform platform) blocks) $$ text "}" where blocks = postorderDfs g diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs index 1f520bfc90..f688f211fb 100644 --- a/compiler/cmm/PprCmmDecl.hs +++ b/compiler/cmm/PprCmmDecl.hs @@ -43,6 +43,7 @@ import PprCmmExpr import Outputable +import Platform import FastString import Data.List @@ -54,23 +55,28 @@ import ClosureInfo #include "../includes/rts/storage/FunTypes.h" -pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc -pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) +pprCmms :: (Outputable info, PlatformOutputable g) + => Platform -> [GenCmm CmmStatics info g] -> SDoc +pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms)) where separator = space $$ ptext (sLit "-------------------") $$ space -writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO () -writeCmms handle cmms = printForC handle (pprCmms cmms) +writeCmms :: (Outputable info, PlatformOutputable g) + => Platform -> Handle -> [GenCmm CmmStatics info g] -> IO () +writeCmms platform handle cmms = printForC handle (pprCmms platform cmms) ----------------------------------------------------------------------------- -instance (Outputable d, Outputable info, Outputable g) - => Outputable (GenCmm d info g) where - ppr c = pprCmm c +instance (Outputable d, Outputable info, PlatformOutputable g) + => PlatformOutputable (GenCmm d info g) where + pprPlatform platform c = pprCmm platform c -instance (Outputable d, Outputable info, Outputable i) - => Outputable (GenCmmTop d info i) where - ppr t = pprTop t +instance (Outputable d, Outputable info, PlatformOutputable i) + => PlatformOutputable (GenCmmTop d info i) where + pprPlatform platform t = pprTop platform t + +instance Outputable CmmStatics where + ppr e = pprStatics e instance Outputable CmmStatic where ppr e = pprStatic e @@ -81,20 +87,22 @@ instance Outputable CmmInfoTable where ----------------------------------------------------------------------------- -pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc -pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops +pprCmm :: (Outputable d, Outputable info, PlatformOutputable g) + => Platform -> GenCmm d info g -> SDoc +pprCmm platform (Cmm tops) + = vcat $ intersperse blankLine $ map (pprTop platform) tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. -- -pprTop :: (Outputable d, Outputable info, Outputable i) - => GenCmmTop d info i -> SDoc +pprTop :: (Outputable d, Outputable info, PlatformOutputable i) + => Platform -> GenCmmTop d info i -> SDoc -pprTop (CmmProc info lbl graph) +pprTop platform (CmmProc info lbl graph) = vcat [ pprCLabel lbl <> lparen <> rparen , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ ppr graph + , nest 4 $ pprPlatform platform graph , rbrace ] -- -------------------------------------------------------------------------- @@ -102,8 +110,8 @@ pprTop (CmmProc info lbl graph) -- -- section "data" { ... } -- -pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds))) +pprTop _ (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) $$ rbrace -- -------------------------------------------------------------------------- @@ -111,8 +119,9 @@ pprTop (CmmData section ds) = pprInfoTable :: CmmInfoTable -> SDoc pprInfoTable CmmNonInfoTable = empty -pprInfoTable (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info) = - vcat [ptext (sLit "has static closure: ") <> ppr stat_clos <+> +pprInfoTable (CmmInfoTable is_local stat_clos (ProfilingInfo closure_type closure_desc) tag info) = + vcat [ptext (sLit "is local: ") <> ppr is_local <+> + ptext (sLit "has static closure: ") <> ppr stat_clos <+> ptext (sLit "type: ") <> pprLit closure_type, ptext (sLit "desc: ") <> pprLit closure_desc, ptext (sLit "tag: ") <> integer (toInteger tag), @@ -171,12 +180,13 @@ instance Outputable ForeignHint where -- Strings are printed as C strings, and we print them as I8[], -- following C-- -- +pprStatics :: CmmStatics -> SDoc +pprStatics (Statics lbl ds) = vcat ((pprCLabel lbl <> colon) : map ppr ds) + pprStatic :: CmmStatic -> SDoc pprStatic s = case s of CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmAlign i -> nest 4 $ text "align" <+> int i - CmmDataLabel clbl -> pprCLabel clbl <> colon CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') -- -------------------------------------------------------------------------- diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 1eea96c1b0..649bda87ef 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -157,6 +157,25 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr reps_compatible = idCgRep v == idCgRep bndr \end{code} +Special case #2.5; seq# + + case seq# a s of v + (# s', a' #) -> e + + ==> + + case a of v + (# s', a' #) -> e + + (taking advantage of the fact that the return convention for (# State#, a #) + is the same as the return convention for just 'a') + +\begin{code} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) + live_in_whole_case live_in_alts bndr alt_type alts + = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts +\end{code} + Special case #3: inline PrimOps and foreign calls. \begin{code} diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 1f11495b60..fe08f50b42 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -151,6 +151,13 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) tycon = tyConAppTyCon res_ty +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) + = cgTailCall a [] + -- seq# :: a -> State# -> (# State# , a #) + -- but the return convention for (# State#, a #) is exactly the same as + -- for just a, so we can implment seq# by + -- seq# a s ==> a + cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | primOpOutOfLine primop = tailCallPrimOp primop args 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/CgHpc.hs b/compiler/codeGen/CgHpc.hs index 48756505c3..a134f00067 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -12,6 +12,7 @@ import OldCmm import CLabel import Module import OldCmmUtils +import CgUtils import CgMonad import HscTypes @@ -30,9 +31,8 @@ cgTickBox mod n = do hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) + emitDataLits (mkHpcTicksLabel this_mod) $ + [ CmmInt 0 W64 | _ <- take hpc_tickCount [0::Int ..] ] diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 2745832227..76a433b48e 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -59,7 +59,7 @@ emitClosureCodeAndInfoTable cl_info args body ; info <- mkCmmInfo cl_info ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks } where - info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info + info_lbl = infoTableLabelFromCI cl_info -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. @@ -84,12 +84,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (closureInfoLocal cl_info) False prof cl_type info) where info = case lf_info of @@ -105,7 +105,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,7 +142,7 @@ emitReturnTarget name stmts ; let info = CmmInfo gc_target Nothing - (CmmInfoTable False + (CmmInfoTable False False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 9b195bfab2..273c1bf16e 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -736,7 +736,7 @@ emitCgStmt stmt ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } } -emitData :: Section -> [CmmStatic] -> Code +emitData :: Section -> CmmStatics -> Code emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index 87ed25c041..c2a57a40d2 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -127,8 +127,28 @@ emitPrimOp [res] ParOp [arg] live NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn where + newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + +emitPrimOp [res] SparkOp [arg] live = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- newTemp bWord + stmtC (CmmAssign (CmmLocal tmp) arg) + + vols <- getVolatileRegs live + emitForeignCall' PlayRisky [] + (CmmCallee newspark CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) + , (CmmHinted arg AddrHint) ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + emitPrimOp [res] ReadMutVarOp [mutv] _ = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 63d99a629f..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" @@ -545,26 +545,26 @@ baseRegOffset _ = panic "baseRegOffset:other" emitDataLits :: CLabel -> [CmmLit] -> Code -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: String -> CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits caller lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -580,7 +580,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- @@ -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 d2c63b3be3..ad2ea4fddd 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -35,7 +35,7 @@ module ClosureInfo ( 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 - isStaticClosure, + closureInfoLocal, isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, @@ -59,7 +59,6 @@ module ClosureInfo ( #include "../includes/MachDeps.h" #include "HsVersions.h" ---import CgUtils import StgSyn import SMRep @@ -111,7 +110,8 @@ data ClosureInfo closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -341,7 +341,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -842,6 +847,9 @@ 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) @@ -900,6 +908,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} @@ -915,9 +929,9 @@ isToplevClosure _ = False Label generation. \begin{code} -infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel -infoTableLabelFromCI (ClosureInfo { closureName = name, - closureLFInfo = lf_info }) caf +infoTableLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info }) = case lf_info of LFBlackHole info -> info @@ -927,23 +941,23 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name caf + LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf + LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl _ -> panic "infoTableLabelFromCI" -infoTableLabelFromCI (ConInfo { closureCon = con, - closureSMRep = rep }) caf - | isStaticRep rep = mkStaticInfoTableLabel name caf - | otherwise = mkConInfoTableLabel name caf +infoTableLabelFromCI cl@(ConInfo { closureCon = con, + closureSMRep = rep }) + | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl + | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl where name = dataConName con -- 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. @@ -1003,7 +1017,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" \end{code} @@ -1052,5 +1067,5 @@ getTyDescription ty getPredTyDescription :: PredType -> String getPredTyDescription (ClassP cl _) = getOccString cl getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) -getPredTyDescription (EqPred _ _) = panic "getPredTyDescription EqPred" +getPredTyDescription (EqPred _ _) = "Type equality" \end{code} diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 7a7bf48b92..42c4bd24fc 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -84,7 +84,7 @@ codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -105,7 +105,7 @@ mkModuleInit dflags cost_centre_info this_mod hpc_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] ; whenC (this_mod == mainModIs dflags) $ emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 2bfe1876ba..29a254fafc 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -81,7 +81,7 @@ codeGen dflags this_mod data_tycons -- initialisation routines; see Note -- [pipeline-split-init]. - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -182,7 +182,7 @@ mkModuleInit cost_centre_info this_mod hpc_info ; initCostCentres cost_centre_info -- For backwards compatibility: user code may refer to this -- label for calling hs_add_root(). - ; emitData Data $ [ CmmDataLabel (mkPlainModuleInitLabel this_mod) ] + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] } --------------------------------------------------------------- diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index d6177438a4..7c4f8bc8b8 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -56,7 +56,7 @@ module StgCmmClosure ( isToplevClosure, closureValDescr, closureTypeDescr, -- profiling - isStaticClosure, + closureInfoLocal, isStaticClosure, cafBlackHoleClosureInfo, staticClosureNeedsLink, clHasCafRefs @@ -679,7 +679,8 @@ data ClosureInfo closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) closureDescr :: !String, -- closure description (for profiling) - closureCafs :: !CafInfo -- whether the closure may have CAFs + closureCafs :: !CafInfo, -- whether the closure may have CAFs + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -725,7 +726,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSRT = srt_info, closureType = idType id, closureDescr = descr, - closureCafs = idCafInfo id } + closureCafs = idCafInfo id, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -756,7 +762,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureSRT = NoC_SRT, closureType = ty, closureDescr = "", - closureCafs = cafs } + closureCafs = cafs, + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" @@ -931,6 +938,10 @@ 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) @@ -997,9 +1008,9 @@ infoTableLabelFromCI cl@(ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> mkInfoTableLabel name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl _other -> panic "infoTableLabelFromCI" @@ -1086,10 +1097,9 @@ getTyDescription ty fun_result other = getTyDescription other getPredTyDescription :: PredType -> String -getPredTyDescription (ClassP cl _) = getOccString cl -getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) -getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk? - +getPredTyDescription (ClassP cl _) = getOccString cl +getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) +getPredTyDescription (EqPred {}) = "Type equality" -------------------------------------- -- SRTs/CAFs diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index eee4a08bc7..fa16b2a7f5 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -53,6 +53,11 @@ import UniqSupply cgExpr :: StgExpr -> FCode () cgExpr (StgApp fun args) = cgIdApp fun args + +{- seq# a s ==> a -} +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = + cgIdApp a [] + cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr } @@ -322,6 +327,22 @@ cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ ; emit $ mkComment $ mkFastString "should be unreachable code" ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} +{- +case seq# a s of v + (# s', a' #) -> e + +==> + +case a of v + (# s', a' #) -> e + +(taking advantage of the fact that the return convention for (# State#, a #) +is the same as the return convention for just 'a') +-} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts + = -- handle seq#, same return convention as vanilla 'a'. + cgCase (StgApp a []) bndr srt alt_type alts + cgCase scrut bndr srt alt_type alts = -- the general case do { up_hp_usg <- getVirtHp -- Upstream heap usage diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index fae3bef016..4465e30b04 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -11,11 +11,11 @@ module StgCmmHpc ( initHpc, mkTickBox ) where import StgCmmMonad import MkGraph -import CmmDecl import CmmExpr import CLabel import Module import CmmUtils +import StgCmmUtils import HscTypes import StaticFlags @@ -36,9 +36,8 @@ initHpc _ (NoHpcInfo {}) = return () initHpc this_mod (HpcInfo tickCount _hashNo) = whenC opt_Hpc $ - do { emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] + do { emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0::Int ..] + ] } diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index eddf257e5f..278c41aef2 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -496,7 +496,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 (isStaticClosure cl_info) prof cl_type info) } + ; return (CmmInfoTable (closureInfoLocal 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/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index f92b3cde27..d06b581f26 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -593,7 +593,7 @@ emit ag = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } -emitData :: Section -> [CmmStatic] -> FCode () +emitData :: Section -> CmmStatics -> FCode () emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 1a6d05e6e6..c71d285735 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -210,6 +210,18 @@ emitPrimOp [res] ParOp [arg] (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] +emitPrimOp [res] SparkOp [arg] + = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + emitCCall + [] + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + emitPrimOp [res] ReadMutVarOp [mutv] = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 558b7fdeaa..74da7317d4 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -508,26 +508,26 @@ baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg) emitDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block emitRODataLits lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -543,7 +543,7 @@ mkByteStringCLit :: [Word8] -> FCode CmmLit mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 33017227b4..f5cd76254d 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -51,6 +51,7 @@ import VarSet import Var import TcType import Coercion +import Maybes( orElse ) import Util import BasicTypes( Activation ) import Outputable @@ -278,18 +279,16 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es -- | Those variables free in the right hand side of a rule ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule {}) = noFVs -ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) - = delFromUFM fvs fn -- Note [Rule free var hack] - where - fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + -- See Note [Rule free var hack] -- | Those variables free in the both the left right hand sides of a rule ruleFreeVars :: CoreRule -> VarSet ruleFreeVars (BuiltinRule {}) = noFVs -ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) - = delFromUFM fvs fn -- Note [Rule free var hack] - where - fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet +ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) + = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet + -- See Note [Rule free var hack] idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet -- Just the variables free on the *rhs* of a rule @@ -316,16 +315,16 @@ ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet \end{code} - -Note [Rule free var hack] +Note [Rule free var hack] (Not a hack any more) ~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't include the Id in its own rhs free-var set. -Otherwise the occurrence analyser makes bindings recursive -that shoudn't be. E.g. +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y RULE: f (f x y) z ==> f x (f y z) - -Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM. - +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. \begin{code} -- |Free variables of a vectorisation declaration @@ -445,13 +444,15 @@ idUnfoldingVars :: Id -> VarSet -- and we'll get exponential behaviour if we look at both unf and rhs! -- But do look at the *real* unfolding, even for loop breakers, else -- we might get out-of-scope variables -idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) - -stableUnfoldingVars :: Unfolding -> VarSet -stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src = exprFreeVars rhs -stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args) -stableUnfoldingVars _ = emptyVarSet +idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet + +stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet +stableUnfoldingVars fv_cand unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src -> Just (exprSomeFreeVars fv_cand rhs) + DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand args) + _other -> Nothing \end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 869f276c50..6a23b10002 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -182,7 +182,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars - ; when (isNonRuleLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) + ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) -- Only non-rule loop breakers inhibit inlining @@ -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 04057160b8..fdd92794bb 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -318,7 +318,7 @@ cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) - = do { (_, bndr1) <- cloneBndr env bndr + = do { (_, bndr1) <- cpCloneBndr env bndr ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive @@ -333,7 +333,7 @@ cpeBind top_lvl env (NonRec bndr rhs) cpeBind top_lvl env (Rec pairs) = do { let (bndrs,rhss) = unzip pairs - ; (env', bndrs1) <- cloneBndrs env (map fst pairs) + ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs) ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss ; let (floats_s, bndrs2, rhss2) = unzip3 stuff @@ -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 @@ -472,7 +473,7 @@ cpeRhsE env (Cast expr co) cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr - ; (env', bndrs') <- cloneBndrs env bndrs + ; (env', bndrs') <- cpCloneBndrs env bndrs ; body' <- cpeBodyNF env' body ; return (emptyFloats, mkLams bndrs' body') } @@ -485,12 +486,12 @@ cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding -- Record that the case binder is evaluated in the alternatives - ; (env', bndr2) <- cloneBndr env bndr1 + ; (env', bndr2) <- cpCloneBndr env bndr1 ; alts' <- mapM (sat_alt env') alts ; return (floats, Case scrut' bndr2 ty alts') } where sat_alt env (con, bs, rhs) - = do { (env2, bs') <- cloneBndrs env bs + = do { (env2, bs') <- cpCloneBndrs env bs ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } @@ -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) @@ -1074,11 +1075,11 @@ lookupCorePrepEnv (CPE env) id -- Cloning binders -- --------------------------------------------------------------------------- -cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) -cloneBndrs env bs = mapAccumLM cloneBndr env bs +cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs -cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) -cloneBndr env bndr +cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) +cpCloneBndr env bndr | isLocalId bndr, not (isCoVar bndr) = do bndr' <- setVarUnique bndr <$> getUniqueM diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 0c954a8927..ca0fbd5a52 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -8,7 +8,8 @@ Utility functions on @Core@ syntax \begin{code} module CoreSubst ( -- * Main data types - Subst, TvSubstEnv, IdSubstEnv, InScopeSet, + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types deShadowBinds, substSpec, substRulesForImportedIds, @@ -27,7 +28,7 @@ module CoreSubst ( -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, - cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, -- ** Simple expression optimiser simpleOptPgm, simpleOptExpr, simpleOptExprWith @@ -45,11 +46,12 @@ import qualified Coercion -- We are defining local versions import Type hiding ( substTy, extendTvSubst, extendTvSubstList - , isInScope, substTyVarBndr ) + , isInScope, substTyVarBndr, cloneTyVarBndr ) 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 import Id @@ -99,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 @@ -211,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 @@ -251,14 +253,15 @@ lookupIdSubst doc (Subst in_scope ids _ _) v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc) + | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v + $$ ppr in_scope) Var v -- | Find the substitution for a 'TyVar' in the 'Subst' 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 @@ -517,6 +520,16 @@ cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL clone subst (vs `zip` uniqsFromSupply us) + where + clone subst (v,uniq) + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + -- | Clone a mutually recursive group of 'Id's cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneRecIdBndrs subst us ids @@ -558,6 +571,12 @@ substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv (TvSubst in_scope' tv_env', tv') -> (Subst in_scope' id_env tv_env' cv_env, tv') +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq + = case Type.cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq of + (TvSubst in_scope' tv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env, tv') + substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of @@ -623,7 +642,7 @@ substUnfoldingSC subst unf -- Short-cut version substUnfolding subst (DFunUnfolding ar con args) = DFunUnfolding ar con (map subst_arg args) where - subst_arg = fmap (substExpr (text "dfun-unf") subst) + subst_arg = substExpr (text "dfun-unf") subst substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! @@ -776,15 +795,16 @@ simpleOptExprWith :: Subst -> InExpr -> OutExpr simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr) ---------------------- -simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> [CoreVect] +simpleOptPgm :: DynFlags -> Module + -> [CoreBind] -> [CoreRule] -> [CoreVect] -> IO ([CoreBind], [CoreRule], [CoreVect]) -simpleOptPgm dflags binds rules vects +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 - occ_anald_binds = occurAnalysePgm Nothing {- No rules active -} + occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} rules vects binds (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 7582481091..ccb87e7782 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -39,7 +39,6 @@ module CoreSyn ( -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - DFunArg(..), dfunArgExprs, -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, @@ -142,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. @@ -459,7 +470,7 @@ data Unfolding DataCon -- The dictionary data constructor (possibly a newtype datacon) - [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order + [CoreExpr] -- Specification of superclasses and methods, in positional order | CoreUnfolding { -- An unfolding for an Id with no pragma, -- or perhaps a NOINLINE pragma @@ -497,21 +508,6 @@ data Unfolding -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ -data DFunArg e -- Given (df a b d1 d2 d3) - = DFunPolyArg e -- Arg is (e a b d1 d2 d3) - | DFunConstArg e -- Arg is e, which is constant - deriving( Functor ) - - -- 'e' is often CoreExpr, which are usually variables, but can - -- be trivial expressions instead (e.g. a type application). - -dfunArgExprs :: [DFunArg e] -> [e] -dfunArgExprs [] = [] -dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as -dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as - - ------------------------------------------------- data UnfoldingSource = InlineRhs -- The current rhs of the function -- Replace uf_tmpl each time around diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index 377bfd8c84..110fd72701 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -198,7 +198,7 @@ tidyIdBndr env@(tidy_env, var_env) id ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding tidyUnfolding tidy_env (DFunUnfolding ar con ids) _ - = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) ids) + = DFunUnfolding ar con (map (tidyExpr tidy_env) ids) tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index fe3772c2a8..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 @@ -93,7 +93,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr) mkSimpleUnfolding :: CoreExpr -> Unfolding mkSimpleUnfolding = mkUnfolding InlineRhs False False -mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding +mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops = DFunUnfolding dfun_nargs data_con ops where @@ -813,7 +813,9 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info | active_unfolding -> tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top is_cheap is_exp uf_arity guidance - | otherwise -> Nothing + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + -> pprTrace "Inactive unfolding:" (ppr id) Nothing + | otherwise -> Nothing NoUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun @@ -1210,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) -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 + -- 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 + + 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 @@ -1260,72 +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 (DFunConstArg e) = e - mk_arg (DFunPolyArg 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/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 9f0b674238..55315c99ea 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -1229,10 +1229,10 @@ hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_ha hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e hash_expr env (Case e _ _ _) = hash_expr env e hash_expr env (Lam b e) = hash_expr (extend_env env b) e +hash_expr env (Coercion co) = fast_hash_co env co hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1 -- Shouldn't happen. Better to use WARN than trace, because trace -- prevents the CPR optimisation kicking in for hash_expr. -hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1 fast_hash_expr :: HashEnv -> CoreExpr -> Word32 fast_hash_expr env (Var v) = hashVar env v @@ -1391,7 +1391,7 @@ tryEtaReduce bndrs body --------------- fun_arity fun -- See Note [Arity care] - | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0 + | isLocalId fun && isStrongLoopBreaker (idOccInfo fun) = 0 | otherwise = idArity fun --------------- @@ -1493,16 +1493,14 @@ rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool rhsIsStatic _is_dynamic_name rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool + -> CoreExpr -> Bool - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Note n e) = notSccNote n && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e - - is_static _ (Lit lit) - = case lit of - MachLabel _ _ _ -> False - _ -> True + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Note n e) = notSccNote n && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e + is_static _ (Coercion {}) = True -- Behaves just like a literal + is_static _ (Lit (MachLabel {})) = False + is_static _ (Lit _) = True -- A MachLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The -- reason is that it might give rise to unresolvable symbols diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 8d0239d8e4..58a940c72a 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -271,38 +271,39 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprTypedBinder binder $$ + | otherwise = pprTypedLetBinder binder $$ ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> - pprTypedLCBinder bind_site (debugStyle sty) bndr + pprTypedLamBinder bind_site (debugStyle sty) bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder -pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc -- For lambda and case binders, show the unfolding info (usually none) -pprTypedLCBinder bind_site debug_on var +pprTypedLamBinder bind_site debug_on var | not debug_on && isDeadBinder var = char '_' | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info + | opt_SuppressAll = pprUntypedBinder var -- Suppress the signature | isTyVar var = parens (pprKindedTyVarBndr var) | otherwise = parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) - where - unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info - | otherwise = empty + where + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info + | otherwise = empty -pprTypedBinder :: Var -> SDoc +pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) -pprTypedBinder binder - | isTyVar binder = pprKindedTyVarBndr binder - | opt_SuppressTypeSignatures = empty - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) +pprTypedLetBinder binder + | isTyVar binder = pprKindedTyVarBndr binder + | opt_SuppressTypeSignatures = pprIdBndr binder + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -438,10 +439,6 @@ instance Outputable Unfolding where | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! - -instance Outputable e => Outputable (DFunArg e) where - ppr (DFunPolyArg e) = braces (ppr e) - ppr (DFunConstArg e) = ppr e \end{code} ----------------------------------------------------- @@ -463,7 +460,8 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)), + 4 (sep [ptext (sLit "forall") <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) ]) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index fbe1ab9a45..6f2e08afff 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -364,20 +364,6 @@ addTickHsExpr (HsWrap w e) = (return w) (addTickHsExpr e) -- explicitly no tick on inside -addTickHsExpr (HsArrApp e1 e2 ty1 arr_ty lr) = - liftM5 HsArrApp - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return arr_ty) - (return lr) - -addTickHsExpr (HsArrForm e fix cmdtop) = - liftM3 HsArrForm - (addTickLHsExpr e) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) - addTickHsExpr e@(HsType _) = return e -- Others dhould never happen in expression content. @@ -544,8 +530,8 @@ addTickLHsCmd (L pos c0) = do addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) addTickHsCmd (HsLam matchgroup) = liftM HsLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsApp e1 e2) = - liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) +addTickHsCmd (HsApp c e) = + liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp (addTickLHsExpr e1) @@ -854,7 +840,12 @@ mkHpcPos pos@(RealSrcSpan s) | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndLine s, - srcSpanEndCol s) + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" hpcSrcSpan :: SrcSpan diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index af2db3697b..2f265221e8 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -61,7 +61,8 @@ deSugar hsc_env tcg_imports = imports, tcg_exports = exports, tcg_keep = keep_var, - tcg_rdr_env = rdr_env, + tcg_th_splice_used = tc_splice_used, + tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, @@ -138,7 +139,7 @@ deSugar hsc_env , pprRules rules_for_imps ]) ; (ds_binds, ds_rules_for_imps, ds_vects) - <- simpleOptPgm dflags final_pgm rules_for_imps vects0 + <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code @@ -147,13 +148,16 @@ deSugar hsc_env ; let used_names = mkUsedNames tcg_env ; deps <- mkDependencies tcg_env - ; let mod_guts = ModGuts { + ; used_th <- readIORef tc_splice_used + + ; let mod_guts = ModGuts { mg_module = mod, mg_boot = isHsBoot hsc_src, mg_exports = exports, mg_deps = deps, mg_used_names = used_names, - mg_dir_imps = imp_mods imports, + mg_used_th = used_th, + mg_dir_imps = imp_mods imports, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_warns = warns, @@ -169,7 +173,8 @@ deSugar hsc_env mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, - mg_vect_info = noVectInfo + mg_vect_info = noVectInfo, + mg_trust_pkg = imp_trust_own_pkg imports } ; return (msgs, Just mod_guts) }}} @@ -345,8 +350,8 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- unsetOptM Opt_EnableRewriteRules $ - unsetOptM Opt_WarnIdentities $ + ; lhs' <- unsetDOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ dsLExpr lhs -- Note [Desugaring RULE left hand sides] ; rhs' <- dsLExpr rhs diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 39e7e298ab..a878e74c6b 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -517,8 +517,11 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) ; let spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id - | otherwise = spec_inl + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = idInlinePragma poly_id -- Get the INLINE pragma from SPECIALISE declaration, or, -- failing that, from the original Id diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index e33b113ae7..a68214d1b1 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -217,7 +217,7 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar var) = return (Var var) +dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit @@ -225,7 +225,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn ; e' <- dsExpr e - ; warn_id <- doptDs Opt_WarnIdentities + ; warn_id <- woptDs Opt_WarnIdentities ; when warn_id $ warnAboutIdentities e' co_fn' ; return (co_fn' e') } @@ -239,6 +239,22 @@ dsExpr (HsApp fun arg) = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg \end{code} +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. + Operator sections. At first it looks as if we can convert \begin{verbatim} (expr op) @@ -814,13 +830,13 @@ warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () warnDiscardedDoBindings rhs rhs_ty | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty = do { -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind + ; warn_unused <- woptDs Opt_WarnUnusedDoBind ; if warn_unused && not (isUnitTy elt_ty) then warnDs (unusedMonadBind rhs elt_ty) else -- Warn about discarding m a things in 'monadic' binding of the same type, -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - do { warn_wrong <- doptDs Opt_WarnWrongDoBind + do { warn_wrong <- woptDs Opt_WarnWrongDoBind ; case tcSplitAppTy_maybe elt_ty of Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty -> warnDs (wrongMonadBind rhs elt_ty) diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index b391b8f02a..6d73d1d2bb 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -40,6 +40,8 @@ import BasicTypes import SrcLoc import Outputable import FastString +import DynFlags +import Platform import Config import Constants import OrdList @@ -298,8 +300,9 @@ dsFExport fn_id ty ext_name cconv isDyn= do Nothing -> return (orig_res_ty, False) -- The function returns t + dflags <- getDOpts return $ - mkFExportCBits ext_name + mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv \end{code} @@ -420,7 +423,8 @@ The C stub constructs the application of the exported Haskell function using the hugs/ghc rts invocation API. \begin{code} -mkFExportCBits :: FastString +mkFExportCBits :: DynFlags + -> FastString -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type @@ -431,7 +435,7 @@ mkFExportCBits :: FastString String, -- the argument reps Int -- total size of arguments ) -mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc = (header_bits, c_bits, type_string, sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args -- NB. the calculation here isn't strictly speaking correct. @@ -474,7 +478,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc -- add some auxiliary args; the stable ptr in the wrapper case, and -- a slot for the dummy return address in the wrapper + ccall case aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info | otherwise = arg_info stable_ptr_arg = @@ -627,26 +631,27 @@ typeTyCon ty = case tcSplitTyConApp_maybe (repType ty) of Just (tc,_) -> tc Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty) -insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -#if !defined(x86_64_TARGET_ARCH) -insertRetAddr CCallConv args = ret_addr_arg : args -insertRetAddr _ args = args -#else --- On x86_64 we insert the return address after the 6th --- integer argument, because this is the point at which we --- need to flush a register argument to the stack (See rts/Adjustor.c for --- details). -insertRetAddr CCallConv args = go 0 args - where go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] -insertRetAddr _ args = args -#endif +insertRetAddr :: DynFlags -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr dflags CCallConv args + = case platformArch (targetPlatform dflags) of + ArchX86_64 -> + -- On x86_64 we insert the return address after the 6th + -- integer argument, because this is the point at which we + -- need to flush a register argument to the stack (See + -- rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg : args +insertRetAddr _ _ args = args ret_addr_arg :: (SDoc, SDoc, Type, CmmType) ret_addr_arg = (text "original_return_addr", text "void*", undefined, diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 3988105e90..8d0082ad21 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -351,8 +351,7 @@ repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] repSafety PlayInterruptible = rep2 interruptibleName [] -repSafety (PlaySafe False) = rep2 safeName [] -repSafety (PlaySafe True) = rep2 threadsafeName [] +repSafety PlaySafe = rep2 safeName [] ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -435,8 +434,9 @@ repBangTy ty= do rep2 strictTypeName [s, t] where (str, ty') = case ty of - L _ (HsBangTy _ ty) -> (isStrictName, ty) - _ -> (notStrictName, ty) + L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty) + L _ (HsBangTy _ ty) -> (isStrictName, ty) + _ -> (notStrictName, ty) ------------------------------------------------------- -- Deriving clause @@ -1778,7 +1778,7 @@ templateHaskellNames = [ -- Pred classPName, equalPName, -- Strict - isStrictName, notStrictName, + isStrictName, notStrictName, unpackedName, -- Con normalCName, recCName, infixCName, forallCName, -- StrictType @@ -1797,7 +1797,6 @@ templateHaskellNames = [ -- Safety unsafeName, safeName, - threadsafeName, interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, @@ -1998,9 +1997,10 @@ classPName = libFun (fsLit "classP") classPIdKey equalPName = libFun (fsLit "equalP") equalPIdKey -- data Strict = ... -isStrictName, notStrictName :: Name +isStrictName, notStrictName, unpackedName :: Name isStrictName = libFun (fsLit "isStrict") isStrictKey notStrictName = libFun (fsLit "notStrict") notStrictKey +unpackedName = libFun (fsLit "unpacked") unpackedKey -- data Con = ... normalCName, recCName, infixCName, forallCName :: Name @@ -2046,10 +2046,9 @@ cCallName = libFun (fsLit "cCall") cCallIdKey stdCallName = libFun (fsLit "stdCall") stdCallIdKey -- data Safety = ... -unsafeName, safeName, threadsafeName, interruptibleName :: Name +unsafeName, safeName, interruptibleName :: Name unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey -threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey -- data InlineSpec = ... @@ -2280,9 +2279,10 @@ classPIdKey = mkPreludeMiscIdUnique 361 equalPIdKey = mkPreludeMiscIdUnique 362 -- data Strict = ... -isStrictKey, notStrictKey :: Unique +isStrictKey, notStrictKey, unpackedKey :: Unique isStrictKey = mkPreludeMiscIdUnique 363 notStrictKey = mkPreludeMiscIdUnique 364 +unpackedKey = mkPreludeMiscIdUnique 365 -- data Con = ... normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique @@ -2328,10 +2328,9 @@ cCallIdKey = mkPreludeMiscIdUnique 394 stdCallIdKey = mkPreludeMiscIdUnique 395 -- data Safety = ... -unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique unsafeIdKey = mkPreludeMiscIdUnique 400 safeIdKey = mkPreludeMiscIdUnique 401 -threadsafeIdKey = mkPreludeMiscIdUnique 402 interruptibleIdKey = mkPreludeMiscIdUnique 403 -- data InlineSpec = diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 62e805334e..1dd347be98 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -9,7 +9,7 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifDOptM, unsetOptM, + foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM, Applicative(..),(<$>), newLocalName, @@ -20,7 +20,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, + getDOptsDs, getGhcModeDs, doptDs, woptDs, dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, dsLookupClass, @@ -257,6 +257,9 @@ getDOptsDs = getDOpts doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs = doptM +woptDs :: WarningFlag -> TcRnIf gbl lcl Bool +woptDs = woptM + getGhcModeDs :: DsM GhcMode getGhcModeDs = getDOptsDs >>= return . ghcMode diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index 1a044d3471..25dab9370c 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -74,18 +74,18 @@ matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs where (pats, eqns_shadow) = check qs incomplete = incomplete_flag hs_ctx && (notNull pats) - shadow = dopt Opt_WarnOverlappingPatterns dflags + shadow = wopt Opt_WarnOverlappingPatterns dflags && notNull eqns_shadow incomplete_flag :: HsMatchContext id -> Bool - incomplete_flag (FunRhs {}) = dopt Opt_WarnIncompletePatterns dflags - incomplete_flag CaseAlt = dopt Opt_WarnIncompletePatterns dflags + incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags - incomplete_flag LambdaExpr = dopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag PatBindRhs = dopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag ProcExpr = dopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags - incomplete_flag RecUpd = dopt Opt_WarnIncompletePatternsRecUpd dflags + incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags incomplete_flag ThPatQuote = False incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 0bd2538937..173bad999c 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -65,6 +65,8 @@ dsLit (HsStringPrim s) = return (Lit (MachStr s)) dsLit (HsCharPrim c) = return (Lit (MachChar c)) dsLit (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsWordPrim w) = return (Lit (MachWord w)) +dsLit (HsInt64Prim i) = return (Lit (MachInt64 i)) +dsLit (HsWord64Prim w) = return (Lit (MachWord64 w)) dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) @@ -111,6 +113,8 @@ hsLitKey :: HsLit -> Literal -- others have been removed by tidy hsLitKey (HsIntPrim i) = mkMachInt i hsLitKey (HsWordPrim w) = mkMachWord w +hsLitKey (HsInt64Prim i) = mkMachInt64 i +hsLitKey (HsWord64Prim w) = mkMachWord64 w hsLitKey (HsCharPrim c) = MachChar c hsLitKey (HsStringPrim s) = MachStr s hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2711c1b20e..8ac0eeae80 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -63,7 +63,7 @@ Library if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, bytestring >= 0.9 && < 0.10, old-time >= 1 && < 1.1, containers >= 0.1 && < 0.5, diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 8ed34c3136..1a7fa07219 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -94,8 +94,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cLeadingUnderscore = "$(LeadingUnderscore)"' >> $@ @echo 'cRAWCPP_FLAGS :: String' >> $@ @echo 'cRAWCPP_FLAGS = "$(RAWCPP_FLAGS)"' >> $@ - @echo 'cMKDLL :: String' >> $@ - @echo 'cMKDLL = "$(BLD_DLL)"' >> $@ @echo 'cLdIsGNULd :: String' >> $@ @echo 'cLdIsGNULd = "$(LdIsGNULd)"' >> $@ @echo 'cLdHasBuildId :: String' >> $@ @@ -104,10 +102,6 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/. @echo 'cLD_X = "$(LD_X)"' >> $@ @echo 'cGHC_DRIVER_DIR :: String' >> $@ @echo 'cGHC_DRIVER_DIR = "$(GHC_DRIVER_DIR)"' >> $@ - @echo 'cGHC_TOUCHY_PGM :: String' >> $@ - @echo 'cGHC_TOUCHY_PGM = "$(GHC_TOUCHY_PGM)"' >> $@ - @echo 'cGHC_TOUCHY_DIR :: String' >> $@ - @echo 'cGHC_TOUCHY_DIR = "$(GHC_TOUCHY_DIR)"' >> $@ @echo 'cGHC_UNLIT_PGM :: String' >> $@ @echo 'cGHC_UNLIT_PGM = "$(GHC_UNLIT_PGM)"' >> $@ @echo 'cGHC_UNLIT_DIR :: String' >> $@ diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 426f4f251b..cd4b60da27 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -344,6 +344,17 @@ instance Outputable TickInfo where parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+> ppr (tickInfo_locals info)) +returnUnboxedAtom :: Word16 -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> CgRep + -> BcM BCInstrList +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnboxedAtom d s p e e_rep + = do (push, szw) <- pushAtom d p e + return (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX e_rep) -- go + -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList @@ -353,31 +364,16 @@ schemeE d s p e = schemeE d s p e' -- Delegate tail-calls to schemeT. -schemeE d s p e@(AnnApp _ _) - = schemeT d s p e +schemeE d s p e@(AnnApp _ _) = schemeT d s p e -schemeE d s p e@(AnnVar v) - | not (isUnLiftedType v_type) - = -- Lifted-type thing; push it in the normal way - schemeT d s p e +schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeCgRep (literalType lit)) +schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg - | otherwise - = do -- Returning an unlifted value. - -- Heave it on the stack, SLIDE, and RETURN. - (push, szw) <- pushAtom d p (AnnVar v) - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX v_rep) -- go +schemeE d s p e@(AnnVar v) + | isUnLiftedType v_type = returnUnboxedAtom d s p e (typeCgRep v_type) + | otherwise = schemeT d s p e where - v_type = idType v - v_rep = typeCgRep v_type - -schemeE d s p (AnnLit literal) - = do (push, szw) <- pushAtom d p (AnnLit literal) - let l_rep = typeCgRep (literalType literal) - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX l_rep) -- go + v_type = idType v schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, @@ -1236,13 +1232,14 @@ pushAtom _ _ (AnnLit lit) = case lit of MachLabel _ _ _ -> code NonPtrArg MachWord _ -> code NonPtrArg - MachInt _ -> code PtrArg + MachInt _ -> code NonPtrArg + MachWord64 _ -> code LongArg + MachInt64 _ -> code LongArg MachFloat _ -> code FloatArg MachDouble _ -> code DoubleArg MachChar _ -> code NonPtrArg MachNullAddr -> code NonPtrArg MachStr s -> pushStr s - l -> pprPanic "pushAtom" (ppr l) where code rep = let size_host_words = fromIntegral (cgRepSizeW rep) diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 90ec0b3a1f..8b56c4f3ae 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -1093,26 +1093,18 @@ linkPackage dflags pkg classifieds <- mapM (locateOneObj dirs) libs' -- Complication: all the .so's must be loaded before any of the .o's. - let dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] - archs = [ arch | Archive arch <- classifieds ] + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Object obj <- classifieds ] + archs = [ arch | Archive arch <- classifieds ] maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") -- See comments with partOfGHCi when (packageName pkg `notElem` partOfGHCi) $ do loadFrameworks pkg - -- When a library A needs symbols from a library B, the order in - -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the - -- way ld expects it for static linking. Dynamic linking is a - -- different story: When A has no dependency information for B, - -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail - -- when B has not been loaded before. In a nutshell: Reverse the - -- order of DLLs for dynamic linking. - -- This fixes a problem with the HOpenGL package (see "Compiling - -- HOpenGL under recent versions of GHC" on the HOpenGL list). - mapM_ (load_dyn dirs) (reverse dlls) - + mapM_ load_dyn (known_dlls ++ map mkSOName dlls) + -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link -- step to resolve everything. @@ -1124,12 +1116,17 @@ linkPackage dflags pkg if succeeded ok then maybePutStrLn dflags "done." else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) -load_dyn :: [FilePath] -> FilePath -> IO () -load_dyn dirs dll = do r <- loadDynamic dirs dll - case r of - Nothing -> return () - Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +-- +load_dyn :: FilePath -> IO () +load_dyn dll = do r <- loadDLL dll + case r of + Nothing -> return () + Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " + ++ dll ++ " (" ++ err ++ ")" )) loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () loadFrameworks pkg @@ -1168,7 +1165,7 @@ locateOneObj dirs lib mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name findObject = liftM (fmap Object) $ findFile mk_obj_path dirs findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs - findDll = liftM (fmap DLL) $ findFile mk_dyn_lib_path dirs + findDll = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path dirs assumeDll = return (DLL lib) infixr `orElse` f `orElse` g = do m <- f diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 7b0d8c4f0d..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) @@ -336,6 +339,7 @@ cvtConstr (ForallC tvs ctxt con) cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' } cvt_arg (NotStrict, ty) = cvtType ty +cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' } cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) cvt_id_arg (i, str, ty) @@ -374,8 +378,7 @@ cvtForD (ImportF callconv safety from nm ty) where safety' = case safety of Unsafe -> PlayRisky - Safe -> PlaySafe False - Threadsafe -> PlaySafe True + Safe -> PlaySafe Interruptible -> PlayInterruptible cvtForD (ExportF callconv as nm ty) @@ -463,9 +466,10 @@ 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 [e]) = cvt e -- Singleton tuples treated like nothing (just parens) 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; ; return $ HsIf (Just noSyntaxExpr) x' y' z' } @@ -482,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 @@ -502,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 @@ -513,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 ------------------------------------- @@ -624,34 +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 } -cvtp (UnboxedTupP [p]) = cvtp p + | 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 @@ -710,8 +819,6 @@ cvtType ty -> if n==1 then return (head tys') -- Singleton tuples treated -- like nothing (ie just parens) else returnL (HsTupleTy Unboxed tys') - | n == 1 - -> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor")) | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' ArrowT diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 52ed14b9f2..fcba55af81 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -148,8 +148,8 @@ data HsBindLR idL idR abs_ev_vars :: [EvVar], -- Includes equality constraints -- AbsBinds only gets used when idL = idR after renaming, - -- but these need to be idL's for the collect... code in HsUtil to have - -- the right type + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type abs_exports :: [([TyVar], idL, idL, TcSpecPrags)], -- (tvs, poly_id, mono_id, prags) abs_ev_binds :: TcEvBinds, -- Evidence bindings @@ -378,7 +378,7 @@ data HsWrapper = WpHole -- The identity coercion | WpCompose HsWrapper HsWrapper - -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]] + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] -- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 3712cbd9f7..9d3382fd8a 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -716,10 +716,13 @@ data ConDecl name , con_qvars :: [LHsTyVarBndr name] -- ^ Type variables. Depending on 'con_res' this describes the - -- follewing entities + -- following entities -- -- - ResTyH98: the constructor's *existential* type variables -- - ResTyGADT: *all* the constructor's quantified type variables + -- + -- If con_explicit is Implicit, then con_qvars is irrelevant + -- until after renaming. , con_cxt :: LHsContext name -- ^ The context. This /does not/ include the \"stupid theta\" which diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index dd33cae373..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 @@ -376,7 +398,7 @@ ppr_expr (OpApp e1 op _ e2) = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2] + = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e @@ -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 @@ -672,7 +697,6 @@ type HsRecordBinds id = HsRecFields id (LHsExpr id) \end{code} - %************************************************************************ %* * \subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} @@ -920,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/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 2cda103479..2b556ea7aa 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -37,8 +37,10 @@ data HsLit | HsStringPrim FastString -- Packed string | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION - | HsIntPrim Integer -- Unboxed Int - | HsWordPrim Integer -- Unboxed Word + | HsIntPrim Integer -- literal Int# + | HsWordPrim Integer -- literal Word# + | HsInt64Prim Integer -- literal Int64# + | HsWord64Prim Integer -- literal Word64# | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION @@ -55,6 +57,8 @@ instance Eq HsLit where (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 (HsWordPrim x1) == (HsWordPrim x2) = x1==x2 + (HsInt64Prim x1) == (HsInt64Prim x2) = x1==x2 + (HsWord64Prim x1) == (HsWord64Prim x2) = x1==x2 (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 @@ -148,6 +152,8 @@ instance Outputable HsLit where ppr (HsDoublePrim d) = ppr d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' ppr (HsWordPrim w) = integer w <> text "##" + ppr (HsInt64Prim i) = integer i <> text "L#" + ppr (HsWord64Prim w) = integer w <> text "L##" -- in debug mode, print the expression that it's resolved to, too instance OutputableBndr id => Outputable (HsOverLit id) where 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/BinIface.hs b/compiler/iface/BinIface.hs index 1e24f34dd3..336030cf0d 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -18,7 +18,6 @@ import HscTypes import BasicTypes import Demand import Annotations -import CoreSyn import IfaceSyn import Module import Name @@ -381,7 +380,8 @@ instance Binary ModIface where mi_usages = usages, mi_exports = exports, mi_exp_hash = exp_hash, - mi_fixities = fixities, + mi_used_th = used_th, + mi_fixities = fixities, mi_warns = warns, mi_anns = anns, mi_decls = decls, @@ -390,8 +390,9 @@ instance Binary ModIface where mi_rules = rules, mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, - mi_hpc = hpc_info, - mi_trust = trust }) = do + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do put_ bh mod put_ bh is_boot put_ bh iface_hash @@ -402,7 +403,8 @@ instance Binary ModIface where lazyPut bh usages put_ bh exports put_ bh exp_hash - put_ bh fixities + put_ bh used_th + put_ bh fixities lazyPut bh warns lazyPut bh anns put_ bh decls @@ -413,6 +415,7 @@ instance Binary ModIface where put_ bh vect_info put_ bh hpc_info put_ bh trust + put_ bh trust_pkg get bh = do mod_name <- get bh @@ -425,7 +428,8 @@ instance Binary ModIface where usages <- {-# SCC "bin_usages" #-} lazyGet bh exports <- {-# SCC "bin_exports" #-} get bh exp_hash <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh @@ -436,6 +440,7 @@ instance Binary ModIface where vect_info <- get bh hpc_info <- get bh trust <- get bh + trust_pkg <- get bh return (ModIface { mi_module = mod_name, mi_boot = is_boot, @@ -446,8 +451,9 @@ instance Binary ModIface where mi_deps = deps, mi_usages = usages, mi_exports = exports, - mi_exp_hash = exp_hash, - mi_anns = anns, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, mi_fixities = fixities, mi_warns = warns, mi_decls = decls, @@ -459,6 +465,7 @@ instance Binary ModIface where mi_vect_info = vect_info, mi_hpc = hpc_info, mi_trust = trust, + mi_trust_pkg = trust_pkg, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, @@ -1273,14 +1280,6 @@ instance Binary IfaceUnfolding where _ -> do e <- get bh return (IfCompulsory e) -instance Binary (DFunArg IfaceExpr) where - put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e - put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e - get bh = do { h <- getByte bh - ; case h of - 0 -> do { a <- get bh; return (DFunPolyArg a) } - _ -> do { a <- get bh; return (DFunConstArg a) } } - instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index eabe8c45aa..b9a6ab9352 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -30,7 +30,7 @@ import Type import Coercion import TcRnMonad -import Data.List ( partition ) +import Util ( isSingleton ) import Outputable \end{code} @@ -248,12 +248,9 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec ; op_items <- mapM (mk_op_item rec_clas) sig_stuff -- Build the selector id and default method id - ; let (eq_theta, dict_theta) = partition isEqPred sc_theta - - -- We only make selectors for the *value* superclasses, - -- not equality predicates + -- Make selectors for the superclasses ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) - [1..length dict_theta] + [1..length sc_theta] ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names] -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we @@ -264,22 +261,23 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1) - -- Use a newtype if the data constructor has - -- (a) exactly one value field - -- (b) no existential or equality-predicate fields - -- i.e. exactly one operation or superclass taken together + ; let use_newtype = isSingleton arg_tys && not (any isEqPred sc_theta) + -- Use a newtype if the data constructor + -- (a) has exactly one value field + -- i.e. exactly one operation or superclass taken together + -- (b) it's of lifted type + -- (NB: for (b) don't look at the classes in sc_theta, because + -- they are part of the knot! Hence isEqPred.) -- See note [Class newtypes and equality predicates] - -- We play a bit fast and loose by treating the dictionary - -- superclasses as ordinary arguments. That means that in - -- the case of + -- We treat the dictionary superclasses as ordinary arguments. + -- That means that in the case of -- class C a => D a -- we don't get a newtype with no arguments! args = sc_sel_names ++ op_names op_tys = [ty | (_,_,ty) <- sig_stuff] op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = map mkPredTy dict_theta ++ op_tys + arg_tys = map mkPredTy sc_theta ++ op_tys rec_tycon = classTyCon rec_clas ; dict_con <- buildDataCon datacon_name @@ -288,7 +286,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec [{- No fields -}] tvs [{- no existentials -}] [{- No GADT equalities -}] - eq_theta + [{- No theta -}] arg_tys (mkTyConApp rec_tycon (mkTyVarTys tvs)) rec_tycon @@ -312,9 +310,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec ; atTyCons = [tycon | ATyCon tycon <- ats] ; result = mkClass class_name tvs fds - (eq_theta ++ dict_theta) -- Equalities first - (length eq_theta) -- Number of equalities - sc_sel_ids atTyCons + sc_theta sc_sel_ids atTyCons op_items tycon } ; traceIf (text "buildClass" <+> ppr tycon) @@ -339,12 +335,12 @@ Consider op :: a -> b We cannot represent this by a newtype, even though it's not -existential, and there's only one value field, because we do -capture an equality predicate: - - data C a b where - MkC :: forall a b. (a ~ F b) => (a->b) -> C a b - -We need to access this equality predicate when we get passes a C -dictionary. See Trac #2238 +existential, because there are two value fields (the equality +predicate and op. See Trac #2238 + +Moreover, + class (a ~ F b) => C a b where {} +Here we can't use a newtype either, even though there is only +one field, because equality predicates are unboxed, and classes +are boxed. diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 41732a9215..8ca6b392ae 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -27,8 +27,6 @@ module IfaceSyn ( #include "HsVersions.h" import IfaceType -import CoreSyn( DFunArg, dfunArgExprs ) -import PprCore() -- Printing DFunArgs import Demand import Annotations import Class @@ -197,7 +195,7 @@ data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs @@ -220,7 +218,7 @@ data IfaceUnfolding | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in -- another module. - | IfDFunUnfold [DFunArg IfaceExpr] + | IfDFunUnfold [IfaceExpr] -------------------------------- data IfaceExpr @@ -316,43 +314,7 @@ defined.) Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Now consider versioning. If we *use* an instance decl in one compilation, -we'll depend on the dfun id for that instance, so we'll recompile if it changes. -But suppose we *don't* (currently) use an instance! We must recompile if -the instance is changed in such a way that it becomes important. (This would -only matter with overlapping instances, else the importing module wouldn't have -compiled before and the recompilation check is irrelevant.) - -The is_orph field is set to (Just n) if the instance is not an orphan. -The 'n' is *any* of the locally-defined names mentioned anywhere in the -instance head. This name is used for versioning; the instance decl is -considered part of the defn of this 'n'. - -I'm worried about whether this works right if we pick a name from -a functionally-dependent part of the instance decl. E.g. - - module M where { class C a b | a -> b } - -and suppose we are compiling module X: - - module X where - import M - data S = ... - data T = ... - instance C S T where ... - -If we base the instance version on T, I'm worried that changing S to S' -would change T's version, but not S or S'. But an importing module might -not depend on T, and so might not be recompiled even though the new instance -(C S' T) might be relevant. I have not been able to make a concrete example, -and it seems deeply obscure, so I'm going to leave it for now. - - -Note [Versioning of rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A rule that is not an orphan has an ifRuleOrph field of (Just n), where n -appears on the LHS of the rule; any change in the rule changes the version of n. - +See [http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances] \begin{code} -- ----------------------------------------------------------------------------- @@ -826,7 +788,7 @@ freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v 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/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index daa0bb0284..9b7a40fb3a 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -655,6 +655,7 @@ pprModIface iface , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) + , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (ptext (sLit "where")) , vcat (map pprExport (mi_exports iface)) , pprDeps (mi_deps iface) @@ -669,6 +670,7 @@ pprModIface iface , pprVectInfo (mi_vect_info iface) , ppr (mi_warns iface) , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) ] where pp_boot | mi_boot iface = ptext (sLit "[boot]") @@ -756,6 +758,9 @@ pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars pprTrustInfo :: IfaceTrustInfo -> SDoc pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg + instance Outputable Warnings where ppr = pprWarns diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 42a4278b4f..7e1a4631a5 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -123,18 +123,20 @@ mkIface :: HscEnv -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_used_names = used_names, - mg_deps = deps, - mg_dir_imps = dir_imp_mods, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info } + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_used_th = used_th, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_trust_pkg = self_trust } = mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env - fix_env warns hpc_info dir_imp_mods mod_details + this_mod is_boot used_names used_th deps rdr_env fix_env + warns hpc_info dir_imp_mods self_trust mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any @@ -151,20 +153,25 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, tcg_warns = warns, - tcg_hpc = other_hpc_info + tcg_hpc = other_hpc_info, + tcg_th_splice_used = tc_splice_used } = do let used_names = mkUsedNames tc_result deps <- mkDependencies tc_result let hpc_info = emptyHpcInfo other_hpc_info + used_th <- readIORef tc_splice_used mkIface_ hsc_env maybe_old_fingerprint - this_mod (isHsBoot hsc_src) used_names deps rdr_env - fix_env warns hpc_info (imp_mods imports) mod_details + this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env + fix_env warns hpc_info (imp_mods imports) + (imp_trust_own_pkg imports) mod_details mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies TcGblEnv{ tcg_mod = mod, @@ -172,9 +179,9 @@ mkDependencies tcg_th_used = th_var } = do - th_used <- readIORef th_var -- Whether TH is used - let - dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) + -- Template Haskell used? + th_used <- readIORef th_var + let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -182,30 +189,31 @@ mkDependencies -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) - | otherwise = imp_dep_pkgs imports + pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports - -- add in safe haskell 'package needs to be safe' bool - sorted_pkgs = sortBy stablePackageIdCmp pkgs - trust_pkgs = imp_trust_pkgs imports - dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + sorted_pkgs = sortBy stablePackageIdCmp pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, dep_pkgs = dep_pkgs', dep_orphs = sortBy stableModuleCmp (imp_orphs imports), dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } - -- sort to get into canonical order - -- NB. remember to use lexicographic ordering + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface - -> NameSet -> Dependencies -> GlobalRdrEnv + -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings -> HpcInfo - -> ImportedMods + -> ImportedMods -> Bool -> ModDetails - -> IO (Messages, Maybe (ModIface, Bool)) + -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info - dir_imp_mods + this_mod is_boot used_names used_th deps rdr_env fix_env src_warns + hpc_info dir_imp_mods pkg_trust_req ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -232,7 +240,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- Sigh: see Note [Root-main Id] in TcRnDriver ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - ; warns = src_warns + ; warns = src_warns ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts @@ -263,7 +271,8 @@ mkIface_ hsc_env maybe_old_fingerprint mi_iface_hash = fingerprint0, mi_mod_hash = fingerprint0, mi_exp_hash = fingerprint0, - mi_orphan_hash = fingerprint0, + mi_used_th = used_th, + mi_orphan_hash = fingerprint0, mi_orphan = False, -- Always set by addVersionInfo, but -- it's a strict field, so we can't omit it. mi_finsts = False, -- Ditto @@ -271,6 +280,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_hash_fn = deliberatelyOmitted "hash_fn", mi_hpc = isHpcUsed hpc_info, mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, @@ -283,8 +293,8 @@ mkIface_ hsc_env maybe_old_fingerprint intermediate_iface decls -- Warn about orphans - ; let warn_orphs = dopt Opt_WarnOrphans dflags - warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags + ; let warn_orphs = wopt Opt_WarnOrphans dflags + warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags orph_warnings --- Laziness means no work done unless -fwarn-orphans | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns | otherwise = emptyBag @@ -468,7 +478,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls = do let hash_fn = mk_put_name local_env decl = abiDecl abi -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do - hash <- computeFingerprint dflags hash_fn abi + hash <- computeFingerprint hash_fn abi return (extend_hash_env (hash,decl) local_env, (hash,decl) : decls_w_hashes) @@ -480,7 +490,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do let stable_abis = sortBy cmp_abiNames abis -- put the cycle in a canonical order - hash <- computeFingerprint dflags hash_fn stable_abis + hash <- computeFingerprint hash_fn stable_abis let pairs = zip (repeat hash) decls return (foldr extend_hash_env local_env pairs, pairs ++ decls_w_hashes) @@ -514,12 +524,12 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls $ dep_orphs sorted_deps dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods - orphan_hash <- computeFingerprint dflags (mk_put_name local_env) + orphan_hash <- computeFingerprint (mk_put_name local_env) (map ifDFun orph_insts, orph_rules, fam_insts) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. - export_hash <- computeFingerprint dflags putNameLiterally + export_hash <- computeFingerprint putNameLiterally (mi_exports iface0, orphan_hash, dep_orphan_hashes, @@ -527,9 +537,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- dep_pkgs: see "Package Version Changes" on -- wiki/Commentary/Compiler/RecompilationAvoidance mi_trust iface0) - -- TODO: Can probably make more fine grained. Only - -- really need to have recompilation for overlapping - -- instances. + -- Make sure change of Safe Haskell mode causes recomp. -- put the declarations in a canonical order, sorted by OccName let sorted_decls = Map.elems $ Map.fromList $ @@ -541,7 +549,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - orphans -- - deprecations -- - XXX vect info? - mod_hash <- computeFingerprint dflags putNameLiterally + mod_hash <- computeFingerprint putNameLiterally (map fst sorted_decls, export_hash, orphan_hash, @@ -552,7 +560,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls -- - usages -- - deps -- - hpc - iface_hash <- computeFingerprint dflags putNameLiterally + iface_hash <- computeFingerprint putNameLiterally (mod_hash, mi_usages iface0, sorted_deps, @@ -745,19 +753,6 @@ putNameLiterally bh name = ASSERT( isExternalName name ) do { put_ bh $! nameModule name ; put_ bh $! nameOccName name } -computeFingerprint :: Binary a - => DynFlags - -> (BinHandle -> Name -> IO ()) - -> a - -> IO Fingerprint - -computeFingerprint _dflags put_name a = do - bh <- openBinMem (3*1024) -- just less than a block - ud <- newWriteState put_name putFS - bh <- return $ setUserData bh ud - put_ bh a - fingerprintBinMem bh - {- -- for testing: use the md5sum command to generate fingerprints and -- compare the results against our built-in version. @@ -918,7 +913,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names Just _ -> pprPanic "mkUsage: empty direct import" empty Nothing -> (False, safeImplicitImpsReq dflags) -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn' - -- is used in the source code. We require them to be safe in SafeHaskell + -- is used in the source code. We require them to be safe in Safe Haskell used_occs = lookupModuleEnv ent_map mod `orElse` [] @@ -1041,21 +1036,20 @@ so we may need to split up a single Avail into multiple ones. \begin{code} checkOldIface :: HscEnv -> ModSummary - -> Bool -- Source unchanged + -> SourceModified -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (RecompileRequired, Maybe ModIface) -checkOldIface hsc_env mod_summary source_unchanged maybe_iface +checkOldIface hsc_env mod_summary source_modified maybe_iface = do showPass (hsc_dflags hsc_env) $ "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary) initIfaceCheck hsc_env $ - check_old_iface hsc_env mod_summary source_unchanged maybe_iface + check_old_iface hsc_env mod_summary source_modified maybe_iface -check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface +check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> IfG (Bool, Maybe ModIface) -check_old_iface hsc_env mod_summary src_unchanged maybe_iface - = let src_changed = not src_unchanged - dflags = hsc_dflags hsc_env +check_old_iface hsc_env mod_summary src_modified maybe_iface + = let dflags = hsc_dflags hsc_env getIface = case maybe_iface of Just _ -> do @@ -1073,23 +1067,34 @@ check_old_iface hsc_env mod_summary src_unchanged maybe_iface return $ Just iface in do - when src_changed + let src_changed + | dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True + | SourceModified <- src_modified = True + | otherwise = False + + when src_changed (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - if not (isObjectTarget $ hscTarget dflags) && src_changed + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + if not (isObjectTarget $ hscTarget dflags) && src_changed then return (outOfDate, maybe_iface) else do -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it maybe_iface' <- getIface + if src_changed + then return (outOfDate, maybe_iface') + else do case maybe_iface' of Nothing -> return (outOfDate, maybe_iface') - Just iface -> do - -- We have got the old iface; check its versions - recomp <- checkVersions hsc_env src_unchanged mod_summary iface - return recomp + Just iface -> + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + checkVersions hsc_env mod_summary iface \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -1110,16 +1115,10 @@ safeHsChanged hsc_env iface = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env) checkVersions :: HscEnv - -> Bool -- True <=> source unchanged -> ModSummary -> ModIface -- Old interface -> IfG (RecompileRequired, Maybe ModIface) -checkVersions hsc_env source_unchanged mod_summary iface - | not source_unchanged - = let iface' = if safeHsChanged hsc_env iface then Nothing else Just iface - in return (outOfDate, iface') - - | otherwise +checkVersions hsc_env mod_summary iface = do { traceHiDiffs (text "Considering whether compilation is required for" <+> ppr (mi_module iface) <> colon) @@ -1532,7 +1531,7 @@ toIfaceIdInfo id_info ------------ Unfolding -------------- unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) - loop_breaker = isNonRuleLoopBreaker (occInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info @@ -1563,7 +1562,7 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding _ar _con ops) - = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops))) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2187f03c61..8cfe3017e2 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -40,7 +40,7 @@ import TyCon import DataCon import TysWiredIn import TysPrim ( anyTyConOfKind ) -import BasicTypes ( Arity, nonRuleLoopBreaker ) +import BasicTypes ( Arity, strongLoopBreaker ) import qualified Var import VarEnv import VarSet @@ -1055,7 +1055,7 @@ tcIdInfo ignore_prags name ty info -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsUnfold lb if_unf) = do { unf <- tcUnfolding name ty info if_unf - ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker + ; let info1 | lb = info `setOccInfo` strongLoopBreaker | otherwise = info ; return (info1 `setUnfoldingInfoLazily` unf) } \end{code} @@ -1091,14 +1091,12 @@ tcUnfolding name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) } tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops + = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops ; return (case mb_ops1 of Nothing -> noUnfolding Just ops1 -> mkDFunUnfolding dfun_ty ops1) } where doc = text "Class ops for dfun" <+> ppr name - tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') } - tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') } tcUnfolding name ty info (IfExtWrapper arity wkr) = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 82c6bfa65e..217d02debf 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -113,15 +113,18 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = -- | Print out a function defenition header. ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args - = let varg' = if varg == VarArgs then text ", ..." else empty + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty align = case a of - Just a' -> space <> text "align" <+> texts a' + Just a' -> text " align" <+> texts a' Nothing -> empty args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%" <> ftext n) (zip p args) in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> - (hcat $ intersperse comma args') <> varg' <> rparen <> align + (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align -- | Print out a list of function declaration. @@ -132,7 +135,18 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs -- Declarations define the function type but don't define the actual body of -- the function. ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc -ppLlvmFunctionDecl dec = text "declare" <+> texts dec +ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty + align = case a of + Just a' -> text " align" <+> texts a' + Nothing -> empty + args = hcat $ intersperse (comma <> space) $ + map (\(t,a) -> texts t <+> ppSpaceJoin a) p + in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> + ftext n <> lparen <> args <> varg' <> rparen <> align -- | Print out a list of LLVM blocks. @@ -204,7 +218,7 @@ ppCall ct fptr vals attrs = case fptr of ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCommaJoin vals - ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params + ppParams = map (texts . fst) params ppArgTy = (hcat $ intersperse comma ppParams) <> (case argTy of VarArgs -> text ", ..." @@ -317,15 +331,14 @@ ppAsm asm constraints rty vars sideeffect alignstack = -- * Misc functions -------------------------------------------------------------------------------- ppCommaJoin :: (Show a) => [a] -> Doc -ppCommaJoin strs = hcat $ intersperse comma (map texts strs) +ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs) ppSpaceJoin :: (Show a) => [a] -> Doc ppSpaceJoin strs = hcat $ intersperse space (map texts strs) -- | Convert SDoc to Doc llvmSDoc :: Out.SDoc -> Doc -llvmSDoc d - = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d +llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d -- | Showable to Doc texts :: (Show a) => a -> Doc diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 3637c86467..101342606d 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -7,6 +7,7 @@ module Llvm.Types where #include "HsVersions.h" import Data.Char +import Data.List (intercalate) import Numeric import Constants @@ -59,12 +60,12 @@ instance Show LlvmType where show (LMStruct tys ) = "<{" ++ (commaCat tys) ++ "}>" show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) - = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists - map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p - varg' = case varg of - VarArgs | not (null args) -> ", ..." - | otherwise -> "..." - _otherwise -> "" + = let varg' = case varg of + VarArgs | null args -> "..." + | otherwise -> ", ..." + _otherwise -> "" + -- by default we don't print param attributes + args = intercalate ", " $ map (show . fst) p in show r ++ " (" ++ args ++ varg' ++ ")" show (LMAlias (s,_)) = "%" ++ unpackFS s @@ -135,29 +136,13 @@ instance Show LlvmStatic where show (LMStaticLit l ) = show l show (LMUninitType t) = show t ++ " undef" show (LMStaticStr s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\"" - - show (LMStaticArray d t) - = let struc = case d of - [] -> "[]" - ts -> "[" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "]" - in show t ++ " " ++ struc - - show (LMStaticStruc d t) - = let struc = case d of - [] -> "<{}>" - ts -> "<{" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "}>" - in show t ++ " " ++ struc - + show (LMStaticArray d t) = show t ++ " [" ++ commaCat d ++ "]" + show (LMStaticStruc d t) = show t ++ "<{" ++ commaCat d ++ "}>" show (LMStaticPointer v) = show v - show (LMBitc v t) = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")" - show (LMPtoI v t) = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")" - show (LMAdd s1 s2) = let ty1 = getStatType s1 op = if isFloat ty1 then " fadd (" else " add (" @@ -176,13 +161,7 @@ instance Show LlvmStatic where -- | Concatenate an array together, separated by commas commaCat :: Show a => [a] -> String -commaCat [] = "" -commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x)) - --- | Concatenate an array together, separated by commas -spaceCat :: Show a => [a] -> String -spaceCat [] = "" -spaceCat x = show (head x) ++ (concat $ map (\y -> " " ++ show y) (tail x)) +commaCat xs = intercalate ", " $ map show xs -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables @@ -207,12 +186,12 @@ getPlainName (LMLitVar x ) = getLit x -- | Print a literal value. No type. getLit :: LlvmLit -> String -getLit (LMIntLit i _) = show ((fromInteger i)::Int) +getLit (LMIntLit i _ ) = show ((fromInteger i)::Int) getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r getLit (LMFloatLit r LMDouble) = dToStr r getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f -getLit (LMNullLit _) = "null" -getLit (LMUndefLit _) = "undef" +getLit (LMNullLit _ ) = "null" +getLit (LMUndefLit _ ) = "undef" -- | Return the 'LlvmType' of the 'LlvmVar' getVarType :: LlvmVar -> LlvmType @@ -366,15 +345,15 @@ data LlvmFunctionDecl = LlvmFunctionDecl { instance Show LlvmFunctionDecl where show (LlvmFunctionDecl n l c r varg p a) - = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists - map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p - varg' = case varg of - VarArgs | not (null args) -> ", ..." - | otherwise -> "..." - _otherwise -> "" + = let varg' = case varg of + VarArgs | null args -> "..." + | otherwise -> ", ..." + _otherwise -> "" align = case a of Just a' -> " align " ++ show a' Nothing -> "" + -- by default we don't print param attributes + args = intercalate ", " $ map (show . fst) p in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ "(" ++ args ++ varg' ++ ")" ++ align diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index 56d8386431..be5c79cf64 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -7,15 +7,12 @@ module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" import Llvm - import LlvmCodeGen.Base import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr - import LlvmMangler -import CLabel import CgUtils ( fixStgRegisters ) import OldCmm import OldPprCmm @@ -42,19 +39,17 @@ llvmCodeGen dflags h us cmms (cdata,env) = foldr split ([],initLlvmEnv) cmm split (CmmData s d' ) (d,e) = ((s,d'):d,e) split (CmmProc i l _) (d,e) = - let lbl = strCLabel_llvm $ if not (null i) - then entryLblToInfoLbl l - else l + let lbl = strCLabel_llvm $ case i of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl env' = funInsert lbl llvmFunTy e in (d,env') in do bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader - ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags - + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] cmmProcLlvmGens dflags bufh us env' cmm 1 [] - bFlush bufh return () @@ -62,7 +57,7 @@ llvmCodeGen dflags h us cmms -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])] +cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] -> [LlvmUnresData] -> IO ( LlvmEnv ) cmmDataLlvmGens dflags h env [] lmdata @@ -83,41 +78,44 @@ cmmDataLlvmGens dflags h env (cmm:cmms) lmdata -- | Do LLVM code generation on all these Cmms procs. -- cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop] - -> Int -- ^ count, used for generating unique subsections - -> [LlvmVar] -- ^ info tables that need to be marked as 'used' + -> Int -- ^ count, used for generating unique subsections + -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used' -> IO () cmmProcLlvmGens _ _ _ _ [] _ [] = return () cmmProcLlvmGens _ h _ _ [] _ ivars - = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars) i8Ptr) - usedArray = LMStaticArray (map cast ivars) ty + = let ivars' = concat ivars + cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars') i8Ptr) + usedArray = LMStaticArray (map cast ivars') ty lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], []) -cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars - = do - (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm +cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars + = cmmProcLlvmGens dflags h us env cmms count ivars +cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars + = cmmProcLlvmGens dflags h us env cmms count ivars + +cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do + (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm Prt.bufLeftRender h $ Prt.vcat docs - - cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars) + cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] ) -cmmLlvmGen dflags us env cmm - = do +cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs let fixed_cmm = fixStgRegisters cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [fixed_cmm]) + (pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm]) -- generate llvm code from cmm let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 221106aec5..1c7592ad2d 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -29,6 +29,7 @@ import LlvmCodeGen.Regs import CLabel import CgUtils ( activeStgRegs ) +import Config import Constants import FastString import OldCmm @@ -40,7 +41,7 @@ import Unique -- * Some Data Types -- -type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement) +type LlvmCmmTop = GenCmmTop [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement -- | Unresolved code. @@ -80,7 +81,8 @@ widthToLlvmInt w = LMInt $ widthInBits w -- | GHC Call Convention for LLVM llvmGhcCC :: LlvmCallConvention -llvmGhcCC = CC_Ncc 10 +llvmGhcCC | cGhcUnregisterised == "NO" = CC_Ncc 10 + | otherwise = CC_Ccc -- | Llvm Function type for Cmm function llvmFunTy :: LlvmType diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index eb002742e1..c9ad76efd5 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,28 +29,19 @@ import Util import Data.List ( partition ) import Control.Monad ( liftM ) -type LlvmStatements = OrdList LlvmStatement +type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop]) -genLlvmProc env (CmmData _ _) - = return (env, []) - -genLlvmProc env (CmmProc _ _ (ListGraph [])) - = return (env, []) - -genLlvmProc env (CmmProc info lbl (ListGraph blocks)) - = do - (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) - - let proc = CmmProc info lbl (ListGraph lmblocks) - let tops = lmdata ++ [proc] - - return (env', tops) +genLlvmProc env (CmmProc info lbl (ListGraph blocks)) = do + (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) + let proc = CmmProc info lbl (ListGraph lmblocks) + return (env', proc:lmdata) +genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 3e486a544f..ef86abfd6f 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -37,8 +37,8 @@ structStr = fsLit "_struct" -- complete this completely though as we need to pass all CmmStatic -- sections before all references can be resolved. This last step is -- done by 'resolveLlvmData'. -genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData -genLlvmData (sec, CmmDataLabel lbl:xs) = +genLlvmData :: (Section, CmmStatics) -> LlvmUnresData +genLlvmData (sec, Statics lbl xs) = let static = map genData xs label = strCLabel_llvm lbl @@ -50,8 +50,6 @@ genLlvmData (sec, CmmDataLabel lbl:xs) = alias = LMAlias ((label `appendFS` structStr), strucTy) in (lbl, sec, alias, static) -genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!" - resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData] -> (LlvmEnv, [LlvmData]) @@ -150,7 +148,6 @@ resData _ _ = panic "resData: Non CLabel expr as left type!" -- -- | Handle static data --- Don't handle 'CmmAlign' or a 'CmmDataLabel'. genData :: CmmStatic -> UnresStatic genData (CmmString str) = @@ -164,12 +161,6 @@ genData (CmmUninitialised bytes) genData (CmmStaticLit lit) = genStaticLit lit -genData (CmmAlign _) - = panic "genData: Can't handle CmmAlign!" - -genData (CmmDataLabel _) - = panic "genData: Can't handle data labels not at top of data!" - -- | Generate Llvm code for a static literal. -- diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 9f25c08826..40f7ce05f1 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -82,16 +82,16 @@ pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar]) pprLlvmCmmTop _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks)) - = let static = CmmDataLabel lbl : info - (idoc, ivar) = if not (null info) - then pprInfoTable env count lbl static - else (empty, []) +pprLlvmCmmTop env count (CmmProc mb_info entry_lbl (ListGraph blks)) + = let (idoc, ivar) = case mb_info of + Nothing -> (empty, []) + Just (Statics info_lbl dat) + -> pprInfoTable env count info_lbl (Statics entry_lbl dat) in (idoc $+$ ( let sec = mkLayoutSection (count + 1) - (lbl',sec') = if not (null info) - then (entryLblToInfoLbl lbl, sec) - else (lbl, Nothing) + (lbl',sec') = case mb_info of + Nothing -> (entry_lbl, Nothing) + Just (Statics info_lbl _) -> (info_lbl, sec) link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal @@ -103,14 +103,14 @@ pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks)) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar]) -pprInfoTable env count lbl stat +pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar]) +pprInfoTable env count info_lbl stat = let unres = genLlvmData (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres setSection ((LMGlobalVar _ ty l _ _ c), d) = let sec = mkLayoutSection count - ilabel = strCLabel_llvm (entryLblToInfoLbl lbl) + ilabel = strCLabel_llvm info_lbl `appendFS` fsLit iTableSuf gv = LMGlobalVar ilabel ty l sec llvmInfAlign c v = if l == Internal then [gv] else [] diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs index 591ef81934..ae3ef9fd81 100644 --- a/compiler/llvmGen/LlvmMangler.hs +++ b/compiler/llvmGen/LlvmMangler.hs @@ -17,18 +17,22 @@ module LlvmMangler ( llvmFixupAsm ) where import LlvmCodeGen.Ppr ( infoSection ) import Control.Exception +import Control.Monad ( when ) import qualified Data.ByteString.Char8 as B import Data.Char -import qualified Data.IntMap as I import System.IO +import Data.List ( sortBy ) +import Data.Function ( on ) + -- Magic Strings -secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString +secStmt, infoSec, newLine, spInst, jmpInst, textStmt, dataStmt :: B.ByteString secStmt = B.pack "\t.section\t" infoSec = B.pack infoSection -newInfoSec = B.pack "\n\t.text" newLine = B.pack "\n" jmpInst = B.pack "\n\tjmp" +textStmt = B.pack "\t.text" +dataStmt = B.pack "\t.data" infoLen, labelStart, spFix :: Int infoLen = B.length infoSec @@ -53,53 +57,79 @@ llvmFixupAsm :: FilePath -> FilePath -> IO () llvmFixupAsm f1 f2 = do r <- openBinaryFile f1 ReadMode w <- openBinaryFile f2 WriteMode - fixTables r w I.empty - B.hPut w (B.pack "\n\n") + ss <- readSections r w hClose r + let fixed = fixTables ss + mapM_ (writeSection w) fixed hClose w return () -{- | - Here we process the assembly file one function and data - definition at a time. When a function is encountered that - should have a info table we store it in a map. Otherwise - we print it. When an info table is found we retrieve its - function from the map and print them both. - - For all functions we fix up the stack alignment. We also - fix up the section definition for functions and info tables. --} -fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO () -fixTables r w m = do - f <- getFun r B.empty - if B.null f - then return () - else let fun = fixupStack f B.empty - (a,b) = B.breakSubstring infoSec fun - (a',s) = B.breakEnd eolPred a - -- We search for the section header in two parts as it makes - -- us portable across OS types and LLVM version types since - -- section names are wrapped differently. - secHdr = secStmt `B.isPrefixOf` s - (x,c) = B.break eolPred b - fun' = a' `B.append` newInfoSec `B.append` c - n = readInt $ B.takeWhile isDigit $ B.drop infoLen x - (bs, m') | B.null b || not secHdr = ([fun], m) - | even n = ([], I.insert n fun' m) - | otherwise = case I.lookup (n+1) m of - Just xf' -> ([fun',xf'], m) - Nothing -> ([fun'], m) - in mapM_ (B.hPut w) bs >> fixTables r w m' - --- | Read in the next function/data defenition -getFun :: Handle -> B.ByteString -> IO B.ByteString -getFun r f = do - l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString) - case l of - Right l' | B.null l' -> return f - | otherwise -> getFun r (f `B.append` newLine `B.append` l') - Left _ -> return B.empty - +type Section = (B.ByteString, B.ByteString) + +-- | Splits the file contents into its sections. Each is returned as a +-- pair of the form (header line, contents lines) +readSections :: Handle -> Handle -> IO [Section] +readSections r w = go B.empty [] [] + where + go hdr ss ls = do + e_l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString) + + -- Note that ".type" directives at the end of a section refer to + -- the first directive of the *next* section, therefore we take + -- it over to that section. + let (tys, ls') = span isType ls + isType = B.isPrefixOf (B.pack "\t.type") + cts = B.intercalate newLine $ reverse ls' + + -- Decide whether to directly output the section or append it + -- to the list for resorting. + let finishSection + | infoSec `B.isInfixOf` hdr = + cts `seq` return $ (hdr, cts):ss + | otherwise = + writeSection w (hdr, fixupStack cts B.empty) >> return ss + + case e_l of + Right l | any (`B.isPrefixOf` l) [secStmt, textStmt, dataStmt] + -> finishSection >>= \ss' -> go l ss' tys + | otherwise + -> go hdr ss (l:ls) + Left _ -> finishSection >>= \ss' -> return (reverse ss') + +-- | Writes sections back +writeSection :: Handle -> Section -> IO () +writeSection w (hdr, cts) = do + when (not $ B.null hdr) $ + B.hPutStrLn w hdr + B.hPutStrLn w cts + +-- | Reorder and convert sections so info tables end up next to the +-- code. Also does stack fixups. +fixTables :: [Section] -> [Section] +fixTables ss = fixed + where + -- Resort sections: We only assign a non-zero number to all + -- sections having the "STRIP ME" marker. As sortBy is stable, + -- this will cause all these sections to be appended to the end of + -- the file in the order given by the indexes. + extractIx hdr + | B.null a = 0 + | otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a) + where (_,a) = B.breakSubstring infoSec hdr + indexed = zip (map (extractIx . fst) ss) ss + sorted = map snd $ sortBy (compare `on` fst) indexed + + -- Turn all the "STRIP ME" sections into normal text sections, as + -- they are in the right place now. + strip (hdr, cts) + | infoSec `B.isInfixOf` hdr = (textStmt, cts) + | otherwise = (hdr, cts) + stripped = map strip sorted + + -- Do stack fixup + fix (hdr, cts) = (hdr, fixupStack cts B.empty) + fixed = map fix stripped + {-| Mac OS X requires that the stack be 16 byte aligned when making a function call (only really required though when making a call that will pass through diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 3ff75e1043..02b6042148 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -34,11 +34,11 @@ import Data.List data Flag m = Flag { flagName :: String, -- Flag, without the leading "-" - flagSafety :: FlagSafety, -- Flag safety level (SafeHaskell) + flagSafety :: FlagSafety, -- Flag safety level (Safe Haskell) flagOptKind :: OptKind m -- What to do if we see it } --- | This determines how a flag should behave when SafeHaskell +-- | This determines how a flag should behave when Safe Haskell -- mode is on. data FlagSafety = EnablesSafe -- ^ This flag is a little bit of a hack. We give @@ -107,7 +107,7 @@ setArg l s (EwM f) = EwM (\_ _ c es ws -> | otherwise = err l es ws err (L loc ('-' : arg)) es ws = let msg = "Warning: " ++ arg ++ " is not allowed in " - ++ "SafeHaskell; ignoring " ++ arg + ++ "Safe Haskell; ignoring " ++ arg in return (es, ws `snocBag` L loc msg, ()) err _ _ _ = error "Bad pattern match in setArg" in check) diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index b58b7cd395..3ff35b6b92 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -61,7 +61,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC do { when (dopt Opt_DoCmmLinting dflags) $ do { showPass dflags "CmmLint" - ; let lints = map cmmLint flat_abstractC + ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC ; case firstJusts lints of Just err -> do { printDump err ; ghcExit dflags 1 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c7bc823823..b1f50acfb8 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -101,6 +101,7 @@ compile :: HscEnv -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch) @@ -115,10 +116,12 @@ compile' :: -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one + -> SourceModified -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compile' (nothingCompiler, interactiveCompiler, batchCompiler) hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable + source_modified0 = do let dflags0 = ms_hspp_opts summary this_mod = ms_mod summary @@ -156,7 +159,9 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- -fforce-recomp should also work with --make let force_recomp = dopt Opt_ForceRecomp dflags - source_unchanged = isJust maybe_old_linkable && not force_recomp + source_modified + | force_recomp || isNothing maybe_old_linkable = SourceModified + | otherwise = source_modified0 object_filename = ml_obj_file location let handleBatch HscNoRecomp @@ -223,7 +228,7 @@ compile' (nothingCompiler, interactiveCompiler, batchCompiler) -- -> m HomeModInfo runCompiler compiler handle = do (result, iface, details) - <- compiler hsc_env' summary source_unchanged mb_old_iface + <- compiler hsc_env' summary source_modified mb_old_iface (Just (mod_index, nmods)) linkable <- handle result return (HomeModInfo{ hm_details = details, @@ -893,22 +898,21 @@ runPhase (Hsc src_flavour) input_fn dflags0 -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. src_timestamp <- io $ getModificationTime (basename <.> suff) - let force_recomp = dopt Opt_ForceRecomp dflags - hsc_lang = hscTarget dflags + let hsc_lang = hscTarget dflags source_unchanged <- io $ - if force_recomp || not (isStopLn stop) - -- Set source_unchanged to False unconditionally if + if not (isStopLn stop) + -- SourceModified unconditionally if -- (a) recompilation checker is off, or -- (b) we aren't going all the way to .o file (e.g. ghc -S) - then return False + then return SourceModified -- Otherwise look at file modification dates else do o_file_exists <- doesFileExist o_file if not o_file_exists - then return False -- Need to recompile + then return SourceModified -- Need to recompile else do t2 <- getModificationTime o_file if t2 > src_timestamp - then return True - else return False + then return SourceUnmodified + else return SourceModified -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang @@ -934,8 +938,8 @@ runPhase (Hsc src_flavour) input_fn dflags0 ms_location = location4, ms_hs_date = src_timestamp, ms_obj_date = Nothing, - ms_imps = imps, - ms_srcimps = src_imps } + ms_textual_imps = imps, + ms_srcimps = src_imps } -- run the compiler! result <- io $ hscCompileOneShot hsc_env' @@ -1440,7 +1444,10 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do | isWindowsTarget = empty | otherwise = hcat [ text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, - text ",\\\"\\\",@note\\n", + text ",\\\"\\\",", + text elfSectionNote, + text "\\n", + text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] where -- we need to escape twice: once because we're inside a C string, @@ -1450,6 +1457,16 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do escape :: String -> String escape = concatMap (charToC.fromIntegral.ord) + elfSectionNote :: String + elfSectionNote = case platformArch (targetPlatform dflags) of + ArchX86 -> "@note" + ArchX86_64 -> "@note" + ArchPPC -> "@note" + ArchPPC_64 -> "@note" + ArchSPARC -> "@note" + ArchARM -> "%note" + ArchUnknown -> panic "elfSectionNote ArchUnknown" + -- The "link info" is a string representing the parameters of the -- link. We save this information in the binary, and the next time we -- link, if nothing else has changed, we use the link info stored in @@ -1568,12 +1585,12 @@ linkBinary dflags o_files dep_packages = do pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) -#ifdef elf_OBJ_FORMAT - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif + get_pkg_lib_path_opts l + | osElfTarget (platformOS (targetPlatform dflags)) && + dynLibLoader dflags == SystemDependent && + not opt_Static + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1649,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 @@ -1693,58 +1721,55 @@ maybeCreateManifest :: DynFlags -> FilePath -- filename of executable -> IO [FilePath] -- extra objects to embed, maybe -#ifndef mingw32_TARGET_OS -maybeCreateManifest _ _ = do - return [] -#else -maybeCreateManifest dflags exe_filename = do - if not (dopt Opt_GenManifest dflags) then return [] else do - - let manifest_filename = exe_filename <.> "manifest" - - writeFile manifest_filename $ - "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ - " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ - " <assemblyIdentity version=\"1.0.0.0\"\n"++ - " processorArchitecture=\"X86\"\n"++ - " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ - " type=\"win32\"/>\n\n"++ - " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ - " <security>\n"++ - " <requestedPrivileges>\n"++ - " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ - " </requestedPrivileges>\n"++ - " </security>\n"++ - " </trustInfo>\n"++ - "</assembly>\n" - - -- Windows will find the manifest file if it is named foo.exe.manifest. - -- However, for extra robustness, and so that we can move the binary around, - -- we can embed the manifest in the binary itself using windres: - if not (dopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags "rc" - rc_obj_filename <- newTempName dflags (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - let wr_opts = getOpts dflags opt_windres - runWindres dflags $ map SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - ++ wr_opts - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - removeFile manifest_filename - - return [rc_obj_filename] -#endif +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + dopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++ + " <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++ + " <assemblyIdentity version=\"1.0.0.0\"\n"++ + " processorArchitecture=\"X86\"\n"++ + " name=\"" ++ dropExtension exe_filename ++ "\"\n"++ + " type=\"win32\"/>\n\n"++ + " <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++ + " <security>\n"++ + " <requestedPrivileges>\n"++ + " <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++ + " </requestedPrivileges>\n"++ + " </security>\n"++ + " </trustInfo>\n"++ + "</assembly>\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (dopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags "rc" + rc_obj_filename <- newTempName dflags (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + let wr_opts = getOpts dflags opt_windres + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + ++ wr_opts + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently + + removeFile manifest_filename + + return [rc_obj_filename] + | otherwise = return [] linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () @@ -1756,12 +1781,12 @@ linkDynLib dflags o_files dep_packages = do let pkg_lib_paths = collectLibraryPaths pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths -#ifdef elf_OBJ_FORMAT - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif + get_pkg_lib_path_opts l + | osElfTarget (platformOS (targetPlatform dflags)) && + dynLibLoader dflags == SystemDependent && + not opt_Static + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1773,11 +1798,11 @@ linkDynLib dflags o_files dep_packages = do -- not allow undefined symbols. -- The RTS library path is still added to the library search path -- above in case the RTS is being explicitly linked in (see #3807). -#if !defined(mingw32_HOST_OS) - let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs -#else - let pkgs_no_rts = pkgs -#endif + let pkgs_no_rts = case platformOS (targetPlatform dflags) of + OSMinGW32 -> + pkgs + _ -> + filter ((/= rtsPackageId) . packageConfigId) pkgs let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts -- probably _stub.o files @@ -1970,7 +1995,15 @@ joinObjectFiles dflags o_files output_fn = do let ld_r args = SysTools.runLink dflags ([ SysTools.Option "-nostdlib", SysTools.Option "-nodefaultlibs", - SysTools.Option "-Wl,-r", + SysTools.Option "-Wl,-r" + ] + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-Wl,-no-relax"] + else []) + ++ [ SysTools.Option ld_build_id, SysTools.Option ld_x_flag, SysTools.Option "-o", diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index fb2bd4f42e..68410cdb64 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -12,11 +12,16 @@ module DynFlags ( -- * Dynamic flags and associated configuration types DynFlag(..), + WarningFlag(..), ExtensionFlag(..), + LogAction, glasgowExtsFlags, dopt, dopt_set, dopt_unset, + wopt, + wopt_set, + wopt_unset, xopt, xopt_set, xopt_unset, @@ -28,27 +33,29 @@ module DynFlags ( PackageFlag(..), Option(..), showOpt, DynLibLoader(..), - fFlags, fLangFlags, xFlags, + fFlags, fWarningFlags, fLangFlags, xFlags, DPHBackend(..), dphPackageMaybe, - wayNames, + wayNames, dynFlagDependencies, - -- ** SafeHaskell + -- ** Safe Haskell SafeHaskellMode(..), safeHaskellOn, safeLanguageOn, safeDirectImpsReq, safeImplicitImpsReq, + -- ** System tool settings and locations Settings(..), ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, extraGccViaCFlags, systemPackageConfig, pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T, pgm_sysman, pgm_windres, pgm_lo, pgm_lc, - opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l, + opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_windres, opt_lo, opt_lc, -- ** Manipulating DynFlags defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags + defaultLogAction, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] getVerbFlags, @@ -211,38 +218,6 @@ data DynFlag | Opt_DoAsmLinting | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_WarnDuplicateExports - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompleteUniPatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSigs - | Opt_WarnMissingLocalSigs - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnIdentities - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnLazyUnliftedBindings - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional | Opt_PrintExplicitForalls @@ -260,7 +235,6 @@ data DynFlag | Opt_DoEtaReduction | Opt_CaseMerge | Opt_UnboxStrictFields - | Opt_MethodSharing -- Now a no-op; remove in GHC 7.2 | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise @@ -323,24 +297,55 @@ data DynFlag deriving (Eq, Show) +data WarningFlag = + Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnLazyUnliftedBindings + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + deriving (Eq, Show) + data Language = Haskell98 | Haskell2010 --- | The various SafeHaskell modes +-- | The various Safe Haskell modes data SafeHaskellMode = Sf_None | Sf_SafeImports - | Sf_SafeLanguage | Sf_Trustworthy - | Sf_TrustworthyWithSafeLanguage | Sf_Safe deriving (Eq) instance Outputable SafeHaskellMode where ppr Sf_None = ptext $ sLit "None" ppr Sf_SafeImports = ptext $ sLit "SafeImports" - ppr Sf_SafeLanguage = ptext $ sLit "SafeLanguage" ppr Sf_Trustworthy = ptext $ sLit "Trustworthy" - ppr Sf_TrustworthyWithSafeLanguage = ptext $ sLit "Trustworthy + SafeLanguage" ppr Sf_Safe = ptext $ sLit "Safe" data ExtensionFlag @@ -355,6 +360,7 @@ data ExtensionFlag | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting | Opt_ForeignFunctionInterface | Opt_UnliftedFFITypes + | Opt_InterruptibleFFI | Opt_GHCForeignImportPrim | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax @@ -384,7 +390,6 @@ data ExtensionFlag | Opt_DeriveFoldable | Opt_DeriveGeneric -- Allow deriving Generic/1 | Opt_DefaultSignatures -- Allow extra signatures for defmeths - | Opt_Generics -- Old generic classes, now deprecated | Opt_TypeSynonymInstances | Opt_FlexibleContexts @@ -533,6 +538,7 @@ data DynFlags = DynFlags { -- hsc dynamic flags flags :: [DynFlag], + warningFlags :: [WarningFlag], -- Don't change this without updating extensionFlags: language :: Maybe Language, -- | Safe Haskell mode @@ -544,7 +550,7 @@ data DynFlags = DynFlags { extensionFlags :: [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can - log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), + log_action :: LogAction, haddockOptions :: Maybe String } @@ -578,7 +584,6 @@ data Settings = Settings { sOpt_P :: [String], sOpt_F :: [String], sOpt_c :: [String], - sOpt_m :: [String], sOpt_a :: [String], sOpt_l :: [String], sOpt_windres :: [String], @@ -635,8 +640,6 @@ opt_F :: DynFlags -> [String] opt_F dflags = sOpt_F (settings dflags) opt_c :: DynFlags -> [String] opt_c dflags = sOpt_c (settings dflags) -opt_m :: DynFlags -> [String] -opt_m dflags = sOpt_m (settings dflags) opt_a :: DynFlags -> [String] opt_a dflags = sOpt_a (settings dflags) opt_l :: DynFlags -> [String] @@ -858,24 +861,28 @@ defaultDynFlags mySettings = generatedDumps = panic "defaultDynFlags: No generatedDumps", haddockOptions = Nothing, flags = defaultFlags, + warningFlags = standardWarnings, language = Nothing, safeHaskell = Sf_None, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], - - log_action = \severity srcSpan style msg -> - case severity of - SevOutput -> printSDoc msg style - SevInfo -> printErrs msg style - SevFatal -> printErrs msg style - _ -> do - hPutChar stderr '\n' - printErrs (mkLocMessage srcSpan msg) style - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. + log_action = defaultLogAction } +type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO () + +defaultLogAction :: LogAction +defaultLogAction severity srcSpan style msg + = case severity of + SevOutput -> printSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, whereas + -- converting to string first and using hPutStr would + -- just emit the low 8 bits of each unicode char. + {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -951,6 +958,18 @@ dopt_set dfs f = dfs{ flags = f : flags dfs } dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `elem` (warningFlags dflags) + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = f : warningFlags dfs } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = filter (/= f) (warningFlags dfs) } + -- | Test whether a 'ExtensionFlag' is set xopt :: ExtensionFlag -> DynFlags -> Bool xopt f dflags = f `elem` extensionFlags dflags @@ -979,17 +998,19 @@ setLanguage l = upd f extensionFlags = flattenExtensionFlags mLang oneoffs } +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the Safe Haskell safe language in use safeLanguageOn :: DynFlags -> Bool -safeLanguageOn dflags = s == Sf_SafeLanguage - || s == Sf_TrustworthyWithSafeLanguage - || s == Sf_Safe - where s = safeHaskell dflags +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe --- | Test if SafeHaskell is on in some form +-- | Test if Safe Haskell is on in some form safeHaskellOn :: DynFlags -> Bool safeHaskellOn dflags = safeHaskell dflags /= Sf_None --- | Set a 'SafeHaskell' flag +-- | Set a 'Safe Haskell' flag setSafeHaskell :: SafeHaskellMode -> DynP () setSafeHaskell s = updM f where f dfs = do @@ -997,18 +1018,18 @@ setSafeHaskell s = updM f safeM <- combineSafeFlags sf s return $ dfs { safeHaskell = safeM } --- | Are all direct imports required to be safe for this SafeHaskell mode? +-- | Are all direct imports required to be safe for this Safe Haskell mode? -- Direct imports are when the code explicitly imports a module safeDirectImpsReq :: DynFlags -> Bool safeDirectImpsReq = safeLanguageOn --- | Are all implicit imports required to be safe for this SafeHaskell mode? +-- | Are all implicit imports required to be safe for this Safe Haskell mode? -- Implicit imports are things in the prelude. e.g System.IO when print is used. safeImplicitImpsReq :: DynFlags -> Bool safeImplicitImpsReq = safeLanguageOn --- | Combine two SafeHaskell modes correctly. Used for dealing with multiple flags. --- This makes SafeHaskell very much a monoid but for now I prefer this as I don't +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't -- want to export this functionality from the module but do want to export the -- type constructors. combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode @@ -1020,17 +1041,6 @@ combineSafeFlags a b = (Sf_SafeImports, sf) -> return sf (sf, Sf_SafeImports) -> return sf - (Sf_SafeLanguage, Sf_Safe) -> err - (Sf_Safe, Sf_SafeLanguage) -> err - - (Sf_SafeLanguage, Sf_Trustworthy) -> return Sf_TrustworthyWithSafeLanguage - (Sf_Trustworthy, Sf_SafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - - (Sf_TrustworthyWithSafeLanguage, Sf_Trustworthy) -> return Sf_TrustworthyWithSafeLanguage - (Sf_TrustworthyWithSafeLanguage, Sf_SafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - (Sf_Trustworthy, Sf_TrustworthyWithSafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - (Sf_SafeLanguage, Sf_TrustworthyWithSafeLanguage) -> return Sf_TrustworthyWithSafeLanguage - (Sf_Trustworthy, Sf_Safe) -> err (Sf_Safe, Sf_Trustworthy) -> err @@ -1038,7 +1048,7 @@ combineSafeFlags a b = | otherwise -> err where err = do - let s = "Incompatible SafeHaskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" + let s = "Incompatible Safe Haskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" addErr s return $ panic s -- Just for saftey instead of returning say, a @@ -1271,7 +1281,7 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags flip xopt_unset Opt_TemplateHaskell)] safeFailure str = [L noSrcSpan $ "Warning: " ++ str ++ " is not allowed in" - ++ " SafeHaskell; ignoring " ++ str] + ++ " Safe Haskell; ignoring " ++ str] {- ********************************************************************** @@ -1283,14 +1293,15 @@ shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags allFlags :: [String] allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++ - map ("fno-"++) flags ++ - map ("f"++) flags ++ - map ("f"++) flags' ++ + map ("fno-"++) fflags ++ + map ("f"++) fflags ++ map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False ok _ = True - flags = [ name | (name, _, _, _) <- fFlags ] - flags' = [ name | (name, _, _, _) <- fLangFlags ] + fflags = fflags0 ++ fflags1 ++ fflags2 + fflags0 = [ name | (name, _, _, _) <- fFlags ] + fflags1 = [ name | (name, _, _, _) <- fWarningFlags ] + fflags2 = [ name | (name, _, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] @@ -1311,7 +1322,7 @@ dynamic_flags = [ , flagA "pgmP" (hasArg setPgmP) , flagA "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) , flagA "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) - , flagA "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagA "pgmm" (HasArg (\_ -> addWarn "The -pgmm flag does nothing; it will be removed in a future GHC release")) , flagA "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) , flagA "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) , flagA "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) @@ -1325,7 +1336,7 @@ dynamic_flags = [ , flagA "optP" (hasArg addOptP) , flagA "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) , flagA "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) - , flagA "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s}))) + , flagA "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) , flagA "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) , flagA "optl" (hasArg addOptl) , flagA "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) @@ -1365,7 +1376,7 @@ dynamic_flags = [ ------- Output Redirection ------------------------------------------ , flagA "odir" (hasArg setObjectDir) - , flagA "o" (SepArg (upd . setOutputFile . Just)) + , flagA "o" (sepArg (setOutputFile . Just)) , flagA "ohi" (hasArg (setOutputHi . Just )) , flagA "osuf" (hasArg setObjectSuf) , flagA "hcsuf" (hasArg setHcSuf) @@ -1513,17 +1524,17 @@ dynamic_flags = [ , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- - , flagA "W" (NoArg (mapM_ setDynFlag minusWOpts)) - , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , flagA "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , flagA "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts - ; deprecate "Use -w instead" })) - , flagA "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) - + , flagA "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , flagA "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) + , flagA "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) + deprecate "Use -w instead")) + , flagA "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) + ------ Plugin flags ------------------------------------------------ - , flagA "fplugin" (hasArg addPluginModuleName) , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) + , flagA "fplugin" (hasArg addPluginModuleName) ------ Optimisation flags ------------------------------------------ , flagA "O" (noArgM (setOptLevel 1)) @@ -1541,7 +1552,7 @@ dynamic_flags = [ , flagA "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) , flagA "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) , flagA "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) - , flagA "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) + , flagA "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s })) , flagA "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) , flagA "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , flagA "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) @@ -1586,12 +1597,16 @@ dynamic_flags = [ ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags + ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags + ++ map (mkFlag turnOff "fno-" unSetWarningFlag) fWarningFlags ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlags ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlags ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags ++ map (mkFlag turnOn "X" setLanguage) languageFlags ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags + ++ [ flagA "XGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) + , flagA "XNoGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) ] package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ @@ -1650,8 +1665,8 @@ nop :: TurnOnFlag -> DynP () nop _ = return () -- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ -fFlags :: [FlagSpec DynFlag] -fFlags = [ +fWarningFlags :: [FlagSpec WarningFlag] +fWarningFlags = [ ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), @@ -1684,7 +1699,11 @@ fFlags = [ ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop ), + ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop )] + +-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@ +fFlags :: [FlagSpec DynFlag] +fFlags = [ ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), @@ -1702,9 +1721,6 @@ fFlags = [ ( "do-eta-reduction", AlwaysAllowed, Opt_DoEtaReduction, nop ), ( "case-merge", AlwaysAllowed, Opt_CaseMerge, nop ), ( "unbox-strict-fields", AlwaysAllowed, Opt_UnboxStrictFields, nop ), - ( "method-sharing", AlwaysAllowed, Opt_MethodSharing, - \_ -> deprecate "doesn't do anything any more"), - -- Remove altogether in GHC 7.2 ( "dicts-cheap", AlwaysAllowed, Opt_DictsCheap, nop ), ( "excess-precision", AlwaysAllowed, Opt_ExcessPrecision, nop ), ( "eager-blackholing", AlwaysAllowed, Opt_EagerBlackHoling, nop ), @@ -1745,8 +1761,6 @@ fLangFlags = [ deprecatedForExtension "ForeignFunctionInterface" ), ( "arrows", AlwaysAllowed, Opt_Arrows, deprecatedForExtension "Arrows" ), - ( "generics", AlwaysAllowed, Opt_Generics, - deprecatedForExtension "Generics" ), ( "implicit-prelude", AlwaysAllowed, Opt_ImplicitPrelude, deprecatedForExtension "ImplicitPrelude" ), ( "bang-patterns", AlwaysAllowed, Opt_BangPatterns, @@ -1797,8 +1811,7 @@ languageFlags = [ -- They are used to place hard requirements on what GHC Haskell language -- features can be used. safeHaskellFlags :: [FlagSpec SafeHaskellMode] -safeHaskellFlags = [mkF Sf_SafeImports, mkF' Sf_SafeLanguage, - mkF Sf_Trustworthy, mkF' Sf_Safe] +safeHaskellFlags = [mkF Sf_SafeImports, mkF Sf_Trustworthy, mkF' Sf_Safe] where mkF flag = (showPpr flag, AlwaysAllowed, flag, nop) mkF' flag = (showPpr flag, EnablesSafe, flag, nop) @@ -1820,6 +1833,7 @@ xFlags = [ ( "MonadComprehensions", AlwaysAllowed, Opt_MonadComprehensions, nop), ( "ForeignFunctionInterface", RestrictedFunction, Opt_ForeignFunctionInterface, nop ), ( "UnliftedFFITypes", AlwaysAllowed, Opt_UnliftedFFITypes, nop ), + ( "InterruptibleFFI", AlwaysAllowed, Opt_InterruptibleFFI, nop ), ( "GHCForeignImportPrim", AlwaysAllowed, Opt_GHCForeignImportPrim, nop ), ( "LiberalTypeSynonyms", AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ), ( "Rank2Types", AlwaysAllowed, Opt_Rank2Types, nop ), @@ -1833,8 +1847,6 @@ xFlags = [ ( "ParallelArrays", AlwaysAllowed, Opt_ParallelArrays, nop ), ( "TemplateHaskell", NeverAllowed, Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", AlwaysAllowed, Opt_QuasiQuotes, nop ), - ( "Generics", AlwaysAllowed, Opt_Generics, - \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ), ( "ImplicitPrelude", AlwaysAllowed, Opt_ImplicitPrelude, nop ), ( "RecordWildCards", AlwaysAllowed, Opt_RecordWildCards, nop ), ( "NamedFieldPuns", AlwaysAllowed, Opt_RecordPuns, nop ), @@ -1913,8 +1925,6 @@ defaultFlags ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options - ++ standardWarnings - impliedFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)] impliedFlags = [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll) @@ -1986,7 +1996,7 @@ optLevelFlags -- ----------------------------------------------------------------------------- -- Standard sets of warning options -standardWarnings :: [DynFlag] +standardWarnings :: [WarningFlag] standardWarnings = [ Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, @@ -2001,7 +2011,7 @@ standardWarnings Opt_WarnAlternativeLayoutRuleTransitional ] -minusWOpts :: [DynFlag] +minusWOpts :: [WarningFlag] -- Things you get with -W minusWOpts = standardWarnings ++ @@ -2013,7 +2023,7 @@ minusWOpts Opt_WarnDodgyImports ] -minusWallOpts :: [DynFlag] +minusWallOpts :: [WarningFlag] -- Things you get with -Wall minusWallOpts = minusWOpts ++ @@ -2025,19 +2035,6 @@ minusWallOpts Opt_WarnUnusedDoBind ] -minuswRemovesOpts :: [DynFlag] --- minuswRemovesOpts should be every warning option -minuswRemovesOpts - = minusWallOpts ++ - [Opt_WarnTabs, - Opt_WarnIncompletePatternsRecUpd, - Opt_WarnIncompleteUniPatterns, - Opt_WarnMonomorphism, - Opt_WarnUnrecognisedPragmas, - Opt_WarnAutoOrphans, - Opt_WarnImplicitPrelude - ] - enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls mapM_ setExtensionFlag glasgowExtsFlags @@ -2137,6 +2134,9 @@ hasArgDF :: (String -> DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynF hasArgDF fn deprec = HasArg (\s -> do { upd (fn s) ; deprecate deprec }) +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) @@ -2153,6 +2153,11 @@ setDynFlag f = upd (\dfs -> dopt_set dfs f) unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +-------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) ; sequence_ deps } @@ -2261,9 +2266,6 @@ setObjTarget l = updM set flag) return dflags HscLlvm - | cGhcUnregisterised == "YES" -> - do addWarn ("Compiler unregisterised, so ignoring " ++ flag) - return dflags | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && (not opt_Static || opt_PIC) -> diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index a0a9f0e3b3..f47b8be935 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -24,7 +24,7 @@ module ErrUtils ( -- * Messages during compilation putMsg, putMsgWith, errorMsg, - fatalErrorMsg, + fatalErrorMsg, fatalErrorMsg', compilationProgressMsg, showPass, debugTraceMsg, @@ -36,7 +36,7 @@ import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import Util ( sortLe ) import Outputable import SrcLoc -import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import DynFlags import StaticFlags ( opt_ErrorSpans ) import System.Exit ( ExitCode(..), exitWith ) @@ -296,7 +296,10 @@ errorMsg :: DynFlags -> Message -> IO () errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg fatalErrorMsg :: DynFlags -> Message -> IO () -fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg + +fatalErrorMsg' :: LogAction -> Message -> IO () +fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg @@ -309,5 +312,4 @@ showPass dflags what debugTraceMsg :: DynFlags -> Int -> Message -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) - \end{code} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c8ca482784..3ebfd52bad 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -319,23 +319,23 @@ import Prelude hiding (init) -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a -defaultErrorHandler dflags inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a +defaultErrorHandler la inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do hFlush stdout case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> - fatalErrorMsg dflags (text (show ioe)) + fatalErrorMsg' la (text (show ioe)) _ -> case fromException exception of Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it") + fatalErrorMsg' la (text "stack overflow: use +RTS -K<size> to increase it") _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> - fatalErrorMsg dflags + fatalErrorMsg' la (text (show (Panic (show exception)))) exitWith (ExitFailure 1) ) $ @@ -347,7 +347,7 @@ defaultErrorHandler dflags inner = case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show ge)) + _ -> do fatalErrorMsg' la (text (show ge)) exitWith (ExitFailure 1) ) $ inner @@ -737,12 +737,17 @@ loadModule tcm = do return (Just l) _otherwise -> return Nothing + let source_modified | isNothing mb_linkable = SourceModified + | otherwise = SourceUnmodified + -- we can't determine stability here + -- compile doesn't change the session hsc_env <- getSession mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg, hscInteractiveBackendOnly tcg, hscBatchBackendOnly tcg) hsc_env ms 1 1 Nothing mb_linkable + source_modified modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info } return tcm @@ -816,7 +821,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do ms_obj_date = Nothing, -- Only handling the single-module case for now, so no imports. ms_srcimps = [], - ms_imps = [], + ms_textual_imps = [], -- No source file ms_hspp_file = "", ms_hspp_opts = dflags, @@ -932,6 +937,8 @@ getModuleInfo mdl = withSession $ \hsc_env -> do {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing else -} liftIO $ getPackageModuleInfo hsc_env mdl + -- ToDo: we don't understand what the following comment means. + -- (SDM, 19/7/2011) -- getPackageModuleInfo will attempt to find the interface, so -- we don't want to call it for a home module, just in case there -- was a problem loading the module and the interface doesn't diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 8ccf0a5a81..dece548043 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2011 @@ -735,15 +737,16 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods where iface = hm_iface hm_info - compile_it :: Maybe Linkable -> IO HomeModInfo - compile_it mb_linkable = + compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo + compile_it mb_linkable src_modified = compile hsc_env summary' mod_index nmods - mb_old_iface mb_linkable + mb_old_iface mb_linkable src_modified - compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo - compile_it_discard_iface mb_linkable = + compile_it_discard_iface :: Maybe Linkable -> SourceModified + -> IO HomeModInfo + compile_it_discard_iface mb_linkable src_modified = compile hsc_env summary' mod_index nmods - Nothing mb_linkable + Nothing mb_linkable src_modified -- With the HscNothing target we create empty linkables to avoid -- recompilation. We have to detect these to recompile anyway if @@ -776,7 +779,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods (text "compiling stable on-disk mod:" <+> ppr this_mod_name) linkable <- liftIO $ findObjectLinkable this_mod obj_fn (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) + compile_it (Just linkable) SourceUnmodifiedAndStable -- object is stable, but we need to load the interface -- off disk to make a HMI. @@ -797,7 +800,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods linkableTime l >= ms_hs_date summary -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) + compile_it (Just l) SourceUnmodified -- we have an old BCO that is up to date with respect -- to the source: do a recompilation check as normal. @@ -819,17 +822,17 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods isObjectLinkable l && linkableTime l == obj_date -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) + compile_it (Just l) SourceUnmodified _otherwise -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) + compile_it_discard_iface (Just linkable) SourceUnmodified _otherwise -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing + compile_it Nothing SourceModified @@ -1254,7 +1257,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_imps = the_imps, + ms_srcimps = srcimps, ms_textual_imps = the_imps, ms_hs_date = src_timestamp, ms_obj_date = obj_timestamp }) @@ -1379,8 +1382,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ms_hspp_file = hspp_fn, ms_hspp_opts = dflags', ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, ms_hs_date = src_timestamp, ms_obj_date = obj_timestamp })) @@ -1458,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 a8bb18d510..2603d21bc4 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 -- ----------------------------------------------------------------------------- @@ -484,7 +487,7 @@ type InteractiveResult = (InteractiveStatus, ModIface, ModDetails) -- 'interactive' mode. They should be removed from 'oneshot' mode. type Compiler result = HscEnv -> ModSummary - -> Bool -- True <=> source unchanged + -> SourceModified -> Maybe ModIface -- Old interface, if available -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) -> IO result @@ -512,38 +515,64 @@ data HsCompiler a } genericHscCompile :: HsCompiler a - -> (HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO ()) - -> HscEnv -> ModSummary -> Bool + -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()) + -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> Maybe (Int, Int) -> IO a genericHscCompile compiler hscMessage hsc_env - mod_summary source_unchanged + mod_summary source_modified mb_old_iface0 mb_mod_index = do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} checkOldIface hsc_env mod_summary - source_unchanged mb_old_iface0 + source_modified mb_old_iface0 -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk. let mb_old_hash = fmap mi_iface_hash mb_checked_iface + + let + skip iface = do + hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary + runHsc hsc_env $ hscNoRecomp compiler iface + + compile reason = do + hscMessage hsc_env mb_mod_index reason mod_summary + runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash + + stable = case source_modified of + SourceUnmodifiedAndStable -> True + _ -> False + + -- If the module used TH splices when it was last compiled, + -- then the recompilation check is not accurate enough (#481) + -- and we must ignore it. However, if the module is stable + -- (none of the modules it depends on, directly or indirectly, + -- changed), then we *can* skip recompilation. This is why + -- the SourceModified type contains SourceUnmodifiedAndStable, + -- and it's pretty important: otherwise ghc --make would + -- always recompile TH modules, even if nothing at all has + -- changed. Stability is just the same check that make is + -- doing for us in one-shot mode. + case mb_checked_iface of - Just iface | not recomp_reqd - -> do hscMessage hsc_env mb_mod_index False mod_summary - runHsc hsc_env $ hscNoRecomp compiler iface - _otherwise - -> do hscMessage hsc_env mb_mod_index True mod_summary - runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash + Just iface | not recomp_reqd -> + if mi_used_th iface && not stable + then compile RecompForcedByTH + else skip iface + _otherwise -> + compile RecompRequired + hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a hscCheckRecompBackend compiler tc_result - hsc_env mod_summary source_unchanged mb_old_iface _m_of_n + hsc_env mod_summary source_modified mb_old_iface _m_of_n = do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} checkOldIface hsc_env mod_summary - source_unchanged mb_old_iface + source_modified mb_old_iface let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of @@ -746,24 +775,31 @@ genModDetails old_iface -- Progress displayers. -------------------------------------------------------------- -oneShotMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO () -oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = - if recomp - then return () - else compilationProgressMsg (hsc_dflags hsc_env) $ - "compilation IS NOT required" +data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH + deriving Eq -batchMsg :: HscEnv -> Maybe (Int,Int) -> Bool -> ModSummary -> IO () +oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = + case recomp of + RecompNotRequired -> + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + _other -> + return () + +batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () batchMsg hsc_env mb_mod_index recomp mod_summary - = do - let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ - (showModuleIndex mb_mod_index ++ - msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) - if recomp - then showMsg "Compiling " - else if verbosity (hsc_dflags hsc_env) >= 2 - then showMsg "Skipping " - else return () + = case recomp of + RecompRequired -> showMsg "Compiling " + RecompNotRequired + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " + | otherwise -> return () + RecompForcedByTH -> showMsg "Compiling [TH] " + where + showMsg msg = + compilationProgressMsg (hsc_dflags hsc_env) $ + (showModuleIndex mb_mod_index ++ + msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) (recomp == RecompRequired) mod_summary) -------------------------------------------------------------- -- FrontEnds @@ -778,7 +814,7 @@ hscFileFrontEnd mod_summary = do ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module dflags <- getDynFlags - -- XXX: See Note [SafeHaskell API] + -- XXX: See Note [Safe Haskell API] if safeHaskellOn dflags then do tcg_env1 <- checkSafeImports dflags hsc_env tcg_env @@ -805,24 +841,53 @@ hscFileFrontEnd mod_summary = do warnRules (L loc (HsRule n _ _ _ _ _ _)) = mkPlainWarnMsg loc $ text "Rule \"" <> ftext n <> text "\" ignored" $+$ - text "User defined rules are disabled under SafeHaskell" + text "User defined rules are disabled under Safe Haskell" -------------------------------------------------------------- --- SafeHaskell +-- Safe Haskell -------------------------------------------------------------- +-- Note [Safe Haskell API] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- XXX: We only call this in hscFileFrontend and don't expose +-- it to the GHC API. External users of GHC can't properly use +-- the GHC API and Safe Haskell. + + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + -- | Validate that safe imported modules are actually safe. -- For modules in the HomePackage (the package the module we -- are compiling in resides) this just involves checking its -- trust type is 'Safe' or 'Trustworthy'. For modules that -- reside in another package we also must check that the --- external pacakge is trusted. +-- external pacakge is trusted. See the Note [Safe Haskell +-- Trust Check] above for more information. -- --- Note [SafeHaskell API] --- ~~~~~~~~~~~~~~~~~~~~~~ --- XXX: We only call this in hscFileFrontend and don't expose --- it to the GHC API. External users of GHC can't properly use --- the GHC API and SafeHaskell. +-- The code for this is quite tricky as the whole algorithm +-- is done in a few distinct phases in different parts of the +-- code base. See RnNames.rnImportDecl for where package trust +-- dependencies for a module are collected and unioned. +-- Specifically see the Note [RnNames . Tracking Trust Transitively] +-- and the Note [RnNames . Trust Own Package]. checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv checkSafeImports dflags hsc_env tcg_env = do @@ -873,9 +938,9 @@ checkSafeImports dflags hsc_env tcg_env -- that their package is trusted. For trustworthy modules, -- modules in the home package are trusted but otherwise -- we check the package trust flag. - packageTrusted :: SafeHaskellMode -> Module -> Bool - packageTrusted Sf_Safe _ = True - packageTrusted _ m + packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted Sf_Safe False _ = True + packageTrusted _ _ m | isHomePkg m = True | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId m) @@ -894,11 +959,11 @@ checkSafeImports dflags hsc_env tcg_env -- got iface, check trust Just iface' -> do let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' -- check module is trusted - safeM = trust `elem` [Sf_Safe, Sf_Trustworthy, - Sf_TrustworthyWithSafeLanguage] + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] -- check package is trusted - safeP = packageTrusted trust m + safeP = packageTrusted trust trust_own_pkg m if safeM && safeP then return Nothing else return $ Just $ if safeM @@ -1025,6 +1090,7 @@ hscGenHardCode cgguts mod_summary cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + platform = targetPlatform dflags location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -1060,7 +1126,7 @@ hscGenHardCode cgguts mod_summary -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms - dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -1131,10 +1197,11 @@ tryNewCodeGen :: HscEnv -> Module -> [TyCon] tryNewCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do { let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags ; prog <- StgCmm.codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" - (pprCmms prog) + (pprCmms platform prog) -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. @@ -1143,7 +1210,7 @@ tryNewCodeGen hsc_env this_mod data_tycons ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog ; let prog' = map cmmOfZgraph (srtToData topSRT : prog) - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog') ; return prog' } @@ -1160,11 +1227,12 @@ optionallyConvertAndOrCPS hsc_env cmms = testCmmConversion :: HscEnv -> Cmm -> IO Cmm testCmmConversion hsc_env cmm = do let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags showPass dflags "CmmToCmm" - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' - let zgraph = initUs_ us (cmmToZgraph cmm) + let zgraph = initUs_ us (cmmToZgraph platform cmm) chosen_graph <- if dopt Opt_RunCPSZ dflags then do us <- mkSplitUniqSupply 'S' @@ -1172,10 +1240,10 @@ testCmmConversion hsc_env cmm = (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph return zgraph else return (runCmmContFlowOpts zgraph) - dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph) showPass dflags "Convert from Z back to Cmm" let cvt = cmmOfZgraph chosen_graph - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt) return cvt myCoreToStg :: DynFlags -> Module -> [CoreBind] @@ -1378,6 +1446,7 @@ mkModGuts mod binds = ModGuts { mg_deps = noDependencies, mg_dir_imps = emptyModuleEnv, mg_used_names = emptyNameSet, + mg_used_th = False, mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, mg_types = emptyTypeEnv, @@ -1393,7 +1462,8 @@ mkModGuts mod binds = ModGuts { mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, - mg_fam_inst_env = emptyFamInstEnv + mg_fam_inst_env = emptyFamInstEnv, + mg_trust_pkg = False } \end{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 1edce70d08..d43105b02d 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -17,8 +17,9 @@ module HscTypes ( ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ImportedMods, ImportedModsVal, - ModSummary(..), ms_mod_name, showModMsg, isBootSummary, + ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), -- * Information about the module being compiled HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases @@ -130,8 +131,7 @@ import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..), SafeHaskellMode(..) ) +import DynFlags import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) @@ -147,8 +147,6 @@ import FastString import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils -import Data.Dynamic ( Typeable ) -import qualified Data.Dynamic as Dyn import Bag import ErrUtils @@ -161,6 +159,7 @@ import Data.Map (Map) import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception +import Data.Typeable ( Typeable ) -- ----------------------------------------------------------------------------- -- Source Errors @@ -191,18 +190,13 @@ throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err -- -- See 'printExceptionAndWarnings' for more information on what to take care -- of when writing a custom error handler. -data SourceError = SourceError ErrorMessages +newtype SourceError = SourceError ErrorMessages + deriving Typeable instance Show SourceError where show (SourceError msgs) = unlines . map show . bagToList $ msgs -- ToDo: is there some nicer way to print this? -sourceErrorTc :: Dyn.TyCon -sourceErrorTc = Dyn.mkTyCon "SourceError" -{-# NOINLINE sourceErrorTc #-} -instance Typeable SourceError where - typeOf _ = Dyn.mkTyConApp sourceErrorTc [] - instance Exception SourceError mkSrcErr = SourceError @@ -219,17 +213,12 @@ handleSourceError handler act = srcErrorMessages (SourceError msgs) = msgs -- | XXX: what exactly is an API error? -data GhcApiError = GhcApiError SDoc +newtype GhcApiError = GhcApiError SDoc + deriving Typeable instance Show GhcApiError where show (GhcApiError msg) = showSDoc msg -ghcApiErrorTc :: Dyn.TyCon -ghcApiErrorTc = Dyn.mkTyCon "GhcApiError" -{-# NOINLINE ghcApiErrorTc #-} -instance Typeable GhcApiError where - typeOf _ = Dyn.mkTyConApp ghcApiErrorTc [] - instance Exception GhcApiError mkApiErr = GhcApiError @@ -246,7 +235,7 @@ printOrThrowWarnings dflags warns handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns - = when (dopt Opt_WarnDeprecatedFlags dflags) $ do + = when (wopt Opt_WarnDeprecatedFlags dflags) $ do -- It would be nicer if warns :: [Located Message], but that -- has circular import problems. let bag = listToBag [ mkPlainWarnMsg loc (text warn) @@ -627,6 +616,8 @@ data ModIface mi_exp_hash :: !Fingerprint, -- ^ Hash of export list + mi_used_th :: !Bool, -- ^ Module required TH splices when it was compiled. This disables recompilation avoidance (see #481). + mi_fixities :: [(OccName,Fixity)], -- ^ Fixities @@ -687,8 +678,15 @@ data ModIface -- The 'OccName' is the parent of the name, if it has one. mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. - mi_trust :: !IfaceTrustInfo + mi_trust :: !IfaceTrustInfo, -- ^ Safe Haskell Trust information for this module. + mi_trust_pkg :: !Bool + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [RnNames . Trust Own Package] } -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' @@ -739,7 +737,8 @@ data ModGuts -- generate initialisation code mg_used_names:: !NameSet, -- ^ What the module needed (used in 'MkIface.mkIface') - mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment -- These fields all describe the things **declared in this module** mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module @@ -767,9 +766,12 @@ data ModGuts mg_inst_env :: InstEnv, -- ^ Class instance environment from /home-package/ modules (including -- this one); c.f. 'tcg_inst_env' - mg_fam_inst_env :: FamInstEnv + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_trust_pkg :: Bool + -- ^ Do we need to trust our own package for Safe Haskell? + -- See Note [RnNames . Trust Own Package] } -- The ModGuts takes on several slightly different forms: @@ -848,7 +850,8 @@ emptyModIface mod mi_usages = [], mi_exports = [], mi_exp_hash = fingerprint0, - mi_fixities = [], + mi_used_th = False, + mi_fixities = [], mi_warns = NoWarnings, mi_anns = [], mi_insts = [], @@ -862,7 +865,8 @@ emptyModIface mod mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache, mi_hpc = False, - mi_trust = noIfaceTrustInfo + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False } \end{code} @@ -1435,19 +1439,21 @@ type IsBootInterface = Bool data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ Home-package module dependencies - , dep_pkgs :: [(PackageId, Bool)] - -- ^ External package dependencies - , dep_orphs :: [Module] - -- ^ Orphan modules (whether home or external pkg), - -- *not* including family instance orphans as they - -- are anyway included in 'dep_finsts' - , dep_finsts :: [Module] + , dep_pkgs :: [(PackageId, Bool)] + -- ^ External package dependencies. The bool indicates + -- if the package is required to be trusted when the + -- module is imported as a safe import (Safe Haskell). + -- See Note [RnNames . Tracking Trust Transitively] + , dep_orphs :: [Module] + -- ^ Orphan modules (whether home or external pkg), + -- *not* including family instance orphans as they + -- are anyway included in 'dep_finsts' + , dep_finsts :: [Module] -- ^ Modules that contain family instances (whether the -- instances are from the home or an external package) } deriving( Eq ) - -- Equality used only for old/new comparison in MkIface.addVersionInfo - + -- Equality used only for old/new comparison in MkIface.addVersionInfo -- See 'TcRnTypes.ImportAvails' for details on dependencies. noDependencies :: Dependencies @@ -1643,22 +1649,38 @@ emptyMG = [] -- * An external-core source module data ModSummary = ModSummary { - ms_mod :: Module, -- ^ Identity of the module - ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core - ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: ClockTime, -- ^ Timestamp of source file - ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one - ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module - ms_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module - ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file - ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ + ms_mod :: Module, -- ^ Identity of the module + ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core + ms_location :: ModLocation, -- ^ Location of the various files belonging to the module + ms_hs_date :: ClockTime, -- ^ Timestamp of source file + ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one + ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module + ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text* + ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ -- and @LANGUAGE@ pragmas in the modules source code - ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it + ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it } ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod +ms_imps :: ModSummary -> [Located (ImportDecl RdrName)] +ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + -- This is a not-entirely-satisfactory means of creating an import that corresponds to an + -- import that did not occur in the program text, such as those induced by the use of + -- plugins (the -plgFoo flag) + mk_additional_import mod_nm = noLoc $ ImportDecl { + ideclName = noLoc mod_nm, + ideclPkgQual = Nothing, + ideclSource = False, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing, + ideclSafe = False + } + -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been -- done. The point is that the summariser will have to cpp/unlit/whatever @@ -1684,7 +1706,7 @@ instance Outputable ModSummary where nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), text "ms_mod =" <+> ppr (ms_mod ms) <> text (hscSourceString (ms_hsc_src ms)) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), char '}' ] @@ -1705,6 +1727,30 @@ showModMsg target recomp mod_summary mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) \end{code} +%************************************************************************ +%* * +\subsection{Recmpilation} +%* * +%************************************************************************ + +\begin{code} +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. +\end{code} %************************************************************************ %* * @@ -1838,27 +1884,20 @@ trustInfoToNum it = case getSafeMode it of Sf_None -> 0 Sf_SafeImports -> 1 - Sf_SafeLanguage -> 2 - Sf_Trustworthy -> 3 - Sf_TrustworthyWithSafeLanguage -> 4 - Sf_Safe -> 5 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 numToTrustInfo :: Word8 -> IfaceTrustInfo numToTrustInfo 0 = setSafeMode Sf_None numToTrustInfo 1 = setSafeMode Sf_SafeImports -numToTrustInfo 2 = setSafeMode Sf_SafeLanguage -numToTrustInfo 3 = setSafeMode Sf_Trustworthy -numToTrustInfo 4 = setSafeMode Sf_TrustworthyWithSafeLanguage -numToTrustInfo 5 = setSafeMode Sf_Safe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_None) = ptext $ sLit "none" ppr (TrustInfo Sf_SafeImports) = ptext $ sLit "safe-imports" - ppr (TrustInfo Sf_SafeLanguage) = ptext $ sLit "safe-language" ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" - ppr (TrustInfo Sf_TrustworthyWithSafeLanguage) - = ptext $ sLit "trustworthy + safe-language" ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" \end{code} diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1df5255dbe..0386273de8 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -197,7 +197,7 @@ runStmtWithLocation source linenumber expr step = -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index f6d0af2665..c542d761f0 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -72,6 +72,7 @@ module StaticFlags ( -- misc opts opt_IgnoreDotGhci, + opt_GhciScripts, opt_ErrorSpans, opt_GranMacros, opt_HiVersion, @@ -92,7 +93,7 @@ module StaticFlags ( import Config import FastString import Util -import Maybes ( firstJusts ) +import Maybes ( firstJusts, catMaybes ) import Panic import Data.Maybe ( listToMaybe ) @@ -121,6 +122,7 @@ lookUp :: FastString -> Bool lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String +lookup_all_str :: String -> [String] -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. @@ -151,6 +153,10 @@ lookup_str sw Just str -> Just str Nothing -> Nothing +lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where + f ('=' : str) = str + f str = str + lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -189,6 +195,9 @@ unpacked_opts = opt_IgnoreDotGhci :: Bool opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") + +opt_GhciScripts :: [String] +opt_GhciScripts = lookup_all_str "-ghci-script" -- debugging options -- | Suppress all that is suppressable in core dumps. @@ -222,7 +231,7 @@ opt_SuppressIdInfo = lookUp (fsLit "-dsuppress-all") || lookUp (fsLit "-dsuppress-idinfo") --- | Suppress seprate type signatures in core, but leave types on lambda bound vars +-- | Suppress separate type signatures in core, but leave types on lambda bound vars opt_SuppressTypeSignatures :: Bool opt_SuppressTypeSignatures = lookUp (fsLit "-dsuppress-all") diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index e40312cd7e..ea11a20db8 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -162,8 +162,6 @@ initSysTools mbMinusB ; let settingsFile = top_dir </> "settings" installed :: FilePath -> FilePath installed file = top_dir </> file - installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file - installed_perl_bin file = top_dir </> ".." </> "perl" </> file ; settingsStr <- readFile settingsFile ; mySettings <- case maybeReadFuzzy settingsStr of @@ -173,7 +171,14 @@ initSysTools mbMinusB pgmError ("Can't parse " ++ show settingsFile) ; let getSetting key = case lookup key mySettings of Just xs -> - return xs + return $ case stripPrefix "$topdir" xs of + Just [] -> + top_dir + Just xs'@(c:_) + | isPathSeparator c -> + top_dir ++ xs' + _ -> + xs Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile) ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts" -- On Windows, mingw is distributed with GHC, @@ -181,14 +186,10 @@ initSysTools mbMinusB -- It would perhaps be nice to be able to override this -- with the settings file, but it would be a little fiddly -- to make that possible, so for now you can't. - ; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc" - else getSetting "C compiler command" - ; gcc_args_str <- if isWindowsHost then return [] - else getSetting "C compiler flags" + ; gcc_prog <- getSetting "C compiler command" + ; gcc_args_str <- getSetting "C compiler flags" ; let gcc_args = map Option (words gcc_args_str) - ; perl_path <- if isWindowsHost - then return $ installed_perl_bin "perl" - else getSetting "perl command" + ; perl_path <- getSetting "perl command" ; let pkgconfig_path = installed "package.conf.d" ghc_usage_msg_path = installed "ghc-usage.txt" @@ -201,16 +202,13 @@ initSysTools mbMinusB -- split is a Perl script split_script = installed cGHC_SPLIT_PGM - windres_path = installed_mingw_bin "windres" + ; windres_path <- getSetting "windres command" ; tmpdir <- getTemporaryDirectory - ; let - -- 'touch' is a GHC util for Windows - touch_path - | isWindowsHost = installed cGHC_TOUCHY_PGM - | otherwise = "touch" - -- On Win32 we don't want to rely on #!/bin/perl, so we prepend + ; touch_path <- getSetting "touch command" + + ; let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend -- a call to Perl to get the invocation of split. -- On Unix, scripts are invoked using the '#!' method. Binary -- installations of GHC on Unix place the correct line on the @@ -219,11 +217,8 @@ initSysTools mbMinusB (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - (mkdll_prog, mkdll_args) - | not isWindowsHost - = panic "Can't build DLLs on a non-Win32 system" - | otherwise = - (installed_mingw_bin cMKDLL, []) + ; mkdll_prog <- getSetting "dllwrap command" + ; let mkdll_args = [] -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix @@ -274,7 +269,6 @@ initSysTools mbMinusB sOpt_F = [], sOpt_c = [], sOpt_a = [], - sOpt_m = [], sOpt_l = [], sOpt_windres = [], sOpt_lo = [], @@ -460,7 +454,9 @@ figureLlvmVersion dflags = do return $ Just v ) (\err -> do - putMsg dflags $ text $ "Warning: " ++ show err + putMsg dflags $ text $ "Error (" ++ show err ++ ")" + putMsg dflags $ text "Warning: Couldn't figure out LLVM version!" + putMsg dflags $ text "Make sure you have installed LLVM" return Nothing) return ver diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index c3be64b60a..bad78c2277 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -701,111 +701,142 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Id -> ([Id],Bool) +addExternal :: Bool -> Id -> ([Id], Bool) addExternal expose_all id = (new_needed_ids, show_unfold) where - new_needed_ids = unfold_ids ++ - filter (\id -> isLocalId id && - not (id `elemVarSet` unfold_set)) - (varSetElems spec_ids) -- XXX non-det ordering - + new_needed_ids = bndrFvsInOrder show_unfold id idinfo = idInfo id + show_unfold = show_unfolding (unfoldingInfo idinfo) never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) - loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) + loop_breaker = isStrongLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig) - spec_ids = specInfoFreeVars (specInfo idinfo) -- Stuff to do with the Id's unfolding -- We leave the unfolding there even if there is a worker - -- In GHCI the unfolding is used by importers - show_unfold = isJust mb_unfold_ids - (unfold_set, unfold_ids) = mb_unfold_ids `orElse` (emptyVarSet, []) - - mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold - mb_unfold_ids = case unfoldingInfo idinfo of - CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } - | show_unfolding src guide - -> Just (unf_ext_ids src unf_rhs) - DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops)) - _ -> Nothing - where - unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v]) - unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs - -- For a wrapper, externalise the wrapper id rather than the - -- fvs of the rhs. The two usually come down to the same thing - -- but I've seen cases where we had a wrapper id $w but a - -- rhs where $w had been inlined; see Trac #3922 - - show_unfolding unf_source unf_guidance + -- In GHCi the unfolding is used by importers + + show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) = expose_all -- 'expose_all' says to expose all -- unfoldings willy-nilly - || isStableSource unf_source -- Always expose things whose - -- source is an inline rule + || isStableSource src -- Always expose things whose + -- source is an inline rule || not (bottoming_fn -- No need to inline bottom functions || never_active -- Or ones that say not to || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance unf_guidance) + || neverUnfoldGuidance guidance) + show_unfolding (DFunUnfolding {}) = True + show_unfolding _ = False +\end{code} --- We want a deterministic free-variable list. exprFreeVars gives us --- a VarSet, which is in a non-deterministic order when converted to a --- list. Hence, here we define a free-variable finder that returns --- the free variables in the order that they are encountered. --- --- Note [choosing external names] +%************************************************************************ +%* * + Deterministic free variables +%* * +%************************************************************************ -exprFvsInOrder :: CoreExpr -> (VarSet, [Id]) -exprFvsInOrder e = run (dffvExpr e) +We want a deterministic free-variable list. exprFreeVars gives us +a VarSet, which is in a non-deterministic order when converted to a +list. Hence, here we define a free-variable finder that returns +the free variables in the order that they are encountered. -exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id]) -exprsFvsInOrder es = run (mapM_ dffvExpr es) +Note [choosing external names] -run :: DFFV () -> (VarSet, [Id]) -run (DFFV m) = case m emptyVarSet [] of - (set,ids,_) -> (set,ids) +\begin{code} +bndrFvsInOrder :: Bool -> Id -> [Id] +bndrFvsInOrder show_unfold id + = run (dffvLetBndr show_unfold id) -newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a)) +run :: DFFV () -> [Id] +run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of + ((_,ids),_) -> ids + +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope + -- we don't want to record these as free vars + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> ((VarSet,[Var]),a)) -- Output state instance Monad DFFV where - return a = DFFV $ \set ids -> (set, ids, a) - (DFFV m) >>= k = DFFV $ \set ids -> - case m set ids of - (set',ids',a) -> case k a of - DFFV f -> f set' ids' + return a = DFFV $ \_ st -> (st, a) + (DFFV m) >>= k = DFFV $ \env st -> + case m env st of + (st',a) -> case k a of + DFFV f -> f env st' + +extendScope :: Var -> DFFV a -> DFFV a +extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) + +extendScopeList :: [Var] -> DFFV a -> DFFV a +extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) insert :: Var -> DFFV () -insert v = DFFV $ \ set ids -> case () of - _ | v `elemVarSet` set -> (set,ids,()) - | otherwise -> (extendVarSet set v, v:ids, ()) +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && + not (v `elemVarSet` env) && + not (v `elemVarSet` set) + in if keep_me + then ((extendVarSet set v, v:ids), ()) + else ((set, ids), ()) + dffvExpr :: CoreExpr -> DFFV () -dffvExpr e = go emptyVarSet e +dffvExpr (Var v) = insert v +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (Note _ e) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ + (mapM_ dffvBind prs >> dffvExpr e) +dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) +dffvExpr _other = return () + +dffvAlt :: (t, [Var], CoreExpr) -> DFFV () +dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) + +dffvBind :: (Id, CoreExpr) -> DFFV () +dffvBind(x,r) = dffvLetBndr True x >> dffvExpr r + +dffvLetBndr :: Bool -> Id -> DFFV () +dffvLetBndr show_unfold id + | not (isId id) = return () + | otherwise + = do { when show_unfold (go_unf (unfoldingInfo idinfo)) + ; extendScope id $ -- See Note [Rule free var hack] in CoreFVs + mapM_ go_rule (specInfoRules (specInfo idinfo)) } where - go scope e = case e of - Var v | isLocalId v && not (v `elemVarSet` scope) -> insert v - App e1 e2 -> do go scope e1; go scope e2 - Lam v e -> go (extendVarSet scope v) e - Note _ e -> go scope e - Cast e _ -> go scope e - Let (NonRec x r) e -> do go scope r; go (extendVarSet scope x) e - Let (Rec prs) e -> do let scope' = extendVarSetList scope (map fst prs) - mapM_ (go scope') (map snd prs) - go scope' e - Case e b _ as -> do go scope e - mapM_ (go_alt (extendVarSet scope b)) as - _other -> return () - - go_alt scope (_,xs,r) = go (extendVarSetList scope xs) r + idinfo = idInfo id + + go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + = case src of + InlineWrapper v -> insert v + _ -> dffvExpr rhs + -- For a wrapper, externalise the wrapper id rather than the + -- fvs of the rhs. The two usually come down to the same thing + -- but I've seen cases where we had a wrapper id $w but a + -- rhs where $w had been inlined; see Trac #3922 + + go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr args + go_unf _ = return () + + go_rule (BuiltinRule {}) = return () + go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) + = extendScopeList bndrs (dffvExpr rhs) \end{code} --------------------------------------------------------------------- --- tidyTopName --- This is where we set names to local/global based on whether they really are --- externally visible (see comment at the top of this module). If the name --- was previously local, we have to give it a unique occurrence name if --- we intend to externalise it. +%************************************************************************ +%* * + tidyTopName +%* * +%************************************************************************ + +This is where we set names to local/global based on whether they really are +externally visible (see comment at the top of this module). If the name +was previously local, we have to give it a unique occurrence name if +we intend to externalise it. \begin{code} tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 1ea83e8e88..94b0258f57 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -62,6 +62,7 @@ import DynFlags import StaticFlags import Util +import BasicTypes ( Alignment ) import Digraph import Pretty (Doc) import qualified Pretty @@ -131,31 +132,32 @@ The machine-dependent bits break down as follows: -- ----------------------------------------------------------------------------- -- Top-level of the native codegen -data NcgImpl instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr), +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, - shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmTop :: NatCmmTop instr -> Doc, + pprNatCmmTop :: Platform -> NatCmmTop statics instr -> Doc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], - ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr], - ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr], + ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] } -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms - = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut - ,shortcutStatic = X86.Instr.shortcutStatic + ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmTop = X86.Ppr.pprNatCmmTop ,maxSpillSlots = X86.Instr.maxSpillSlots @@ -173,7 +175,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatic = PPC.RegInfo.shortcutStatic + ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop ,maxSpillSlots = PPC.Instr.maxSpillSlots @@ -188,7 +190,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop ,maxSpillSlots = SPARC.Instr.maxSpillSlots @@ -197,18 +199,21 @@ nativeCodeGen dflags h us cmms ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop ,ncgMakeFarBranches = id } + ArchARM -> + panic "nativeCodeGen: No NCG for ARM" ArchPPC_64 -> panic "nativeCodeGen: No NCG for PPC 64" ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Instruction instr, Outputable instr) +nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do - let split_cmms = concat $ map add_split cmms + let platform = targetPlatform dflags + split_cmms = concat $ map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). @@ -222,7 +227,7 @@ nativeCodeGen' dflags ncgImpl h us cmms -- dump native code dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) $ concat native) -- dump global NCG stats for graph coloring allocator (case concat $ catMaybes colorStats of @@ -240,10 +245,10 @@ nativeCodeGen' dflags ncgImpl h us cmms dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" $ Color.dotGraph - targetRegDotColor - (Color.trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) $ graphGlobal) @@ -263,25 +268,25 @@ nativeCodeGen' dflags ncgImpl h us cmms | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph []) + split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Instruction instr, Outputable instr) +cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply -> [RawCmmTop] -> [[CLabel]] - -> [ ([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + -> [ ([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats]) ] -> Int -> IO ( [[CLabel]], - [([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + [([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats])] ) cmmNativeGens _ _ _ _ [] impAcc profAcc _ @@ -293,7 +298,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count <- cmmNativeGen dflags ncgImpl us cmm count Pretty.bufLeftRender h - $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl (targetPlatform dflags)) native -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let @@ -323,20 +328,21 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: (Instruction instr, Outputable instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmTop -- ^ the cmm to generate code for -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do + let platform = targetPlatform dflags -- rewrite assignments to global regs let fixed_cmm = @@ -350,7 +356,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [opt_cmm]) + (pprCmm platform $ Cmm [opt_cmm]) -- generate native code from cmm let ((native, lastMinuteImports), usGen) = @@ -359,18 +365,18 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) native) -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} initUs usGen - $ mapUs regLiveness + $ mapUs (regLiveness platform) $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) + (vcat $ map (pprPlatform platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -380,7 +386,7 @@ cmmNativeGen dflags ncgImpl us cmm count -- the regs usable for allocation let (alloc_regs :: UniqFM (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg r) (unitUniqSet r)) + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM $ allocatableRegs ncgImpl @@ -397,14 +403,14 @@ cmmNativeGen dflags ncgImpl us cmm count -- dump out what happened during register allocation dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) + $$ pprPlatform platform stats) $ zip [0..] regAllocStats) let mPprStats = @@ -428,7 +434,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) let mPprStats = if dopt Opt_D_dump_asm_stats dflags @@ -472,7 +478,7 @@ cmmNativeGen dflags ncgImpl us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) expanded) return ( usAlloc , expanded @@ -481,7 +487,7 @@ cmmNativeGen dflags ncgImpl us cmm count , ppr_raStatsLinear) -x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr +x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top x86fp_kludge (CmmProc info lbl (ListGraph code)) = CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) @@ -554,7 +560,7 @@ makeImportsDoc dflags imports sequenceTop :: Instruction instr - => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr + => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr sequenceTop _ top@(CmmData _ _) = top sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = @@ -668,8 +674,8 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl instr jumpDest - -> [NatCmmTop instr] -> [NatCmmTop instr] + :: NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] -> [NatCmmTop statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] @@ -680,9 +686,9 @@ generateJumpTables ncgImpl xs = concatMap f xs shortcutBranches :: DynFlags - -> NcgImpl instr jumpDest - -> [NatCmmTop instr] - -> [NatCmmTop instr] + -> NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] + -> [NatCmmTop statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -691,7 +697,7 @@ shortcutBranches dflags ncgImpl tops (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops mapping = foldr plusUFM emptyUFM mappings -build_mapping :: NcgImpl instr jumpDest +build_mapping :: NcgImpl statics instr jumpDest -> GenCmmTop d t (ListGraph instr) -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) @@ -721,14 +727,12 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest -apply_mapping :: NcgImpl instr jumpDest +apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest - -> GenCmmTop CmmStatic h (ListGraph instr) - -> GenCmmTop CmmStatic h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ map short_bb blocks) where @@ -759,10 +763,10 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) genMachCode :: DynFlags - -> (RawCmmTop -> NatM [NatCmmTop instr]) + -> (RawCmmTop -> NatM [NatCmmTop statics instr]) -> RawCmmTop -> UniqSM - ( [NatCmmTop instr] + ( [NatCmmTop statics instr] , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 918198cb9c..b2db2ef206 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -1,11 +1,11 @@ module Instruction ( - RegUsage(..), - noUsage, - NatCmm, - NatCmmTop, - NatBasicBlock, - Instruction(..) + RegUsage(..), + noUsage, + NatCmm, + NatCmmTop, + NatBasicBlock, + Instruction(..) ) where @@ -14,19 +14,20 @@ import Reg import BlockId import OldCmm +import Platform -- | Holds a list of source and destination registers used by a --- particular instruction. +-- particular instruction. -- -- Machine registers that are pre-allocated to stgRegs are filtered --- out, because they are uninteresting from a register allocation --- standpoint. (We wouldn't want them to end up on the free list!) +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) -- -- As far as we are concerned, the fixed registers simply don't exist --- (for allocation purposes, anyway). +-- (for allocation purposes, anyway). -- -data RegUsage - = RU [Reg] [Reg] +data RegUsage + = RU [Reg] [Reg] -- | No regs read or written to. noUsage :: RegUsage @@ -36,124 +37,127 @@ noUsage = RU [] [] -- Our flavours of the Cmm types -- Type synonyms for Cmm populated with native code type NatCmm instr - = GenCmm - CmmStatic - [CmmStatic] - (ListGraph instr) + = GenCmm + CmmStatics + (Maybe CmmStatics) + (ListGraph instr) -type NatCmmTop instr - = GenCmmTop - CmmStatic - [CmmStatic] - (ListGraph instr) +type NatCmmTop statics instr + = GenCmmTop + statics + (Maybe CmmStatics) + (ListGraph instr) type NatBasicBlock instr - = GenBasicBlock instr + = GenBasicBlock instr -- | Common things that we can do with instructions, on all architectures. --- These are used by the shared parts of the native code generator, --- specifically the register allocators. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. -- -class Instruction instr where - - -- | Get the registers that are being used by this instruction. - -- regUsage doesn't need to do any trickery for jumps and such. - -- Just state precisely the regs read and written by that insn. - -- The consequences of control flow transfers, as far as register - -- allocation goes, are taken care of by the register allocator. - -- - regUsageOfInstr - :: instr - -> RegUsage - - - -- | Apply a given mapping to all the register references in this - -- instruction. - patchRegsOfInstr - :: instr - -> (Reg -> Reg) - -> instr - - - -- | Checks whether this instruction is a jump/branch instruction. - -- One that can change the flow of control in a way that the - -- register allocator needs to worry about. - isJumpishInstr - :: instr -> Bool - - - -- | Give the possible destinations of this jump instruction. - -- Must be defined for all jumpish instructions. - jumpDestsOfInstr - :: instr -> [BlockId] - - - -- | Change the destination of this jump instruction. - -- Used in the linear allocator when adding fixup blocks for join - -- points. - patchJumpInstr - :: instr - -> (BlockId -> BlockId) - -> instr - - - -- | An instruction to spill a register into a spill slot. - mkSpillInstr - :: Reg -- ^ the reg to spill - -> Int -- ^ the current stack delta - -> Int -- ^ spill slot to use - -> instr - - - -- | An instruction to reload a register from a spill slot. - mkLoadInstr - :: Reg -- ^ the reg to reload. - -> Int -- ^ the current stack delta - -> Int -- ^ the spill slot to use - -> instr - - -- | See if this instruction is telling us the current C stack delta - takeDeltaInstr - :: instr - -> Maybe Int - - -- | Check whether this instruction is some meta thing inserted into - -- the instruction stream for other purposes. - -- - -- Not something that has to be treated as a real machine instruction - -- and have its registers allocated. - -- - -- eg, comments, delta, ldata, etc. - isMetaInstr - :: instr - -> Bool - - - - -- | Copy the value in a register to another one. - -- Must work for all register classes. - mkRegRegMoveInstr - :: Reg -- ^ source register - -> Reg -- ^ destination register - -> instr - - -- | Take the source and destination from this reg -> reg move instruction - -- or Nothing if it's not one - takeRegRegMoveInstr - :: instr - -> Maybe (Reg, Reg) - - -- | Make an unconditional jump instruction. - -- For architectures with branch delay slots, its ok to put - -- a NOP after the jump. Don't fill the delay slot with an - -- instruction that references regs or you'll confuse the - -- linear allocator. - mkJumpInstr - :: BlockId - -> [instr] - - +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: Platform + -> Reg -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slot to use + -> instr + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: Platform + -> Reg -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> instr + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: Platform + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 2a7376838a..57d2adf9b8 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -130,18 +130,20 @@ getNewLabelNat getNewRegNat :: Size -> NatM Reg -getNewRegNat rep - = do u <- getUniqueNat - return (RegVirtual $ targetMkVirtualReg u rep) +getNewRegNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) -getNewRegPairNat rep - = do u <- getUniqueNat - let vLo = targetMkVirtualReg u rep - let lo = RegVirtual $ targetMkVirtualReg u rep - let hi = RegVirtual $ getHiVirtualRegFromLo vLo - return (lo, hi) +getNewRegPairNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + let vLo = targetMkVirtualReg (targetPlatform dflags) u rep + let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) getPicBaseMaybeNat :: NatM (Maybe Reg) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index c375ab4707..7f59fd6fc9 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -709,8 +709,8 @@ pprImportedSymbol _ _ _ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmTop PPC.Instr] - -> NatM [NatCmmTop PPC.Instr] + -> [NatCmmTop CmmStatics PPC.Instr] + -> NatM [NatCmmTop CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) @@ -719,8 +719,7 @@ initializePicBase_ppc ArchPPC os picReg gotOffLabel <- getNewLabelNat tmp <- getNewRegNat $ intSize wordWidth let - gotOffset = CmmData Text [ - CmmDataLabel gotOffLabel, + gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel mkPicBaseLabel 0) @@ -762,8 +761,8 @@ initializePicBase_ppc _ _ _ _ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmTop X86.Instr] - -> NatM [NatCmmTop X86.Instr] + -> [NatCmmTop (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg (CmmProc info lab (ListGraph blocks) : statics) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index f4c972e4b0..a0e3ae92b5 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -67,7 +67,7 @@ import FastString cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -86,7 +86,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -403,11 +403,12 @@ getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ (CmmLoad mem pk) +getRegister' dflags (CmmLoad mem pk) | not (isWord64 pk) = do + let platform = targetPlatform dflags Amode addr addr_code <- getAmode mem - let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk) + let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) addr_code `snocOL` LD size dst addr return (Any size code) where size = cmmTypeSize pk @@ -557,8 +558,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do Amode addr addr_code <- getAmode dynRef let size = floatSize frep code dst = - LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f frep)] + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) @@ -903,7 +904,7 @@ genCCall' _ (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC genCCall' gcp target dest_regs argsAndHints - = ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps) + = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments @@ -1058,23 +1059,23 @@ genCCall' gcp target dest_regs argsAndHints = case gcp of GCPDarwin -> case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- The Darwin ABI requires that we skip a -- corresponding number of GPRs when we use -- the FPRs. FF32 -> (1, 1, 4, fprs) FF64 -> (2, 1, 8, fprs) - II8 -> panic "genCCall' passArguments II8" II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" GCPLinux -> case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) II32 -> (1, 0, 4, gprs) -- ... the SysV ABI doesn't. FF32 -> (0, 1, 4, fprs) FF64 -> (0, 1, 8, fprs) - II8 -> panic "genCCall' passArguments II8" II16 -> panic "genCCall' passArguments II16" II64 -> panic "genCCall' passArguments II64" FF80 -> panic "genCCall' passArguments FF80" @@ -1180,7 +1181,7 @@ genSwitch expr ids ] return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (BCTR ids (Just lbl)) = let jumpTable | opt_PIC = map jumpTableEntryRel ids @@ -1190,7 +1191,7 @@ generateJumpTableForInstr (BCTR ids (Just lbl)) = jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) - in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) + in Just (CmmData ReadOnlyData (Statics lbl jumpTable)) generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- @@ -1362,10 +1363,9 @@ coerceInt2FP fromRep toRep x = do Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), ST II32 itmp (spRel 3), LIS itmp (ImmInt 0x4330), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 0288f1bf02..ffe5408033 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -32,6 +32,7 @@ import OldCmm import FastString import CLabel import Outputable +import Platform import FastBool -------------------------------------------------------------------------------- @@ -43,18 +44,18 @@ archWordSize = II32 -- | Instruction instance for powerpc instance Instruction Instr where - regUsageOfInstr = ppc_regUsageOfInstr - patchRegsOfInstr = ppc_patchRegsOfInstr - isJumpishInstr = ppc_isJumpishInstr - jumpDestsOfInstr = ppc_jumpDestsOfInstr - patchJumpInstr = ppc_patchJumpInstr - mkSpillInstr = ppc_mkSpillInstr - mkLoadInstr = ppc_mkLoadInstr - takeDeltaInstr = ppc_takeDeltaInstr - isMetaInstr = ppc_isMetaInstr - mkRegRegMoveInstr = ppc_mkRegRegMoveInstr - takeRegRegMoveInstr = ppc_takeRegRegMoveInstr - mkJumpInstr = ppc_mkJumpInstr + regUsageOfInstr = ppc_regUsageOfInstr + patchRegsOfInstr = ppc_patchRegsOfInstr + isJumpishInstr = ppc_isJumpishInstr + jumpDestsOfInstr = ppc_jumpDestsOfInstr + patchJumpInstr = ppc_patchJumpInstr + mkSpillInstr = ppc_mkSpillInstr + mkLoadInstr = ppc_mkLoadInstr + takeDeltaInstr = ppc_takeDeltaInstr + isMetaInstr = ppc_isMetaInstr + mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr + takeRegRegMoveInstr = ppc_takeRegRegMoveInstr + mkJumpInstr = ppc_mkJumpInstr -- ----------------------------------------------------------------------------- @@ -75,7 +76,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -346,15 +347,16 @@ ppc_patchJumpInstr insn patchF -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr reg delta slot +ppc_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkSpillInstr: no match" @@ -362,15 +364,16 @@ ppc_mkSpillInstr reg delta slot ppc_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr reg delta slot +ppc_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkLoadInstr: no match" diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index bd12a8188c..54056c9e4d 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -37,10 +37,11 @@ import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable ( Outputable, panic ) +import Outputable ( PlatformOutputable, panic ) import Data.Word import Data.Bits @@ -49,26 +50,30 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without an info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -78,24 +83,24 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock blockid instrs) = +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) + vcat (map (pprInstr platform) instrs) + +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str #if darwin_TARGET_OS @@ -133,25 +138,12 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int pow2 - where - pow2 = log2 bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr pprReg :: Reg -> Doc @@ -345,26 +337,26 @@ pprDataItem lit = panic "PPC.Ppr.pprDataItem: no match" -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) +pprInstr _ (COMMENT s) IF_OS_linux( ((<>) (ptext (sLit "# ")) (ftext s)), ((<>) (ptext (sLit "; ")) (ftext s))) -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char '\t', @@ -372,7 +364,7 @@ pprInstr (SPILL reg slot) comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char '\t', @@ -381,7 +373,7 @@ pprInstr (RELOAD slot reg) pprReg reg] -} -pprInstr (LD sz reg addr) = hcat [ +pprInstr _ (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -399,7 +391,7 @@ pprInstr (LD sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (LA sz reg addr) = hcat [ +pprInstr _ (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -417,7 +409,7 @@ pprInstr (LA sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (ST sz reg addr) = hcat [ +pprInstr _ (ST sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -428,7 +420,7 @@ pprInstr (ST sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (STU sz reg addr) = hcat [ +pprInstr _ (STU sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -439,7 +431,7 @@ pprInstr (STU sz reg addr) = hcat [ ptext (sLit ", "), pprAddr addr ] -pprInstr (LIS reg imm) = hcat [ +pprInstr _ (LIS reg imm) = hcat [ char '\t', ptext (sLit "lis"), char '\t', @@ -447,7 +439,7 @@ pprInstr (LIS reg imm) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (LI reg imm) = hcat [ +pprInstr _ (LI reg imm) = hcat [ char '\t', ptext (sLit "li"), char '\t', @@ -455,11 +447,11 @@ pprInstr (LI reg imm) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (MR reg1 reg2) +pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ char '\t', - case targetClassOfReg reg1 of + case targetClassOfReg platform reg1 of RcInteger -> ptext (sLit "mr") _ -> ptext (sLit "fmr"), char '\t', @@ -467,7 +459,7 @@ pprInstr (MR reg1 reg2) ptext (sLit ", "), pprReg reg2 ] -pprInstr (CMP sz reg ri) = hcat [ +pprInstr _ (CMP sz reg ri) = hcat [ char '\t', op, char '\t', @@ -483,7 +475,7 @@ pprInstr (CMP sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (CMPL sz reg ri) = hcat [ +pprInstr _ (CMPL sz reg ri) = hcat [ char '\t', op, char '\t', @@ -499,7 +491,7 @@ pprInstr (CMPL sz reg ri) = hcat [ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (BCC cond blockid) = hcat [ +pprInstr _ (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, @@ -508,7 +500,7 @@ pprInstr (BCC cond blockid) = hcat [ ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (BCCFAR cond blockid) = vcat [ +pprInstr _ (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -521,33 +513,33 @@ pprInstr (BCCFAR cond blockid) = vcat [ ] where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel +pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext (sLit "b"), char '\t', pprCLabel_asm lbl ] -pprInstr (MTCTR reg) = hcat [ +pprInstr _ (MTCTR reg) = hcat [ char '\t', ptext (sLit "mtctr"), char '\t', pprReg reg ] -pprInstr (BCTR _ _) = hcat [ +pprInstr _ (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] -pprInstr (BL lbl _) = hcat [ +pprInstr _ (BL lbl _) = hcat [ ptext (sLit "\tbl\t"), pprCLabel_asm lbl ] -pprInstr (BCTRL _) = hcat [ +pprInstr _ (BCTRL _) = hcat [ char '\t', ptext (sLit "bctrl") ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ +pprInstr _ (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri +pprInstr _ (ADDIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "addis"), char '\t', @@ -558,15 +550,15 @@ pprInstr (ADDIS reg1 reg2 imm) = hcat [ pprImm imm ] -pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) -pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) -pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri -pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri -pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) -pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) +pprInstr _ (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) +pprInstr _ (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) +pprInstr _ (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) +pprInstr _ (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri +pprInstr _ (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri +pprInstr _ (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) +pprInstr _ (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) -pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ +pprInstr _ (MULLW_MayOflo reg1 reg2 reg3) = vcat [ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprReg reg3 ], @@ -578,7 +570,7 @@ pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ +pprInstr _ (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', ptext (sLit "andi."), char '\t', @@ -588,12 +580,12 @@ pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ ptext (sLit ", "), pprImm imm ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri +pprInstr _ (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri +pprInstr _ (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri +pprInstr _ (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri -pprInstr (XORIS reg1 reg2 imm) = hcat [ +pprInstr _ (XORIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "xoris"), char '\t', @@ -604,7 +596,7 @@ pprInstr (XORIS reg1 reg2 imm) = hcat [ pprImm imm ] -pprInstr (EXTS sz reg1 reg2) = hcat [ +pprInstr _ (EXTS sz reg1 reg2) = hcat [ char '\t', ptext (sLit "exts"), pprSize sz, @@ -614,13 +606,13 @@ pprInstr (EXTS sz reg1 reg2) = hcat [ pprReg reg2 ] -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 +pprInstr _ (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 +pprInstr _ (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 -pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ +pprInstr _ (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), @@ -633,13 +625,13 @@ pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ int me ] -pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 -pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 -pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 -pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 +pprInstr _ (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 +pprInstr _ (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 +pprInstr _ (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 +pprInstr _ (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 +pprInstr _ (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 -pprInstr (FCMP reg1 reg2) = hcat [ +pprInstr _ (FCMP reg1 reg2) = hcat [ char '\t', ptext (sLit "fcmpu\tcr0, "), -- Note: we're using fcmpu, not fcmpo @@ -650,10 +642,10 @@ pprInstr (FCMP reg1 reg2) = hcat [ pprReg reg2 ] -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 +pprInstr _ (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 +pprInstr _ (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 -pprInstr (CRNOR dst src1 src2) = hcat [ +pprInstr _ (CRNOR dst src1 src2) = hcat [ ptext (sLit "\tcrnor\t"), int dst, ptext (sLit ", "), @@ -662,28 +654,28 @@ pprInstr (CRNOR dst src1 src2) = hcat [ int src2 ] -pprInstr (MFCR reg) = hcat [ +pprInstr _ (MFCR reg) = hcat [ char '\t', ptext (sLit "mfcr"), char '\t', pprReg reg ] -pprInstr (MFLR reg) = hcat [ +pprInstr _ (MFLR reg) = hcat [ char '\t', ptext (sLit "mflr"), char '\t', pprReg reg ] -pprInstr (FETCHPC reg) = vcat [ +pprInstr _ (FETCHPC reg) = vcat [ ptext (sLit "\tbcl\t20,31,1f"), hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] ] -pprInstr LWSYNC = ptext (sLit "\tlwsync") +pprInstr _ LWSYNC = ptext (sLit "\tlwsync") --- pprInstr _ = panic "pprInstr (ppc)" +-- pprInstr _ _ = panic "pprInstr (ppc)" pprLogic :: LitString -> Reg -> Reg -> RI -> Doc diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bfc712af86..2a30087ab7 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -11,7 +11,7 @@ module PPC.RegInfo ( canShortcut, shortcutJump, - shortcutStatic + shortcutStatics ) where @@ -43,18 +43,24 @@ shortcutJump _ other = other -- Here because it knows about JumpDest -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/PprInstruction.hs b/compiler/nativeGen/PprInstruction.hs new file mode 100644 index 0000000000..6c19160e35 --- /dev/null +++ b/compiler/nativeGen/PprInstruction.hs @@ -0,0 +1,2 @@ + + pprInstruction :: Platform -> instr -> SDoc diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 1eaf00f3a2..a499e1d562 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -27,8 +27,8 @@ import Data.List -- the same and the move instruction safely erased. regCoalesce :: Instruction instr - => [LiveCmmTop instr] - -> UniqSM [LiveCmmTop instr] + => [LiveCmmTop statics instr] + -> UniqSM [LiveCmmTop statics instr] regCoalesce code = do @@ -61,7 +61,7 @@ sinkReg fm r -- then we can rename the two regs to the same thing and eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpJoinMovs live diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index cdbe98755a..5321a34695 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -28,6 +28,7 @@ import UniqSet import UniqFM import Bag import Outputable +import Platform import DynFlags import Data.List @@ -44,12 +45,12 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable instr, Instruction instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) + -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation @@ -58,9 +59,10 @@ regAlloc dflags regsFree slotsFree code -- TODO: the regClass function is currently hard coded to the default target -- architecture. Would prefer to determine this from dflags. -- There are other uses of targetRegClass later in this module. - let triv = trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze + let platform = targetPlatform dflags + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) (code_final, debug_codeGraphs, _) <- regAlloc_spin dflags 0 @@ -79,6 +81,7 @@ regAlloc_spin debug_codeGraphs code = do + let platform = targetPlatform dflags -- if any of these dump flags are turned on we want to hang on to -- intermediate structures in the allocator - otherwise tell the -- allocator to ditch them early so we don't end up creating space leaks. @@ -111,7 +114,7 @@ regAlloc_spin -- build a map of the cost of spilling each instruction -- this will only actually be computed if we have to spill something. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map slurpSpillCostInfo code + $ map (slurpSpillCostInfo platform) code -- the function to choose regs to leave uncolored let spill = chooseSpill spillCosts @@ -159,14 +162,14 @@ regAlloc_spin else graph_colored -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced -- clean out unneeded SPILL/RELOADs - let code_spillclean = map cleanSpills code_patched + let code_spillclean = map (cleanSpills platform) code_patched -- strip off liveness information, -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map stripLive code_spillclean + let code_final = map (stripLive platform) code_spillclean -- record what happened in this stage for debugging let stat = @@ -211,7 +214,7 @@ regAlloc_spin -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency -- order required by computeLiveness. If they're not in the correct order -- that function will panic. - code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = @@ -239,7 +242,7 @@ regAlloc_spin -- | Build a graph from the liveness and coalesce information in this code. buildGraph :: Instruction instr - => [LiveCmmTop instr] + => [LiveCmmTop statics instr] -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code @@ -320,11 +323,11 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable instr, Instruction instr) - => Color.Graph VirtualReg RegClass RealReg - -> LiveCmmTop instr -> LiveCmmTop instr + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmTop statics instr -> LiveCmmTop statics instr -patchRegsFromGraph graph code +patchRegsFromGraph platform graph code = let -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg @@ -343,12 +346,12 @@ patchRegsFromGraph graph code | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg - $$ ppr code + $$ pprPlatform platform code $$ Color.dotGraph (\_ -> text "white") - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) graph) in patchEraseLive patchF code diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 4eabb3b0b4..c4fb783688 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -41,13 +41,13 @@ import qualified Data.Set as Set -- regSpill :: Instruction instr - => [LiveCmmTop instr] -- ^ the code + => [LiveCmmTop statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling + ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling regSpill code slotsFree regs @@ -81,8 +81,8 @@ regSpill code slotsFree regs regSpill_top :: Instruction instr => RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmTop instr -- ^ the top level thing. - -> SpillM (LiveCmmTop instr) + -> LiveCmmTop statics instr -- ^ the top level thing. + -> SpillM (LiveCmmTop statics instr) regSpill_top regSlotMap cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 38c33b708a..da13eab045 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -39,6 +39,7 @@ import UniqFM import Unique import State import Outputable +import Platform import Data.List import Data.Maybe @@ -52,22 +53,23 @@ type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => LiveCmmTop instr -> LiveCmmTop instr +cleanSpills + :: Instruction instr + => Platform -> LiveCmmTop statics instr -> LiveCmmTop statics instr -cleanSpills cmm - = evalState (cleanSpin 0 cmm) initCleanS +cleanSpills platform cmm + = evalState (cleanSpin platform 0 cmm) initCleanS -- | do one pass of cleaning -cleanSpin - :: Instruction instr - => Int - -> LiveCmmTop instr - -> CleanM (LiveCmmTop instr) +cleanSpin + :: Instruction instr + => Platform + -> Int + -> LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) {- -cleanSpin spinCount code +cleanSpin _ spinCount code = do jumpValid <- gets sJumpValid pprTrace "cleanSpin" ( int spinCount @@ -78,7 +80,7 @@ cleanSpin spinCount code $ cleanSpin' spinCount code -} -cleanSpin spinCount code +cleanSpin platform spinCount code = do -- init count of cleaned spills\/reloads modify $ \s -> s @@ -86,7 +88,7 @@ cleanSpin spinCount code , sCleanedReloadsAcc = 0 , sReloadedBy = emptyUFM } - code_forward <- mapBlockTopM cleanBlockForward code + code_forward <- mapBlockTopM (cleanBlockForward platform) code code_backward <- cleanTopBackward code_forward -- During the cleaning of each block we collected information about what regs @@ -107,16 +109,17 @@ cleanSpin spinCount code then return code -- otherwise go around again - else cleanSpin (spinCount + 1) code_backward + else cleanSpin platform (spinCount + 1) code_backward -- | Clean one basic block -cleanBlockForward - :: Instruction instr - => LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) +cleanBlockForward + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) -cleanBlockForward (BasicBlock blockId instrs) +cleanBlockForward platform (BasicBlock blockId instrs) = do -- see if we have a valid association for the entry to this block jumpValid <- gets sJumpValid @@ -124,7 +127,7 @@ cleanBlockForward (BasicBlock blockId instrs) Just assoc -> assoc Nothing -> emptyAssoc - instrs_reload <- cleanForward blockId assoc [] instrs + instrs_reload <- cleanForward platform blockId assoc [] instrs return $ BasicBlock blockId instrs_reload @@ -135,37 +138,38 @@ cleanBlockForward (BasicBlock blockId instrs) -- then we don't need to do the reload. -- cleanForward - :: Instruction instr - => BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) - -cleanForward _ _ acc [] + :: Instruction instr + => Platform + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + +cleanForward _ _ _ acc [] = return acc -- write out live range joins via spill slots to just a spill and a reg-reg move -- hopefully the spill will be also be cleaned in the next pass -- -cleanForward blockId assoc acc (li1 : li2 : instrs) +cleanForward platform blockId assoc acc (li1 : li2 : instrs) | LiveInstr (SPILL reg1 slot1) _ <- li1 , LiveInstr (RELOAD slot2 reg2) _ <- li2 , slot1 == slot2 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward blockId assoc acc - (li1 : LiveInstr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) + cleanForward platform blockId assoc acc + (li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing : instrs) -cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) +cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) | Just (r1, r2) <- takeRegRegMoveInstr i1 = if r1 == r2 -- erase any left over nop reg reg moves while we're here -- this will also catch any nop moves that the "write out live range joins" case above -- happens to add - then cleanForward blockId assoc acc instrs + then cleanForward platform blockId assoc acc instrs -- if r1 has the same value as some slots and we copy r1 to r2, -- then r2 is now associated with those slots instead @@ -173,50 +177,51 @@ cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) $ delAssoc (SReg r2) $ assoc - cleanForward blockId assoc' (li : acc) instrs + cleanForward platform blockId assoc' (li : acc) instrs -cleanForward blockId assoc acc (li : instrs) +cleanForward platform blockId assoc acc (li : instrs) -- update association due to the spill | LiveInstr (SPILL reg slot) _ <- li = let assoc' = addAssoc (SReg reg) (SSlot slot) $ delAssoc (SSlot slot) $ assoc - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- clean a reload instr | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload blockId assoc li + = do (assoc', mli) <- cleanReload platform blockId assoc li case mli of - Nothing -> cleanForward blockId assoc' acc instrs - Just li' -> cleanForward blockId assoc' (li' : acc) instrs + Nothing -> cleanForward platform blockId assoc' acc instrs + Just li' -> cleanForward platform blockId assoc' (li' : acc) instrs -- remember the association over a jump | LiveInstr instr _ <- li , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accJumpValid assoc) targets - cleanForward blockId assoc (li : acc) instrs + cleanForward platform blockId assoc (li : acc) instrs -- writing to a reg changes its value. | LiveInstr instr _ <- li , RU _ written <- regUsageOfInstr instr = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- | Try and rewrite a reload instruction to something more pleasing -- -cleanReload - :: Instruction instr - => BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) +cleanReload + :: Instruction instr + => Platform + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) +cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) -- if the reg we're reloading already has the same value as the slot -- then we can erase the instruction outright @@ -233,7 +238,7 @@ cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) $ delAssoc (SReg reg) $ assoc - return (assoc', Just $ LiveInstr (mkRegRegMoveInstr reg2 reg) Nothing) + return (assoc', Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) -- gotta keep this instr | otherwise @@ -247,7 +252,7 @@ cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) return (assoc', Just li) -cleanReload _ _ _ +cleanReload _ _ _ _ = panic "RegSpillClean.cleanReload: unhandled instr" @@ -282,8 +287,8 @@ cleanReload _ _ _ -- cleanTopBackward :: Instruction instr - => LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) cleanTopBackward cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 330a410312..3ea150a3df 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -29,6 +29,7 @@ import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable +import Platform import State import Data.List (nub, minimumBy) @@ -62,12 +63,12 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- for each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) -- -slurpSpillCostInfo - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> SpillCostInfo +slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> SpillCostInfo -slurpSpillCostInfo cmm +slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () @@ -96,7 +97,7 @@ slurpSpillCostInfo cmm | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> ppr instr) + (text "no liveness information on instruction " <> pprPlatform platform instr) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 5ff7bff91a..15ec6e7f87 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -36,56 +36,56 @@ import State import Data.List -data RegAllocStats instr +data RegAllocStats statics instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + { raLiveCmm :: [LiveCmmTop statics instr] -- ^ initial code, with liveness , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced , raSpillStats :: SpillStats -- ^ spiller stats , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raCodeCoalesced :: [LiveCmmTop instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code + , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance Outputable instr => Outputable (RegAllocStats instr) where +instance (Outputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) + pprPlatform platform (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) + $$ pprPlatform platform (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraph s) - ppr (s@RegAllocStatsSpill{}) + pprPlatform platform (s@RegAllocStatsSpill{}) = text "# Spill" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -99,22 +99,22 @@ instance Outputable instr => Outputable (RegAllocStats instr) where $$ text "" $$ text "# Code with spills inserted." - $$ (ppr (raSpilled s)) + $$ pprPlatform platform (raSpilled s) - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraphColored s) $$ text "" @@ -125,19 +125,19 @@ instance Outputable instr => Outputable (RegAllocStats instr) where else empty) $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) + $$ pprPlatform platform (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ ppr (raPatched s) + $$ pprPlatform platform (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) + $$ pprPlatform platform (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) + $$ pprPlatform platform (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) @@ -147,7 +147,7 @@ instance Outputable instr => Outputable (RegAllocStats instr) where -- | Do all the different analysis on this list of RegAllocStats pprStats - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -> SDoc @@ -162,7 +162,7 @@ pprStats stats graph -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let @@ -180,7 +180,7 @@ pprStatsSpills stats -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo @@ -208,7 +208,7 @@ binLifetimeCount fm -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) @@ -225,7 +225,7 @@ pprStatsConflict stats -- | For every vreg, dump it's how many conflicts it has and its lifetime -- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc @@ -256,7 +256,7 @@ pprStatsLifeConflict stats graph -- Lets us see how well the register allocator has done. countSRMs :: Instruction instr - => LiveCmmTop instr -> (Int, Int, Int) + => LiveCmmTop statics instr -> (Int, Int, Int) countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index 848b266116..e62b4a9abb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -98,23 +98,21 @@ the most efficient variant tried. Benchmark compiling 10-times SHA1.lhs follows. 100.00% 166.23% 94.18% 100.95% -} --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - trivColorable - :: (RegClass -> VirtualReg -> FastInt) + :: Platform + -> (RegClass -> VirtualReg -> FastInt) -> (RegClass -> RealReg -> FastInt) -> Triv VirtualReg RegClass RealReg -trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions | let !cALLOCATABLE_REGS_INTEGER - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 3 ArchX86_64 -> 5 ArchPPC -> 16 ArchSPARC -> 14 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER (virtualRegSqueeze RcInteger) @@ -126,14 +124,15 @@ trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions = count3 <# cALLOCATABLE_REGS_INTEGER -trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions | let !cALLOCATABLE_REGS_FLOAT - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 0 ArchX86_64 -> 0 ArchPPC -> 0 ArchSPARC -> 22 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT (virtualRegSqueeze RcFloat) @@ -145,14 +144,15 @@ trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions = count3 <# cALLOCATABLE_REGS_FLOAT -trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions | let !cALLOCATABLE_REGS_DOUBLE - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 6 ArchX86_64 -> 0 ArchPPC -> 26 ArchSPARC -> 11 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE (virtualRegSqueeze RcDouble) @@ -164,14 +164,15 @@ trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions = count3 <# cALLOCATABLE_REGS_DOUBLE -trivColorable virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions +trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions | let !cALLOCATABLE_REGS_SSE - = iUnbox (case platformArch defaultTargetPlatform of + = iUnbox (case platformArch platform of ArchX86 -> 8 ArchX86_64 -> 10 ArchPPC -> 0 ArchSPARC -> 0 ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" ArchUnknown -> panic "trivColorable ArchUnknown") , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE (virtualRegSqueeze RcDoubleSSE) diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs index b442d069a4..5a413d341e 100644 --- a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs @@ -58,16 +58,14 @@ instance FR SPARC.FreeRegs where frInitFreeRegs = SPARC.initFreeRegs frReleaseReg = SPARC.releaseReg --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -maxSpillSlots :: Int -maxSpillSlots = case platformArch defaultTargetPlatform of +maxSpillSlots :: Platform -> Int +maxSpillSlots platform + = case platformArch platform of ArchX86 -> X86.Instr.maxSpillSlots ArchX86_64 -> X86.Instr.maxSpillSlots ArchPPC -> PPC.Instr.maxSpillSlots ArchSPARC -> SPARC.Instr.maxSpillSlots + ArchARM -> panic "maxSpillSlots ArchARM" ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index e6a078a05e..ba07e61871 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -24,6 +24,7 @@ import BlockId import OldCmm hiding (RegSet) import Digraph import Outputable +import Platform import Unique import UniqFM import UniqSet @@ -34,7 +35,8 @@ import UniqSet -- joinToTargets :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> BlockId -- ^ id of the current block @@ -44,19 +46,20 @@ joinToTargets , instr) -- the original branch instruction, but maybe patched to jump -- to a fixup block first. -joinToTargets block_live id instr +joinToTargets platform block_live id instr -- we only need to worry about jump instructions. | not $ isJumpishInstr instr = return ([], instr) | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' :: (FR freeRegs, Instruction instr) - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -70,11 +73,11 @@ joinToTargets' , instr) -- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] +joinToTargets' _ _ new_blocks _ instr [] = return (new_blocks, instr) -- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) +joinToTargets' platform block_live new_blocks block_id instr (dest:dests) = do -- get the map of where the vregs are stored on entry to each basic block. block_assig <- getBlockAssigR @@ -97,18 +100,19 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) case mapLookup dest block_assig of Nothing -> joinToTargets_first - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests adjusted_assig dest_assig -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -118,7 +122,7 @@ joinToTargets_first :: (FR freeRegs, Instruction instr) -> RegMap Loc -> [RealReg] -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_first block_live new_blocks block_id instr dest dests +joinToTargets_first platform block_live new_blocks block_id instr dest dests block_assig src_assig to_free @@ -129,12 +133,13 @@ joinToTargets_first block_live new_blocks block_id instr dest dests -- remember the current assignment on entry to this block. setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - joinToTargets' block_live new_blocks block_id instr dests + joinToTargets' platform block_live new_blocks block_id instr dests -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs) - => BlockMap RegSet + => Platform + -> BlockMap RegSet -> [NatBasicBlock instr] -> BlockId -> instr @@ -143,13 +148,13 @@ joinToTargets_again :: (Instruction instr, FR freeRegs) -> UniqFM Loc -> UniqFM Loc -> RegM freeRegs ([NatBasicBlock instr], instr) -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig +joinToTargets_again + platform block_live new_blocks block_id instr dest dests + src_assig dest_assig -- the assignments already match, no problem. | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' block_live new_blocks block_id instr dests + = joinToTargets' platform block_live new_blocks block_id instr dests -- assignments don't match, need fixup code | otherwise @@ -184,7 +189,7 @@ joinToTargets_again (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs let fixUpInstrs = concat fixUpInstrs_ -- make a new basic block containing the fixup code. @@ -202,7 +207,7 @@ joinToTargets_again -} -- if we didn't need any fixups, then don't include the block case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests + [] -> joinToTargets' platform block_live new_blocks block_id instr dests -- patch the original branch instruction so it goes to our -- fixup block instead. @@ -211,7 +216,7 @@ joinToTargets_again then mkBlockId fixup_block_id else bid) -- no change! - in joinToTargets' block_live (block : new_blocks) block_id instr' dests + in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. @@ -281,14 +286,14 @@ expandNode vreg src dst -- handleComponent :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] + => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] -- If the graph is acyclic then we won't get the swapping problem below. -- In this case we can just do the moves directly, and avoid having to -- go via a spill slot. -- -handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove delta vreg src) dsts +handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove platform delta vreg src) dsts -- Handle some cyclic moves. @@ -306,53 +311,54 @@ handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) -- are allocated exclusively for a virtual register and therefore can not -- require a fixup. -- -handleComponent delta instr +handleComponent platform delta instr (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RegReal sreg) vreg + <- spillR platform (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot + instrLoad <- loadR platform (RegReal dreg) slot - remainingFixUps <- mapM (handleComponent delta instr) + remainingFixUps <- mapM (handleComponent platform delta instr) (stronglyConnCompFromEdgedVerticesR rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) -handleComponent _ _ (CyclicSCC _) +handleComponent _ _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" -- | Move a vreg between these two locations. -- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM freeRegs instr -- ^ move instruction. - -makeMove _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) - -makeMove delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RegReal dst) delta src - -makeMove delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RegReal src) delta dst +makeMove + :: Instruction instr + => Platform + -> Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove platform _ vreg (InReg src) (InReg dst) + = do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) + +makeMove platform delta vreg (InMem src) (InReg dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr platform (RegReal dst) delta src + +makeMove platform delta vreg (InReg src) (InMem dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr platform (RegReal src) delta dst -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share stack slots between vregs. -makeMove _ vreg src dst +makeMove _ _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " we don't handle mem->mem moves." diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index b91c2d0269..8fa758d063 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -127,10 +127,10 @@ import Control.Monad -- Allocate registers regAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags - -> LiveCmmTop instr - -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) + -> LiveCmmTop statics instr + -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) regAlloc _ (CmmData sec d) = return @@ -170,7 +170,7 @@ regAlloc _ (CmmProc _ _ _) -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (Outputable instr, Instruction instr) + :: (PlatformOutputable instr, Instruction instr) => DynFlags -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block @@ -178,50 +178,54 @@ linearRegAlloc -> UniqSM ([NatBasicBlock instr], RegAllocStats) linearRegAlloc dflags first_id block_live sccs - = case platformArch $ targetPlatform dflags of - ArchX86 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchX86_64 -> linearRegAlloc' (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs - ArchSPARC -> linearRegAlloc' (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs - ArchPPC -> linearRegAlloc' (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs - ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" - ArchUnknown -> panic "linearRegAlloc ArchUnknown" + = let platform = targetPlatform dflags + in case platformArch platform of + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM -> panic "linearRegAlloc ArchARM" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" linearRegAlloc' - :: (FR freeRegs, Outputable instr, Instruction instr) - => freeRegs + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> freeRegs -> BlockId -- ^ the first block -> BlockMap RegSet -- ^ live regs on entry to each basic block -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" -> UniqSM ([NatBasicBlock instr], RegAllocStats) -linearRegAlloc' initFreeRegs first_id block_live sccs +linearRegAlloc' platform initFreeRegs first_id block_live sccs = do us <- getUs let (_, _, stats, blocks) = - runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us - $ linearRA_SCCs first_id block_live [] sccs + runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us + $ linearRA_SCCs platform first_id block_live [] sccs return (blocks, stats) -linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [NatBasicBlock instr] -> [SCC (LiveBasicBlock instr)] -> RegM freeRegs [NatBasicBlock instr] -linearRA_SCCs _ _ blocksAcc [] +linearRA_SCCs _ _ _ blocksAcc [] = return $ reverse blocksAcc -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live +linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock platform block_live block + linearRA_SCCs platform first_id block_live ((reverse blocks') ++ blocksAcc) sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live + blockss' <- process platform first_id block_live blocks [] (return []) False + linearRA_SCCs platform first_id block_live (reverse (concat blockss') ++ blocksAcc) sccs @@ -237,8 +241,9 @@ linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) more sanity checking to guard against this eventuality. -} -process :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockId +process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId -> BlockMap RegSet -> [GenBasicBlock (LiveInstr instr)] -> [GenBasicBlock (LiveInstr instr)] @@ -246,10 +251,10 @@ process :: (FR freeRegs, Instruction instr, Outputable instr) -> Bool -> RegM freeRegs [[NatBasicBlock instr]] -process _ _ [] [] accum _ +process _ _ _ [] [] accum _ = return $ reverse accum -process first_id block_live [] next_round accum madeProgress +process platform first_id block_live [] next_round accum madeProgress | not madeProgress {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. @@ -259,10 +264,10 @@ process first_id block_live [] next_round accum madeProgress = return $ reverse accum | otherwise - = process first_id block_live + = process platform first_id block_live next_round [] accum False -process first_id block_live (b@(BasicBlock id _) : blocks) +process platform first_id block_live (b@(BasicBlock id _) : blocks) next_round accum madeProgress = do block_assig <- getBlockAssigR @@ -270,26 +275,27 @@ process first_id block_live (b@(BasicBlock id _) : blocks) if isJust (mapLookup id block_assig) || id == first_id then do - b' <- processBlock block_live b - process first_id block_live blocks + b' <- processBlock platform block_live b + process platform first_id block_live blocks next_round (b' : accum) True - else process first_id block_live blocks + else process platform first_id block_live blocks (b : next_round) accum madeProgress -- | Do register allocation on this basic block -- processBlock - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ live regs on entry to each basic block -> LiveBasicBlock instr -- ^ block to do register allocation on -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated -processBlock block_live (BasicBlock id instrs) +processBlock platform block_live (BasicBlock id instrs) = do initBlock id (instrs', fixups) - <- linearRA block_live [] [] id instrs + <- linearRA platform block_live [] [] id instrs return $ BasicBlock id instrs' : fixups @@ -315,8 +321,9 @@ initBlock id -- | Do allocation for a sequence of instructions. linearRA - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. -> BlockId -- ^ id of the current block, for debugging. @@ -327,24 +334,25 @@ linearRA , [NatBasicBlock instr]) -- fresh blocks of fixup code. -linearRA _ accInstr accFixup _ [] +linearRA _ _ accInstr accFixup _ [] = return ( reverse accInstr -- instrs need to be returned in the correct order. , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA block_live accInstr accFixups id (instr:instrs) +linearRA platform block_live accInstr accFixups id (instr:instrs) = do (accInstr', new_fixups) - <- raInsn block_live accInstr id instr + <- raInsn platform block_live accInstr id instr - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. raInsn - :: (FR freeRegs, Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. -> [instr] -- ^ accumulator for instructions already processed. -> BlockId -- ^ the id of the current block, for debugging -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. @@ -352,17 +360,17 @@ raInsn ( [instr] -- new instructions , [NatBasicBlock instr]) -- extra fixup blocks -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | Just n <- takeDeltaInstr ii = do setDeltaR n return (new_instrs, []) -raInsn _ new_instrs _ (LiveInstr ii Nothing) +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) | isMetaInstr ii = return (new_instrs, []) -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -397,17 +405,18 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) -} return (new_instrs, []) - _ -> genRaInsn block_live new_instrs id instr + _ -> genRaInsn platform block_live new_instrs id instr (uniqSetToList $ liveDieRead live) (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) +raInsn platform _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) -genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) - => BlockMap RegSet +genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockMap RegSet -> [instr] -> BlockId -> instr @@ -415,7 +424,7 @@ genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr) -> [Reg] -> RegM freeRegs ([instr], [NatBasicBlock instr]) -genRaInsn block_live new_instrs block_id instr r_dying w_dying = +genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> do let real_written = [ rr | (RegReal rr) <- written ] @@ -427,7 +436,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying + clobber_saves <- saveClobberedTemps platform real_written r_dying -- debugging {- freeregs <- getFreeRegsR @@ -445,14 +454,14 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- (b), (c) allocate real regs for all regs read by this instruction. (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets block_live block_id instr + <- joinToTargets platform block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. @@ -463,7 +472,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = -- (g) Allocate registers for temporaries *written* (only) (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. @@ -545,16 +554,17 @@ releaseRegs regs = do saveClobberedTemps - :: (Outputable instr, Instruction instr) - => [RealReg] -- real registers clobbered by this instruction + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM freeRegs [instr] -- return: instructions to spill any temps that will -- be clobbered. -saveClobberedTemps [] _ +saveClobberedTemps _ [] _ = return [] -saveClobberedTemps clobbered dying +saveClobberedTemps platform clobbered dying = do assig <- getAssigR let to_spill @@ -573,7 +583,7 @@ saveClobberedTemps clobbered dying clobber assig instrs ((temp, reg) : rest) = do - (spill, slot) <- spillR (RegReal reg) temp + (spill, slot) <- spillR platform (RegReal reg) temp -- record why this reg was spilled for profiling recordSpill (SpillClobber temp) @@ -637,24 +647,25 @@ data SpillLoc = ReadMem StackSlot -- reading from register only in memory -- the list of free registers and free stack slots. allocateRegsAndSpill - :: (FR freeRegs, Outputable instr, Instruction instr) - => Bool -- True <=> reading (load up spilled regs) + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> Bool -- True <=> reading (load up spilled regs) -> [VirtualReg] -- don't push these out -> [instr] -- spill insns -> [RealReg] -- real registers allocated (accum.) -> [VirtualReg] -- temps to allocate -> RegM freeRegs ( [instr] , [RealReg]) -allocateRegsAndSpill _ _ spills alloc [] +allocateRegsAndSpill _ _ _ spills alloc [] = return (spills, reverse alloc) -allocateRegsAndSpill reading keep spills alloc (r:rs) +allocateRegsAndSpill platform reading keep spills alloc (r:rs) = do assig <- getAssigR - let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig + let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig case lookupUFM assig r of -- case (1a): already in a register Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs -- case (1b): already in a register (and memory) -- NB1. if we're writing this register, update its assignment to be @@ -663,7 +674,7 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- are also read by the same instruction. Just (InBoth my_reg _) -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs -- Not already in a register, so we need to find a free one... Just (InMem slot) | reading -> doSpill (ReadMem slot) @@ -681,8 +692,9 @@ allocateRegsAndSpill reading keep spills alloc (r:rs) -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY -allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) - => Bool +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> Bool -> [VirtualReg] -> [instr] -> [RealReg] @@ -691,7 +703,7 @@ allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr) -> UniqFM Loc -> SpillLoc -> RegM freeRegs ([instr], [RealReg]) -allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc +allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc = do freeRegs <- getFreeRegsR let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs @@ -700,12 +712,12 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc -- case (2): we have a free register (my_reg : _) -> - do spills' <- loadTemp r spill_loc my_reg spills + do spills' <- loadTemp platform r spill_loc my_reg spills setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) setFreeRegsR $ frAllocateReg my_reg freeRegs - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs -- case (3): we need to push something out to free up a register @@ -717,7 +729,7 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = [ (temp, reg, mem) | (temp, InBoth reg mem) <- ufmToList assig , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] + , targetClassOfRealReg platform reg == classOfVirtualReg r ] -- the vregs we could kick out that are only in a reg -- this would require writing the reg to a new slot before using it. @@ -725,26 +737,26 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc = [ (temp, reg) | (temp, InReg reg) <- ufmToList assig , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] + , targetClassOfRealReg platform reg == classOfVirtualReg r ] let result -- we have a temporary that is in both register and mem, -- just free up its register for use. | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp r spill_loc my_reg spills + = do spills' <- loadTemp platform r spill_loc my_reg spills let assig1 = addToUFM assig temp (InMem slot) let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs -- otherwise, we need to spill a temporary that currently -- resides in a register. | (temp_to_push_out, (my_reg :: RealReg)) : _ <- candidates_inReg = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out let spill_store = (if reading then id else reverse) [ -- COMMENT (fsLit "spill alloc") spill_insn ] @@ -758,9 +770,9 @@ allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc setAssigR assig2 -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp r spill_loc my_reg spills + spills' <- loadTemp platform r spill_loc my_reg spills - allocateRegsAndSpill reading keep + allocateRegsAndSpill platform reading keep (spill_store ++ spills') (my_reg:alloc) rs @@ -786,19 +798,20 @@ newLocation _ my_reg = InReg my_reg -- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: (Outputable instr, Instruction instr) - => VirtualReg -- the temp being loaded + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> VirtualReg -- the temp being loaded -> SpillLoc -- the current location of this temp -> RealReg -- the hreg to load the temp into -> [instr] -> RegM freeRegs [instr] -loadTemp vreg (ReadMem slot) hreg spills +loadTemp platform vreg (ReadMem slot) hreg spills = do - insn <- loadR (RegReal hreg) slot + insn <- loadR platform (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills -loadTemp _ _ _ spills = +loadTemp _ _ _ _ spills = return spills diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs index 62bf6adb2a..1dd410aa46 100644 --- a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs +++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs @@ -22,6 +22,7 @@ where import RegAlloc.Linear.FreeRegs import Outputable +import Platform import UniqFM import Unique @@ -39,8 +40,8 @@ data StackMap -- | An empty stack map, with all slots available. -emptyStackMap :: StackMap -emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM +emptyStackMap :: Platform -> StackMap +emptyStackMap platform = StackMap [0 .. maxSpillSlots platform] emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 05db9de350..9999a1e2e4 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -36,6 +36,7 @@ import RegAlloc.Liveness import Instruction import Reg +import Platform import Unique import UniqSupply @@ -81,21 +82,21 @@ makeRAStats state { ra_spillInstrs = binSpillReasons (ra_spills state) } -spillR :: Instruction instr - => Reg -> Unique -> RegM freeRegs (instr, Int) +spillR :: Instruction instr + => Platform -> Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> +spillR platform reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr reg delta slot + instr = mkSpillInstr platform reg delta slot in (# s{ra_stack=stack'}, (instr,slot) #) -loadR :: Instruction instr - => Reg -> Int -> RegM freeRegs instr +loadR :: Instruction instr + => Platform -> Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr reg delta slot #) +loadR platform reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + (# s, mkLoadInstr platform reg delta slot #) getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index c80f77f893..0c059eac27 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -37,7 +37,7 @@ binSpillReasons reasons -- | Count reg-reg moves remaining in this code. countRegRegMovesNat :: Instruction instr - => NatCmmTop instr -> Int + => NatCmmTop statics instr -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 @@ -58,7 +58,7 @@ countRegRegMovesNat cmm -- | Pretty print some RegAllocStats pprStats :: Instruction instr - => [NatCmmTop instr] -> [RegAllocStats] -> SDoc + => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc pprStats code statss = let -- sum up all the instrs inserted by the spiller diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a2030fafa9..2b7975dcb4 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -8,28 +8,28 @@ {-# OPTIONS -Wall -fno-warn-name-shadowing #-} module RegAlloc.Liveness ( - RegSet, - RegMap, emptyRegMap, - BlockMap, emptyBlockMap, - LiveCmmTop, - InstrSR (..), - LiveInstr (..), - Liveness (..), - LiveInfo (..), - LiveBasicBlock, - - mapBlockTop, mapBlockTopM, mapSCCM, - mapGenBlockTop, mapGenBlockTopM, - stripLive, - stripLiveBlock, - slurpConflicts, - slurpReloadCoalesce, - eraseDeltasLive, - patchEraseLive, - patchRegsLiveInstr, - reverseBlocksInTops, - regLiveness, - natCmmTopToLive + RegSet, + RegMap, emptyRegMap, + BlockMap, emptyBlockMap, + LiveCmmTop, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + natCmmTopToLive ) where import Reg import Instruction @@ -40,6 +40,7 @@ import OldPprCmm() import Digraph import Outputable +import Platform import Unique import UniqSet import UniqFM @@ -50,9 +51,9 @@ import FastString import Data.List import Data.Maybe -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map ----------------------------------------------------------------------------- type RegSet = UniqSet Reg @@ -66,869 +67,873 @@ type BlockMap a = BlockEnv a -- | A top level thing which carries liveness information. -type LiveCmmTop instr - = GenCmmTop - CmmStatic - LiveInfo - [SCC (LiveBasicBlock instr)] +type LiveCmmTop statics instr + = GenCmmTop + statics + LiveInfo + [SCC (LiveBasicBlock instr)] -- | The register allocator also wants to use SPILL/RELOAD meta instructions, --- so we'll keep those here. +-- so we'll keep those here. data InstrSR instr - -- | A real machine instruction - = Instr instr + -- | A real machine instruction + = Instr instr - -- | spill this reg to a stack slot - | SPILL Reg Int + -- | spill this reg to a stack slot + | SPILL Reg Int - -- | reload this reg from a stack slot - | RELOAD Int Reg + -- | reload this reg from a stack slot + | RELOAD Int Reg instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr i - = case i of - Instr instr -> regUsageOfInstr instr - SPILL reg _ -> RU [reg] [] - RELOAD _ reg -> RU [] [reg] + regUsageOfInstr i + = case i of + Instr instr -> regUsageOfInstr instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] - patchRegsOfInstr i f - = case i of - Instr instr -> Instr (patchRegsOfInstr instr f) - SPILL reg slot -> SPILL (f reg) slot - RELOAD slot reg -> RELOAD slot (f reg) + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) - isJumpishInstr i - = case i of - Instr instr -> isJumpishInstr instr - _ -> False + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False - jumpDestsOfInstr i - = case i of - Instr instr -> jumpDestsOfInstr instr - _ -> [] + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] - patchJumpInstr i f - = case i of - Instr instr -> Instr (patchJumpInstr instr f) - _ -> i + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i - mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" - mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" - takeDeltaInstr i - = case i of - Instr instr -> takeDeltaInstr instr - _ -> Nothing + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing - isMetaInstr i - = case i of - Instr instr -> isMetaInstr instr - _ -> False + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False - mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2) + mkRegRegMoveInstr platform r1 r2 + = Instr (mkRegRegMoveInstr platform r1 r2) - takeRegRegMoveInstr i - = case i of - Instr instr -> takeRegRegMoveInstr instr - _ -> Nothing + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) - mkJumpInstr target = map Instr (mkJumpInstr target) - -- | An instruction with liveness information. data LiveInstr instr - = LiveInstr (InstrSR instr) (Maybe Liveness) + = LiveInstr (InstrSR instr) (Maybe Liveness) -- | Liveness information. --- The regs which die are ones which are no longer live in the *next* instruction --- in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). data Liveness - = Liveness - { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. - , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. + = Liveness + { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. + , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo - = LiveInfo - [CmmStatic] -- cmm static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + = LiveInfo + (Maybe CmmStatics) -- cmm info table static stuff + (Maybe BlockId) -- id of the first block + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. type LiveBasicBlock instr - = GenBasicBlock (LiveInstr instr) - - -instance Outputable instr - => Outputable (InstrSR instr) where - - ppr (Instr realInstr) - = ppr realInstr - - ppr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char ' ', - ppr reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - - ppr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char ' ', - ptext (sLit "SLOT") <> parens (int slot), - comma, - ppr reg] - -instance Outputable instr - => Outputable (LiveInstr instr) where - - ppr (LiveInstr instr Nothing) - = ppr instr - - ppr (LiveInstr instr (Just live)) - = ppr instr - $$ (nest 8 - $ vcat - [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) - , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) - , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] - $+$ space) - - where pprRegs :: SDoc -> RegSet -> SDoc - pprRegs name regs - | isEmptyUniqSet regs = empty - | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) + = GenBasicBlock (LiveInstr instr) + + +instance PlatformOutputable instr + => PlatformOutputable (InstrSR instr) where + + pprPlatform platform (Instr realInstr) + = pprPlatform platform realInstr + + pprPlatform _ (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + ppr reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + + pprPlatform _ (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + ppr reg] + +instance PlatformOutputable instr + => PlatformOutputable (LiveInstr instr) where + + pprPlatform platform (LiveInstr instr Nothing) + = pprPlatform platform instr + + pprPlatform platform (LiveInstr instr (Just live)) + = pprPlatform platform instr + $$ (nest 8 + $ vcat + [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) + , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) + , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> RegSet -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry) - = (vcat $ map ppr static) - $$ text "# firstId = " <> ppr firstId - $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty ppr mb_static) + $$ text "# firstId = " <> ppr firstId + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) -- | map a function across all the basic blocks in this code -- mapBlockTop - :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmTop instr -> LiveCmmTop instr + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr mapBlockTop f cmm - = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) -- mapBlockTopM - :: Monad m - => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmTop instr -> m (LiveCmmTop instr) + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr) mapBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm mapBlockTopM f (CmmProc header label sccs) - = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label sccs' + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) -mapSCCM f (AcyclicSCC x) - = do x' <- f x - return $ AcyclicSCC x' +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' mapSCCM f (CyclicSCC xs) - = do xs' <- mapM f xs - return $ CyclicSCC xs' + = do xs' <- mapM f xs + return $ CyclicSCC xs' -- map a function across all the basic blocks in this code mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) mapGenBlockTop f cmm - = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) mapGenBlockTopM - :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) mapGenBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) - = do blocks' <- mapM f blocks - return $ CmmProc header label (ListGraph blocks') + = do blocks' <- mapM f blocks + return $ CmmProc header label (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. --- Slurping of conflicts and moves is wrapped up together so we don't have --- to make two passes over the same code when we want to build the graph. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. -- -slurpConflicts - :: Instruction instr - => LiveCmmTop instr - -> (Bag (UniqSet Reg), Bag (Reg, Reg)) +slurpConflicts + :: Instruction instr + => LiveCmmTop statics instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live - = slurpCmm (emptyBag, emptyBag) live + = slurpCmm (emptyBag, emptyBag) live + + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ sccs) + = foldl' (slurpSCC info) rs sccs - where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ sccs) - = foldl' (slurpSCC info) rs sccs + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b - slurpSCC info rs (AcyclicSCC b) - = slurpBlock info rs b + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs - slurpSCC info rs (CyclicSCC bs) - = foldl' (slurpBlock info) rs bs + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) - slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- mapLookup blockId blockLive - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs - = (consBag rsLiveEntry conflicts, moves) + | otherwise + = panic "Liveness.slurpConflicts: bad block" - | otherwise - = panic "Liveness.slurpConflicts: bad block" + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) - slurpLIs rsLive (conflicts, moves) [] - = (consBag rsLive conflicts, moves) + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis - slurpLIs rsLive rs (LiveInstr _ Nothing : lis) - = slurpLIs rsLive rs lis - - slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) - = let - -- regs that die because they are read for the last time at the start of an instruction - -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - -- regs live on entry to the next instruction. - -- be careful of orphans, make sure to delete dying regs _after_ unioning - -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) - -- orphan vregs are the ones that die in the same instruction they are born in. - -- these are likely to be results that are never used, but we still - -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets - (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans - in case takeRegRegMoveInstr instr of - Just rr -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , consBag rr moves) lis + in case takeRegRegMoveInstr instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis - Nothing -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , moves) lis + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis -- | For spill\/reloads -- --- SPILL v1, slot1 --- ... --- RELOAD slot1, v2 +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 -- --- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely --- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. -- -- -slurpReloadCoalesce - :: forall instr. Instruction instr - => LiveCmmTop instr - -> Bag (Reg, Reg) +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmTop statics instr + -> Bag (Reg, Reg) slurpReloadCoalesce live - = slurpCmm emptyBag live + = slurpCmm emptyBag live - where + where slurpCmm :: Bag (Reg, Reg) -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) - slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ sccs) - = slurpComp cs (flattenSCCs sccs) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ sccs) + = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg) - slurpComp cs blocks - = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM - in unionManyBags (cs : moveBags) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) slurpCompM :: [LiveBasicBlock instr] -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] - slurpCompM blocks - = do -- run the analysis once to record the mapping across jumps. - mapM_ (slurpBlock False) blocks + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks - -- run it a second time while using the information from the last pass. - -- We /could/ run this many more times to deal with graphical control - -- flow and propagating info across multiple jumps, but it's probably - -- not worth the trouble. - mapM (slurpBlock True) blocks + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks slurpBlock :: Bool -> LiveBasicBlock instr -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) - slurpBlock propagate (BasicBlock blockId instrs) - = do -- grab the slot map for entry to this block - slotMap <- if propagate - then getSlotMap blockId - else return emptyUFM - - (_, mMoves) <- mapAccumLM slurpLI slotMap instrs - return $ listToBag $ catMaybes mMoves - - slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr instr - -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] - -- for tracking slotMaps across jumps - - ( UniqFM Reg -- new slotMap - , Maybe (Reg, Reg)) -- maybe a new coalesce edge - - slurpLI slotMap li - - -- remember what reg was stored into the slot - | LiveInstr (SPILL reg slot) _ <- li - , slotMap' <- addToUFM slotMap slot reg - = return (slotMap', Nothing) - - -- add an edge betwen the this reg and the last one stored into the slot - | LiveInstr (RELOAD slot reg) _ <- li - = case lookupUFM slotMap slot of - Just reg2 - | reg /= reg2 -> return (slotMap, Just (reg, reg2)) - | otherwise -> return (slotMap, Nothing) - - Nothing -> return (slotMap, Nothing) - - -- if we hit a jump, remember the current slotMap - | LiveInstr (Instr instr) _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accSlotMap slotMap) targets - return (slotMap, Nothing) - - | otherwise - = return (slotMap, Nothing) - - -- record a slotmap for an in edge to this block - accSlotMap slotMap blockId - = modify (\s -> addToUFM_C (++) s blockId [slotMap]) - - -- work out the slot map on entry to this block - -- if we have slot maps for multiple in-edges then we need to merge them. - getSlotMap blockId - = do map <- get - let slotMaps = fromMaybe [] (lookupUFM map blockId) - return $ foldr mergeSlotMaps emptyUFM slotMaps - - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg - mergeSlotMaps map1 map2 - = listToUFM - $ [ (k, r1) | (k, r1) <- ufmToList map1 - , case lookupUFM map2 k of - Nothing -> False - Just r2 -> r1 == r2 ] + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: UniqFM Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( UniqFM Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge betwen the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot reg) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg + mergeSlotMaps map1 map2 + = listToUFM + $ [ (k, r1) | (k, r1) <- ufmToList map1 + , case lookupUFM map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] -- | Strip away liveness information, yielding NatCmmTop -stripLive - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> NatCmmTop instr +stripLive + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> NatCmmTop statics instr -stripLive live - = stripCmm live +stripLive platform live + = stripCmm live - where stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) - = let final_blocks = flattenSCCs sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output. This is the entry point - -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks + where stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + = let final_blocks = flattenSCCs sccs - in CmmProc info label - (ListGraph $ map stripLiveBlock $ first' : rest') + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks - -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) - = CmmProc info label (ListGraph []) + in CmmProc info label + (ListGraph $ map (stripLiveBlock platform) $ first' : rest') - -- If the proc has blocks but we don't know what the first one was, then we're dead. - stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) + -- procs used for stg_split_markers don't contain any blocks, and have no first_id. + stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) + = CmmProc info label (ListGraph []) + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc) -- | Strip away liveness information from a basic block, --- and make real spill instructions out of SPILL, RELOAD pseudos along the way. +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. stripLiveBlock - :: Instruction instr - => LiveBasicBlock instr - -> NatBasicBlock instr + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> NatBasicBlock instr -stripLiveBlock (BasicBlock i lis) - = BasicBlock i instrs' +stripLiveBlock platform (BasicBlock i lis) + = BasicBlock i instrs' - where (instrs', _) - = runState (spillNat [] lis) 0 + where (instrs', _) + = runState (spillNat [] lis) 0 - spillNat acc [] - = return (reverse acc) + spillNat acc [] + = return (reverse acc) - spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) - = do delta <- get - spillNat (mkSpillInstr reg delta slot : acc) instrs + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr platform reg delta slot : acc) instrs - spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) - = do delta <- get - spillNat (mkLoadInstr reg delta slot : acc) instrs + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr platform reg delta slot : acc) instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - | Just i <- takeDeltaInstr instr - = do put i - spillNat acc instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs -- | Erase Delta instructions. -eraseDeltasLive - :: Instruction instr - => LiveCmmTop instr - -> LiveCmmTop instr +eraseDeltasLive + :: Instruction instr + => LiveCmmTop statics instr + -> LiveCmmTop statics instr eraseDeltasLive cmm - = mapBlockTop eraseBlock cmm + = mapBlockTop eraseBlock cmm where - eraseBlock (BasicBlock id lis) - = BasicBlock id - $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) - $ lis + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis -- | Patch the registers in this code according to this register mapping. --- also erase reg -> reg moves when the reg is the same. --- also erase reg -> reg moves when the destination dies in this instr. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. patchEraseLive - :: Instruction instr - => (Reg -> Reg) - -> LiveCmmTop instr -> LiveCmmTop instr + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchEraseLive patchF cmm - = patchCmm cmm + = patchCmm cmm where - patchCmm cmm@CmmData{} = cmm + patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label sccs) - | LiveInfo static id (Just blockMap) mLiveSlots <- info - = let - patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapMap patchRegSet blockMap + patchCmm (CmmProc info label sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + blockMap' = mapMap patchRegSet blockMap - info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label $ map patchSCC sccs + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label $ map patchSCC sccs - | otherwise - = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" + | otherwise + = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" - patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) - patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) - patchBlock (BasicBlock id lis) - = BasicBlock id $ patchInstrs lis + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis - patchInstrs [] = [] - patchInstrs (li : lis) + patchInstrs [] = [] + patchInstrs (li : lis) - | LiveInstr i (Just live) <- li' - , Just (r1, r2) <- takeRegRegMoveInstr i - , eatMe r1 r2 live - = patchInstrs lis + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i + , eatMe r1 r2 live + = patchInstrs lis - | otherwise - = li' : patchInstrs lis + | otherwise + = li' : patchInstrs lis - where li' = patchRegsLiveInstr patchF li + where li' = patchRegsLiveInstr patchF li - eatMe r1 r2 live - -- source and destination regs are the same - | r1 == r2 = True + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True - -- desination reg is never used - | elementOfUniqSet r2 (liveBorn live) - , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) - = True + -- desination reg is never used + | elementOfUniqSet r2 (liveBorn live) + , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) + = True - | otherwise = False + | otherwise = False -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr - :: Instruction instr - => (Reg -> Reg) - -> LiveInstr instr -> LiveInstr instr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr patchRegsLiveInstr patchF li = case li of - LiveInstr instr Nothing - -> LiveInstr (patchRegsOfInstr instr patchF) Nothing + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - LiveInstr instr (Just live) - -> LiveInstr - (patchRegsOfInstr instr patchF) - (Just live - { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live - , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live - , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live + , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live + , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) -------------------------------------------------------------------------------- -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information -natCmmTopToLive - :: Instruction instr - => NatCmmTop instr - -> LiveCmmTop instr +natCmmTopToLive + :: Instruction instr + => NatCmmTop statics instr + -> LiveCmmTop statics instr natCmmTopToLive (CmmData i d) - = CmmData i d + = CmmData i d natCmmTopToLive (CmmProc info lbl (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) - = let first_id = blockId first - sccs = sccBlocks blocks - sccsLive = map (fmap (\(BasicBlock l instrs) -> - BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) - $ sccs - - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive + = let first_id = blockId first + sccs = sccBlocks blocks + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC (NatBasicBlock instr)] + +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC (NatBasicBlock instr)] sccBlocks blocks = stronglyConnCompFromEdgedVertices graph where - getOutEdges :: Instruction instr => [instr] -> [BlockId] - getOutEdges instrs = concat $ map jumpDestsOfInstr instrs + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) - | block@(BasicBlock id instrs) <- blocks ] + graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) + | block@(BasicBlock id instrs) <- blocks ] --------------------------------------------------------------------------------- -- Annotate code with register liveness information -- regLiveness - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (LiveCmmTop instr) + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> UniqSM (LiveCmmTop statics instr) -regLiveness (CmmData i d) - = returnUs $ CmmData i d +regLiveness _ (CmmData i d) + = returnUs $ CmmData i d -regLiveness (CmmProc info lbl []) - | LiveInfo static mFirst _ _ <- info - = returnUs $ CmmProc - (LiveInfo static mFirst (Just mapEmpty) Map.empty) - lbl [] +regLiveness _ (CmmProc info lbl []) + | LiveInfo static mFirst _ _ <- info + = returnUs $ CmmProc + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] -regLiveness (CmmProc info lbl sccs) - | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness sccs +regLiveness platform (CmmProc info lbl sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs - in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl ann_sccs + in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + lbl ann_sccs -- ----------------------------------------------------------------------------- -- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse dependent order. --- If they're not the liveness information will be wrong, and we'll get a bad allocation. --- Better to check for this precondition explicitly or some other poor sucker will --- waste a day staring at bad assembly code.. --- +-- The computeLiveness function requires SCCs to be in reverse dependent order. +-- If they're not the liveness information will be wrong, and we'll get a bad allocation. +-- Better to check for this precondition explicitly or some other poor sucker will +-- waste a day staring at bad assembly code.. +-- checkIsReverseDependent - :: Instruction instr - => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. - -> Maybe BlockId -- ^ BlockIds that fail the test (if any) - + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + checkIsReverseDependent sccs' = go emptyUniqSet sccs' - where go _ [] - = Nothing - - go blocksSeen (AcyclicSCC block : sccs) - = let dests = slurpJumpDestsOfBlock block - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - go blocksSeen (CyclicSCC blocks : sccs) - = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - slurpJumpDestsOfBlock (BasicBlock _ instrs) - = unionManyUniqSets - $ map (mkUniqSet . jumpDestsOfInstr) - [ i | LiveInstr i _ <- instrs] + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] -- | If we've compute liveness info for this code already we have to reverse -- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr reverseBlocksInTops top = case top of - CmmData{} -> top - CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + CmmData{} -> top + CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + - -- | Computing liveness --- +-- -- On entry, the SCCs must be in "reverse" order: later blocks may transfer -- control to earlier ones only, else `panic`. --- +-- -- The SCCs returned are in the *opposite* order, which is exactly what we -- want for the next pass. -- computeLiveness - :: (Outputable instr, Instruction instr) - => [SCC (LiveBasicBlock instr)] - -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annontated with set of live registers - -- on entry to the block. - -computeLiveness sccs + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap RegSet) -- blocks annontated with set of live registers + -- on entry to the block. + +computeLiveness platform sccs = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs emptyBlockMap [] sccs - Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" - (vcat [ text "SCCs aren't in reverse dependent order" - , text "bad blockId" <+> ppr bad - , ppr sccs]) + Nothing -> livenessSCCs emptyBlockMap [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , pprPlatform platform sccs]) livenessSCCs :: Instruction instr => BlockMap RegSet - -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] - , BlockMap RegSet) + , BlockMap RegSet) -livenessSCCs blockmap done [] - = (done, blockmap) +livenessSCCs blockmap done [] + = (done, blockmap) livenessSCCs blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock blockmap block - in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs + = let (blockmap', block') = livenessBlock blockmap block + in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs livenessSCCs blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs blockmap' (CyclicSCC blocks':done) sccs + (CyclicSCC blocks : sccs) = + livenessSCCs blockmap' (CyclicSCC blocks':done) sccs where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks iterateUntilUnchanged :: (a -> b -> (a,c)) -> (a -> a -> Bool) -> a -> b -> (a,c) - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") + iterateUntilUnchanged f eq a b + = head $ + concatMap tail $ + groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ + iterate (\(a, _) -> f a b) $ + (a, panic "RegLiveness.livenessSCCs") - linearLiveness - :: Instruction instr - => BlockMap RegSet -> [LiveBasicBlock instr] - -> (BlockMap RegSet, [LiveBasicBlock instr]) + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) linearLiveness = mapAccumL livenessBlock -- probably the least efficient way to compare two -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ mapToList a - b' = map f $ mapToList b - f (key,elt) = (key, uniqSetToList elt) + equalBlockMaps a b + = a' == b' + where a' = map f $ mapToList a + b' = map f $ mapToList b + f (key,elt) = (key, uniqSetToList elt) -- | Annotate a basic block with register liveness information. -- livenessBlock - :: Instruction instr - => BlockMap RegSet - -> LiveBasicBlock instr - -> (BlockMap RegSet, LiveBasicBlock instr) + :: Instruction instr + => BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) livenessBlock blockmap (BasicBlock block_id instrs) = let - (regsLiveOnEntry, instrs1) - = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = mapInsert block_id regsLiveOnEntry blockmap + (regsLiveOnEntry, instrs1) + = livenessBack emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap - instrs2 = livenessForward regsLiveOnEntry instrs1 + instrs2 = livenessForward regsLiveOnEntry instrs1 - output = BasicBlock block_id instrs2 + output = BasicBlock block_id instrs2 - in ( blockmap', output) + in ( blockmap', output) -- | Calculate liveness going forwards, --- filling in when regs are born +-- filling in when regs are born livenessForward - :: Instruction instr - => RegSet -- regs live on this instr - -> [LiveInstr instr] -> [LiveInstr instr] + :: Instruction instr + => RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] -livenessForward _ [] = [] +livenessForward _ [] = [] livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) - | Nothing <- mLive - = li : livenessForward rsLiveEntry lis + | Nothing <- mLive + = li : livenessForward rsLiveEntry lis - | Just live <- mLive - , RU _ written <- regUsageOfInstr instr - = let - -- Regs that are written to but weren't live on entry to this instruction - -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written + | Just live <- mLive + , RU _ written <- regUsageOfInstr instr + = let + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) - in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward rsLiveNext lis + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward rsLiveNext lis -livenessForward _ _ = panic "RegLiveness.livenessForward: no match" +livenessForward _ _ = panic "RegLiveness.livenessForward: no match" -- | Calculate liveness going backwards, --- filling in when regs die, and what regs are live across each instruction +-- filling in when regs die, and what regs are live across each instruction livenessBack - :: Instruction instr - => RegSet -- regs live on this instr - -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (RegSet, [LiveInstr instr]) + :: Instruction instr + => RegSet -- regs live on this instr + -> BlockMap RegSet -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) livenessBack liveregs _ done [] = (liveregs, done) livenessBack liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 liveregs blockmap instr - in livenessBack liveregs' blockmap (instr' : acc) instrs + = let (liveregs', instr') = liveness1 liveregs blockmap instr + in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness -liveness1 - :: Instruction instr - => RegSet - -> BlockMap RegSet - -> LiveInstr instr - -> (RegSet, LiveInstr instr) +liveness1 + :: Instruction instr + => RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) liveness1 liveregs _ (LiveInstr instr _) - | isMetaInstr instr - = (liveregs, LiveInstr instr Nothing) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) liveness1 liveregs blockmap (LiveInstr instr _) - | not_a_branch - = (liveregs1, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) - - | otherwise - = (liveregs_br, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) - - where - RU read written = regUsageOfInstr instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDestsOfInstr instr -- where we go from here - not_a_branch = null targets - - targetLiveRegs target + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying + , liveDieWrite = mkUniqSet w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying_br + , liveDieWrite = mkUniqSet w_dying })) + + where + RU read written = regUsageOfInstr instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = [ reg | reg <- read, reg `notElem` written, + not (elementOfUniqSet reg liveregs) ] + + w_dying = [ reg | reg <- written, + not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets + + targetLiveRegs target = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - liveregs_br = liveregs1 `unionUniqSets` live_from_branch + liveregs_br = liveregs1 `unionUniqSets` live_from_branch -- registers that are live only in the branch targets should -- be listed as dying here. diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a4dbbe8771..6f454a3733 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -41,28 +41,30 @@ import OldCmm import CLabel -- The rest: +import DynFlags import StaticFlags ( opt_PIC ) import OrdList import Outputable +import Platform import Unique import Control.Monad ( mapAndUnzipM ) -- | Top level code generation -cmmTopCodeGen - :: RawCmmTop - -> NatM [NatCmmTop Instr] +cmmTopCodeGen :: RawCmmTop + -> NatM [NatCmmTop CmmStatics Instr] -cmmTopCodeGen - (CmmProc info lab (ListGraph blocks)) - = do - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks +cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) + = do + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks - let proc = CmmProc info lab (ListGraph $ concat nat_blocks) - let tops = proc : concat statics + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let tops = proc : concat statics + + return tops - return tops - cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -72,12 +74,12 @@ cmmTopCodeGen (CmmData sec dat) = do -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen :: Platform + -> CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop CmmStatics Instr]) -basicBlockCodeGen cmm@(BasicBlock id stmts) = do +basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let (top,other_blocks,statics) @@ -94,7 +96,7 @@ basicBlockCodeGen cmm@(BasicBlock id stmts) = do -- do intra-block sanity checking blocksChecked - = map (checkBlock cmm) + = map (checkBlock platform cmm) $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -313,8 +315,8 @@ genSwitch expr ids , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 7445f7168e..3e629c47f5 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -24,8 +24,10 @@ import CLabel import BasicTypes import OrdList +import DynFlags import FastString import Outputable +import Platform {- Now the biggest nightmare---calls. Most of the nastiness is buried in @@ -137,6 +139,7 @@ genCCall target dest_regs argsAndHints let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) + dflags <- getDynFlagsNat return $ argcode `appOL` move_sp_down `appOL` @@ -144,7 +147,7 @@ genCCall target dest_regs argsAndHints callinsns `appOL` unitOL NOP `appOL` move_sp_up `appOL` - assign_code dest_regs + assign_code (targetPlatform dflags) dest_regs -- | Generate code to calculate an argument, and move it into one @@ -224,11 +227,11 @@ move_final (v:vs) (a:az) offset -- | Assign results returned from the call into their -- desination regs. -- -assign_code :: [CmmHinted LocalReg] -> OrdList Instr +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr -assign_code [] = nilOL +assign_code _ [] = nilOL -assign_code [CmmHinted dest _hint] +assign_code platform [CmmHinted dest _hint] = let rep = localRegType dest width = typeWidth rep r_dest = getRegisterReg (CmmLocal dest) @@ -244,20 +247,20 @@ assign_code [CmmHinted dest _hint] | not $ isFloatType rep , W32 <- width - = unitOL $ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest | not $ isFloatType rep , W64 <- width , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr (regSingle $ oReg 1) r_dest] + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] | otherwise = panic "SPARC.CodeGen.GenCCall: no match" in result -assign_code _ +assign_code _ _ = panic "SPARC.CodeGen.GenCCall: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index d4500e8a8e..3e49f5c025 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -21,7 +21,7 @@ import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr expandTop top@(CmmData{}) = top diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 9d6aa5e646..ddeed0508b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -83,9 +83,8 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal SETHI (HI (ImmCLbl lbl)) tmp, @@ -97,9 +96,8 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d W64)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 180ec315ee..6bf2a8f32d 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -23,6 +23,7 @@ import Reg import OldCmm +import DynFlags import OrdList import Outputable @@ -182,10 +183,12 @@ iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - let code = a_code + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + code = a_code `appOL` toOL - [ mkRegRegMoveInstr g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr a_reg r_dst_lo ] + [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr platform a_reg r_dst_lo ] return $ ChildCode64 code r_dst_lo diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index ca4c8e4994..a3053cbae8 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -15,15 +15,17 @@ import Instruction import OldCmm import Outputable +import Platform -- | Enforce intra-block invariants. -- -checkBlock - :: CmmBasicBlock - -> NatBasicBlock Instr -> NatBasicBlock Instr +checkBlock :: Platform + -> CmmBasicBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs) +checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -31,9 +33,9 @@ checkBlock cmm block@(BasicBlock _ instrs) = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , ppr cmm + , pprPlatform platform cmm , text " -- native code ---------\n" - , ppr block ]) + , pprPlatform platform block ]) checkBlockInstrs :: [Instr] -> Bool diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 93f4d27444..61090e05c8 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -43,6 +43,7 @@ import OldCmm import FastString import FastBool import Outputable +import Platform -- | Register or immediate @@ -112,7 +113,7 @@ data Instr -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- Start a new basic block. Useful during codegen, removed later. -- Preceding instruction should be a jump, as per the invariants @@ -363,15 +364,16 @@ sparc_patchJumpInstr insn patchF -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr - :: Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to spill + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkSpillInstr reg _ slot +sparc_mkSpillInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -382,15 +384,16 @@ sparc_mkSpillInstr reg _ slot -- | Make a spill reload instruction. sparc_mkLoadInstr - :: Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to load into + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkLoadInstr reg _ slot +sparc_mkLoadInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -430,13 +433,14 @@ sparc_isMetaInstr instr -- have to go via memory. -- sparc_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr - -sparc_mkRegRegMoveInstr src dst - | srcClass <- targetClassOfReg src - , dstClass <- targetClassOfReg dst + :: Platform + -> Reg + -> Reg + -> Instr + +sparc_mkRegRegMoveInstr platform src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst , srcClass == dstClass = case srcClass of RcInteger -> ADD False False src (RIReg g0) dst diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index d78d1a760e..bf3fd3c303 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -39,7 +39,8 @@ import CLabel import Unique ( Uniquable(..), pprUnique ) import qualified Outputable -import Outputable (Outputable, panic) +import Outputable (PlatformOutputable, panic) +import Platform import Pretty import FastString import Data.Word @@ -47,24 +48,28 @@ import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map pprBasicBlock blocks) + +pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ vcat (map pprBasicBlock blocks) -- above: Even the first block gets a label, because with branch-chain @@ -76,12 +81,10 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif @@ -91,9 +94,10 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes pprData (CmmStaticLit lit) = pprDataItem lit @@ -125,16 +129,12 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int bytes - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr +instance PlatformOutputable Instr where + pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr -- | Pretty print a register. diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 30e48bb377..10e2e9fbaa 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -3,7 +3,7 @@ module SPARC.ShortcutJump ( JumpDest(..), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic, + shortcutStatics, shortBlockId ) @@ -38,16 +38,23 @@ shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index b357675eeb..089269785c 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -40,69 +40,70 @@ import qualified PPC.Regs as PPC import qualified SPARC.Regs as SPARC --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -targetVirtualRegSqueeze :: RegClass -> VirtualReg -> FastInt -targetVirtualRegSqueeze - = case platformArch defaultTargetPlatform of +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze platform + = case platformArch platform of ArchX86 -> X86.virtualRegSqueeze ArchX86_64 -> X86.virtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze ArchSPARC -> SPARC.virtualRegSqueeze ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" + ArchARM -> panic "targetVirtualRegSqueeze ArchARM" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" -targetRealRegSqueeze :: RegClass -> RealReg -> FastInt -targetRealRegSqueeze - = case platformArch defaultTargetPlatform of +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt +targetRealRegSqueeze platform + = case platformArch platform of ArchX86 -> X86.realRegSqueeze ArchX86_64 -> X86.realRegSqueeze ArchPPC -> PPC.realRegSqueeze ArchSPARC -> SPARC.realRegSqueeze ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" + ArchARM -> panic "targetRealRegSqueeze ArchARM" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" -targetClassOfRealReg :: RealReg -> RegClass -targetClassOfRealReg - = case platformArch defaultTargetPlatform of +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of ArchX86 -> X86.classOfRealReg ArchX86_64 -> X86.classOfRealReg ArchPPC -> PPC.classOfRealReg ArchSPARC -> SPARC.classOfRealReg ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" + ArchARM -> panic "targetClassOfRealReg ArchARM" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" -- TODO: This should look at targetPlatform too targetWordSize :: Size targetWordSize = intSize wordWidth -targetMkVirtualReg :: Unique -> Size -> VirtualReg -targetMkVirtualReg - = case platformArch defaultTargetPlatform of +targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of ArchX86 -> X86.mkVirtualReg ArchX86_64 -> X86.mkVirtualReg ArchPPC -> PPC.mkVirtualReg ArchSPARC -> SPARC.mkVirtualReg ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" + ArchARM -> panic "targetMkVirtualReg ArchARM" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" -targetRegDotColor :: RealReg -> SDoc -targetRegDotColor - = case platformArch defaultTargetPlatform of - ArchX86 -> X86.regDotColor - ArchX86_64 -> X86.regDotColor +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform ArchPPC -> PPC.regDotColor ArchSPARC -> SPARC.regDotColor ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" + ArchARM -> panic "targetRegDotColor ArchARM" ArchUnknown -> panic "targetRegDotColor ArchUnknown" -targetClassOfReg :: Reg -> RegClass -targetClassOfReg reg +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg = case reg of - RegVirtual vr -> classOfVirtualReg vr - RegReal rr -> targetClassOfRealReg rr + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg platform rr diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index a667c51532..6ab7cff93b 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -80,7 +80,7 @@ if_sse2 sse2 x87 = do cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -95,13 +95,13 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Nothing -> return tops cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop (Alignment, CmmStatics) Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -323,7 +323,7 @@ iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 let r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) code = toOL [ MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) @@ -352,7 +352,7 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do (rlo,rhi) <- getNewRegPairNat II32 let r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) r1hi = getHiVRegFromLo r1lo code = code1 `appOL` toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), @@ -1123,10 +1123,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData - [CmmAlign align, - CmmDataLabel lbl, - CmmStaticLit lit] + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -1580,346 +1577,355 @@ genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL genCCall target dest_regs args = do dflags <- getDynFlagsNat if target32Bit (targetPlatform dflags) - then case (target, dest_regs) of - -- void return type prim op - (CmmPrim op, []) -> - outOfLineCmmOp op Nothing args - -- we only cope with a single result for foreign calls - (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do - l1 <- getNewLabelNat - l2 <- getNewLabelNat - sse2 <- sse2Enabled - if sse2 - then - outOfLineCmmOp op (Just r_hinted) args - else case op of - MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args - MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args - - MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args - MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args - - MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args - MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args - - MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args - MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - - _other_op -> outOfLineCmmOp op (Just r_hinted) args - - where - actuallyInlineFloatOp instr size [CmmHinted x _] - = do res <- trivialUFCode size (instr size) x - any <- anyReg res - return (any (getRegisterReg False (CmmLocal r))) - - actuallyInlineFloatOp _ _ args - = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" - ++ show (length args) ++ ")" - _ -> do - let - sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) - raw_arg_size = sum sizes - tot_arg_size = if isDarwin then roundTo 16 raw_arg_size else raw_arg_size - arg_pad_size = tot_arg_size - raw_arg_size - delta0 <- getDeltaNat - when isDarwin $ setDeltaNat (delta0 - arg_pad_size) - - use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse args) - delta <- getDeltaNat + then genCCall32 target dest_regs args + else genCCall64 target dest_regs args + +genCCall32 :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32 target dest_regs args = + case (target, dest_regs) of + -- void return type prim op + (CmmPrim op, []) -> + outOfLineCmmOp op Nothing args + -- we only cope with a single result for foreign calls + (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + l1 <- getNewLabelNat + l2 <- getNewLabelNat + sse2 <- sse2Enabled + if sse2 + then + outOfLineCmmOp op (Just r_hinted) args + else case op of + MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args + MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args + + MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args + MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args + + MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args + MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args + + MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args + MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args + + _other_op -> outOfLineCmmOp op (Just r_hinted) args + + where + actuallyInlineFloatOp instr size [CmmHinted x _] + = do res <- trivialUFCode size (instr size) x + any <- anyReg res + return (any (getRegisterReg False (CmmLocal r))) + + actuallyInlineFloatOp _ _ args + = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + ++ show (length args) ++ ")" + _ -> do + let + sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) + raw_arg_size = sum sizes + tot_arg_size = roundTo 16 raw_arg_size + arg_pad_size = tot_arg_size - raw_arg_size + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) + + use_sse2 <- sse2Enabled + push_codes <- mapM (push_arg use_sse2) (reverse args) + delta <- getDeltaNat + + -- in + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) []), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do { (dyn_r, dyn_c) <- getSomeReg expr + ; ASSERT( isWord32 (cmmExprType expr) ) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." + + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- even if we are doing stdcall, though (#5052) + pop_size | cconv /= StdCallConv = tot_arg_size + | otherwise = arg_pad_size + + call = callinsns `appOL` + toOL ( + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) + ++ + [DELTA (delta + tot_arg_size)] + ) + -- in + setDeltaNat (delta + tot_arg_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] + | isFloatType ty = + if use_sse2 + then let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + sz = floatSize w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + GST sz fake0 tmp_amode, + MOV sz (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp)] + else unitOL (GMOV fake0 r_dest) + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getRegisterReg use_sse2 (CmmLocal dest) + assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) + + where + arg_size :: CmmType -> Int -- Width in bytes + arg_size ty = widthInBytes (typeWidth ty) + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) - -- in - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) []), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType expr) ) - return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." - - let push_code - | isDarwin && (arg_pad_size /= 0) - = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), - DELTA (delta0 - arg_pad_size)] - `appOL` concatOL push_codes - | otherwise - = concatOL push_codes - - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - -- - -- We have to pop any stack padding we added - -- on Darwin even if we are doing stdcall, though (#5052) - pop_size | cconv /= StdCallConv = tot_arg_size - | isDarwin = arg_pad_size - | otherwise = 0 - - call = callinsns `appOL` - toOL ( - (if pop_size==0 then [] else - [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) - ++ - [DELTA (delta + tot_arg_size)] - ) - -- in - setDeltaNat (delta + tot_arg_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] - | isFloatType ty = - if use_sse2 - then let tmp_amode = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - sz = floatSize w - in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), - GST sz fake0 tmp_amode, - MOV sz (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp)] - else unitOL (GMOV fake0 r_dest) - | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), - MOV II32 (OpReg edx) (OpReg r_dest_hi)] - | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) - where - ty = localRegType dest - w = typeWidth ty - b = widthInBytes w - r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg use_sse2 (CmmLocal dest) - assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) - - return (push_code `appOL` - call `appOL` - assign_code dest_regs) - - where - isDarwin = case platformOS (targetPlatform dflags) of - OSDarwin -> True - _ -> False - - arg_size :: CmmType -> Int -- Width in bytes - arg_size ty = widthInBytes (typeWidth ty) - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) - - push_arg :: Bool -> HintedCmmActual {-current argument-} - -> NatM InstrBlock -- code - - push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 - | isWord64 arg_ty = do - ChildCode64 code r_lo <- iselExpr64 arg - delta <- getDeltaNat - setDeltaNat (delta - 8) - let - r_hi = getHiVRegFromLo r_lo - -- in - return ( code `appOL` - toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), - PUSH II32 (OpReg r_lo), DELTA (delta - 8), - DELTA (delta-8)] - ) - - | isFloatType arg_ty = do - (reg, code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `appOL` - toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), - DELTA (delta-size), - let addr = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - size = floatSize (typeWidth arg_ty) - in - if use_sse2 - then MOV size (OpReg reg) (OpAddr addr) - else GST size reg addr - ] - ) - - | otherwise = do - (operand, code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `snocOL` - PUSH II32 operand `snocOL` - DELTA (delta-size)) - - where - arg_ty = cmmExprType arg - size = arg_size arg_ty -- Byte size - else case (target, dest_regs) of - (CmmPrim op, []) -> - -- void return type prim op - outOfLineCmmOp op Nothing args - (CmmPrim op, [res]) -> - -- we only cope with a single result for foreign calls - outOfLineCmmOp op (Just res) args - _ -> do - -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL - - let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used - -- for annotating the call instruction with - - sse_regs = length fp_regs_used - - tot_arg_size = arg_size * length stack_args - - -- On entry to the called function, %rsp should be aligned - -- on a 16-byte boundary +8 (i.e. the first stack arg after - -- the return address is 16-byte aligned). In STG land - -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just - -- need to make sure we push a multiple of 16-bytes of args, - -- plus the return address, to get the correct alignment. - -- Urg, this is hard. We need to feed the delta back into - -- the arg pushing code. - (real_size, adjust_rsp) <- - if tot_arg_size `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta-8) - return (tot_arg_size+8, toOL [ - SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), - DELTA (delta-8) - ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL + push_arg :: Bool -> HintedCmmActual {-current argument-} + -> NatM InstrBlock -- code + + push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 + | isWord64 arg_ty = do + ChildCode64 code r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + let + r_hi = getHiVRegFromLo r_lo + -- in + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + size = floatSize (typeWidth arg_ty) + in + if use_sse2 + then MOV size (OpReg reg) (OpAddr addr) + else GST size reg addr + ] + ) + + | otherwise = do + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType arg + size = arg_size arg_ty -- Byte size + +genCCall64 :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64 target dest_regs args = + case (target, dest_regs) of + (CmmPrim op, []) -> + -- void return type prim op + outOfLineCmmOp op Nothing args + (CmmPrim op, [res]) -> + -- we only cope with a single result for foreign calls + outOfLineCmmOp op (Just res) args + _ -> do + -- load up the register arguments + (stack_args, aregs, fregs, load_args_code) + <- load_args args allArgRegs allFPArgRegs nilOL + + let + fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) + arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + -- for annotating the call instruction with + + sse_regs = length fp_regs_used + + tot_arg_size = arg_size * length stack_args + + -- On entry to the called function, %rsp should be aligned + -- on a 16-byte boundary +8 (i.e. the first stack arg after + -- the return address is 16-byte aligned). In STG land + -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just + -- need to make sure we push a multiple of 16-bytes of args, + -- plus the return address, to get the correct alignment. + -- Urg, this is hard. We need to feed the delta back into + -- the arg pushing code. + (real_size, adjust_rsp) <- + if tot_arg_size `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... delta <- getDeltaNat + setDeltaNat (delta-8) + return (tot_arg_size+8, toOL [ + SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), + DELTA (delta-8) + ]) + + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + delta <- getDeltaNat + + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) - CmmPrim _ - -> panic $ "genCCall: Can't handle CmmPrim call type here, error " - ++ "probably because too many return values." - - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - -- in - setDeltaNat (delta + real_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) - assign_code _many = panic "genCCall.assign_code many" - - return (load_args_code `appOL` - adjust_rsp `appOL` - push_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) - - where - arg_size = 8 -- always, at the mo - - load_args :: [CmmHinted CmmExpr] - -> [Reg] -- int regs avail for args - -> [Reg] -- FP regs avail for args - -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) - load_args args [] [] code = return (args, [], [], code) - -- no more regs to use - load_args [] aregs fregs code = return ([], aregs, fregs, code) - -- no more args to push - load_args ((CmmHinted arg hint) : rest) aregs fregs code - | isFloatType arg_rep = - case fregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest aregs rs (code `appOL` arg_code r) - | otherwise = - case aregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest rs fregs (code `appOL` arg_code r) - where - arg_rep = cmmExprType arg - - push_this_arg = do - (args',ars,frs,code') <- load_args rest aregs fregs code - return ((CmmHinted arg hint):args', ars, frs, code') - - push_args [] code = return code - push_args ((CmmHinted arg _):rest) code - | isFloatType arg_rep = do - (arg_reg, arg_code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , - DELTA (delta-arg_size), - MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] - push_args rest code' - - | otherwise = do - -- we only ever generate word-sized function arguments. Promotion - -- has already happened: our Int8# type is kept sign-extended - -- in an Int#, for example. - ASSERT(width == W64) return () - (arg_op, arg_code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - PUSH II64 arg_op, - DELTA (delta-arg_size)] - push_args rest code' - where - arg_rep = cmmExprType arg - width = typeWidth arg_rep + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + (if cconv == StdCallConv || real_size==0 then [] else + [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + -- in + setDeltaNat (delta + real_size) + + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" + + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) + + where + arg_size = 8 -- always, at the mo + + load_args :: [CmmHinted CmmExpr] + -> [Reg] -- int regs avail for args + -> [Reg] -- FP regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args args [] [] code = return (args, [], [], code) + -- no more regs to use + load_args [] aregs fregs code = return ([], aregs, fregs, code) + -- no more args to push + load_args ((CmmHinted arg hint) : rest) aregs fregs code + | isFloatType arg_rep = + case fregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest aregs rs (code `appOL` arg_code r) + | otherwise = + case aregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest rs fregs (code `appOL` arg_code r) + where + arg_rep = cmmExprType arg + + push_this_arg = do + (args',ars,frs,code') <- load_args rest aregs fregs code + return ((CmmHinted arg hint):args', ars, frs, code') + + push_args [] code = return code + push_args ((CmmHinted arg _):rest) code + | isFloatType arg_rep = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , + DELTA (delta-arg_size), + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] + push_args rest code' + + | otherwise = do + -- we only ever generate word-sized function arguments. Promotion + -- has already happened: our Int8# type is kept sign-extended + -- in an Int#, for example. + ASSERT(width == W64) return () + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] + push_args rest code' + where + arg_rep = cmmExprType arg + width = typeWidth arg_rep -- | We're willing to inline and unroll memcpy/memset calls that touch -- at most these many bytes. This threshold is the same as the one @@ -2046,11 +2052,11 @@ genSwitch expr ids -- in return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop (Alignment, CmmStatics) Instr) generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) generateJumpTableForInstr _ = Nothing -createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g +createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g createJumpTable ids section lbl = let jumpTable | opt_PIC = @@ -2061,7 +2067,7 @@ createJumpTable ids section lbl where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids | otherwise = map jumpTableEntry ids - in CmmData section (CmmDataLabel lbl : jumpTable) + in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9c851a859..0e292ac21f 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -25,8 +25,10 @@ import OldCmm import FastString import FastBool import Outputable +import Platform import Constants (rESERVED_C_STACK_BYTES) +import BasicTypes (Alignment) import CLabel import UniqSet import Unique @@ -151,7 +153,6 @@ bit precision. --SDM 1/2003 -} - data Instr -- comment pseudo-op = COMMENT FastString @@ -159,7 +160,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section (Alignment, CmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -603,16 +604,17 @@ x86_patchJumpInstr insn patchF -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkSpillInstr reg delta slot +x86_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpReg reg) (OpAddr (spRel off_w)) RcDouble -> GST FF80 reg (spRel off_w) {- RcFloat/RcDouble -} @@ -622,16 +624,17 @@ x86_mkSpillInstr reg delta slot -- | Make a spill reload instruction. x86_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkLoadInstr reg delta slot +x86_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpAddr (spRel off_w)) (OpReg reg) RcDouble -> GLD FF80 (spRel off_w) reg {- RcFloat/RcDouble -} @@ -689,12 +692,13 @@ x86_isMetaInstr instr -- have to go via memory. -- x86_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr + :: Platform + -> Reg + -> Reg + -> Instr -x86_mkRegRegMoveInstr src dst - = case targetClassOfReg src of +x86_mkRegRegMoveInstr platform src dst + = case targetClassOfReg platform src of #if i386_TARGET_ARCH RcInteger -> MOV II32 (OpReg src) (OpReg dst) #else @@ -805,16 +809,24 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn shortcutJump' _ _ other = other -- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq))) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 769057ae02..a755d839fb 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -31,13 +31,15 @@ import Reg import PprBase +import BasicTypes (Alignment) import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable (panic, Outputable) +import Outputable (panic, PlatformOutputable) import Data.Word @@ -48,26 +50,31 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop (Alignment, CmmStatics) Instr -> Doc +pprNatCmmTop platform (CmmData section dats) = + pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl -pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) $$ + pprSizeDecl platform lbl + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -77,62 +84,57 @@ pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) = -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif - $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl) + $$ pprSizeDecl platform info_lbl -- | Output the ELF .size directive. -pprSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprSizeDecl lbl = +pprSizeDecl :: Platform -> CLabel -> Doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = ptext (sLit "\t.size") <+> pprCLabel_asm lbl <> ptext (sLit ", .-") <> pprCLabel_asm lbl -#else -pprSizeDecl _ = empty -#endif + | otherwise = empty -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock blockid instrs) = - pprLabel (mkAsmTempLabel (getUnique blockid)) $$ - vcat (map pprInstr instrs) +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = + pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map (pprInstr platform) instrs) -pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl -pprData (CmmString str) = pprASCII str +pprDatas :: Platform -> (Alignment, CmmStatics) -> Doc +pprDatas platform (align, (Statics lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData platform) dats) + -- TODO: could remove if align == 1 -#if darwin_TARGET_OS -pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes -#else -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes -#endif +pprData :: Platform -> CmmStatic -> Doc +pprData _ (CmmString str) = pprASCII str -pprData (CmmStaticLit lit) = pprDataItem lit +pprData platform (CmmUninitialised bytes) + | platformOS platform == OSDarwin = ptext (sLit ".space ") <> int bytes + | otherwise = ptext (sLit ".skip ") <> int bytes + +pprData _ (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl -pprTypeAndSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprTypeAndSizeDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") -#else -pprTypeAndSizeDecl _ - = empty -#endif +pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl platform lbl + | osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + = ptext (sLit ".type ") <> + pprCLabel_asm lbl <> ptext (sLit ", @object") + | otherwise = empty -pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprLabel :: Platform -> CLabel -> Doc +pprLabel platform lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (pprCLabel_asm lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -142,15 +144,13 @@ pprASCII str do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc - - -pprAlign bytes - = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes) +pprAlign :: Platform -> Int -> Doc +pprAlign platform bytes + = ptext (sLit ".align ") <> int alignment where - -#if darwin_TARGET_OS - pow2 = log2 bytes + alignment = if platformOS platform == OSDarwin + then log2 bytes + else bytes log2 :: Int -> Int -- cache the common ones log2 1 = 0 @@ -158,18 +158,16 @@ pprAlign bytes log2 4 = 2 log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -#endif -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr - +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -pprReg :: Size -> Reg -> Doc -pprReg s r +pprReg :: Platform -> Size -> Reg -> Doc +pprReg _ s r = case r of RegReal (RealRegSingle i) -> ppr_reg_no s i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" @@ -338,8 +336,8 @@ pprImm (ImmConstantDiff a b) = pprImm a <> char '-' -pprAddr :: AddrMode -> Doc -pprAddr (ImmAddr imm off) +pprAddr :: Platform -> AddrMode -> Doc +pprAddr _ (ImmAddr imm off) = let pp_imm = pprImm imm in if (off == 0) then @@ -349,11 +347,11 @@ pprAddr (ImmAddr imm off) else pp_imm <> char '+' <> int off -pprAddr (AddrBaseIndex base index displacement) +pprAddr platform (AddrBaseIndex base index displacement) = let pp_disp = ppr_disp displacement pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg archWordSize r + pp_reg r = pprReg platform archWordSize r in case (base, index) of (EABaseNone, EAIndexNone) -> pp_disp @@ -486,23 +484,23 @@ pprDataItem lit -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) = ptext (sLit "# ") <> ftext s +pprInstr _ (COMMENT s) = ptext (sLit "# ") <> ftext s -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char ' ', @@ -510,7 +508,7 @@ pprInstr (SPILL reg slot) comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char ' ', @@ -519,48 +517,48 @@ pprInstr (RELOAD slot reg) pprUserReg reg] -} -pprInstr (MOV size src dst) - = pprSizeOpOp (sLit "mov") size src dst +pprInstr platform (MOV size src dst) + = pprSizeOpOp platform (sLit "mov") size src dst -pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst +pprInstr platform (MOVZxL II32 src dst) = pprSizeOpOp platform (sLit "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because -- the reg alloc would tend to throw away a plain reg-to-reg -- move, and we still want it to do that. -pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst +pprInstr platform (MOVZxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movz") sizes II32 src dst -- zero-extension only needs to extend to 32 bits: on x86_64, -- the remaining zero-extension to 64 bits is automatic, and the 32-bit -- instruction is shorter. -pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst +pprInstr platform (MOVSxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movs") sizes archWordSize src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg1 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg2) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg2) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg2 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg1) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg1) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) | reg1 == reg3 - = pprInstr (ADD size (OpImm displ) dst) + = pprInstr platform (ADD size (OpImm displ) dst) -pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst +pprInstr platform (LEA size src dst) = pprSizeOpOp platform (sLit "lea") size src dst -pprInstr (ADD size (OpImm (ImmInt (-1))) dst) - = pprSizeOp (sLit "dec") size dst -pprInstr (ADD size (OpImm (ImmInt 1)) dst) - = pprSizeOp (sLit "inc") size dst -pprInstr (ADD size src dst) - = pprSizeOpOp (sLit "add") size src dst -pprInstr (ADC size src dst) - = pprSizeOpOp (sLit "adc") size src dst -pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst -pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 +pprInstr platform (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp platform (sLit "dec") size dst +pprInstr platform (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp platform (sLit "inc") size dst +pprInstr platform (ADD size src dst) + = pprSizeOpOp platform (sLit "add") size src dst +pprInstr platform (ADC size src dst) + = pprSizeOpOp platform (sLit "adc") size src dst +pprInstr platform (SUB size src dst) = pprSizeOpOp platform (sLit "sub") size src dst +pprInstr platform (IMUL size op1 op2) = pprSizeOpOp platform (sLit "imul") size op1 op2 {- A hack. The Intel documentation says that "The two and three operand forms [of IMUL] may also be used with unsigned operands @@ -569,25 +567,25 @@ pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 however, cannot be used to determine if the upper half of the result is non-zero." So there. -} -pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst -pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst +pprInstr platform (AND size src dst) = pprSizeOpOp platform (sLit "and") size src dst +pprInstr platform (OR size src dst) = pprSizeOpOp platform (sLit "or") size src dst -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst -pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst -pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst +pprInstr platform (XOR FF32 src dst) = pprOpOp platform (sLit "xorps") FF32 src dst +pprInstr platform (XOR FF64 src dst) = pprOpOp platform (sLit "xorpd") FF64 src dst +pprInstr platform (XOR size src dst) = pprSizeOpOp platform (sLit "xor") size src dst -pprInstr (NOT size op) = pprSizeOp (sLit "not") size op -pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op +pprInstr platform (NOT size op) = pprSizeOp platform (sLit "not") size op +pprInstr platform (NEGI size op) = pprSizeOp platform (sLit "neg") size op -pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst -pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst -pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst +pprInstr platform (SHL size src dst) = pprShift platform (sLit "shl") size src dst +pprInstr platform (SAR size src dst) = pprShift platform (sLit "sar") size src dst +pprInstr platform (SHR size src dst) = pprShift platform (sLit "shr") size src dst -pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src +pprInstr platform (BT size imm src) = pprSizeImmOp platform (sLit "bt") size imm src -pprInstr (CMP size src dst) - | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 - | otherwise = pprSizeOpOp (sLit "cmp") size src dst +pprInstr platform (CMP size src dst) + | is_float size = pprSizeOpOp platform (sLit "ucomi") size src dst -- SSE2 + | otherwise = pprSizeOpOp platform (sLit "cmp") size src dst where -- This predicate is needed here and nowhere else is_float FF32 = True @@ -595,63 +593,63 @@ pprInstr (CMP size src dst) is_float FF80 = True is_float _ = False -pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst -pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op -pprInstr (POP size op) = pprSizeOp (sLit "pop") size op +pprInstr platform (TEST size src dst) = pprSizeOpOp platform (sLit "test") size src dst +pprInstr platform (PUSH size op) = pprSizeOp platform (sLit "push") size op +pprInstr platform (POP size op) = pprSizeOp platform (sLit "pop") size op -- both unused (SDM): -- pprInstr PUSHA = ptext (sLit "\tpushal") -- pprInstr POPA = ptext (sLit "\tpopal") -pprInstr NOP = ptext (sLit "\tnop") -pprInstr (CLTD II32) = ptext (sLit "\tcltd") -pprInstr (CLTD II64) = ptext (sLit "\tcqto") +pprInstr _ NOP = ptext (sLit "\tnop") +pprInstr _ (CLTD II32) = ptext (sLit "\tcltd") +pprInstr _ (CLTD II64) = ptext (sLit "\tcqto") -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) +pprInstr platform (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand platform II8 op) -pprInstr (JXX cond blockid) +pprInstr _ (JXX cond blockid) = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) where lab = mkAsmTempLabel (getUnique blockid) -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) +pprInstr _ (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) -pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) -pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op) -pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op) -pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) -pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg) +pprInstr _ (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) +pprInstr platform (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand platform archWordSize op) +pprInstr platform (JMP_TBL op _ _ _) = pprInstr platform (JMP op) +pprInstr _ (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) +pprInstr platform (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg platform archWordSize reg) -pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op -pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op -pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op +pprInstr platform (IDIV sz op) = pprSizeOp platform (sLit "idiv") sz op +pprInstr platform (DIV sz op) = pprSizeOp platform (sLit "div") sz op +pprInstr platform (IMUL2 sz op) = pprSizeOp platform (sLit "imul") sz op -- x86_64 only -pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2 +pprInstr platform (MUL size op1 op2) = pprSizeOpOp platform (sLit "mul") size op1 op2 -pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2 +pprInstr platform (FDIV size op1 op2) = pprSizeOpOp platform (sLit "div") size op1 op2 -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to -pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to -pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to -pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to +pprInstr platform (CVTSS2SD from to) = pprRegReg platform (sLit "cvtss2sd") from to +pprInstr platform (CVTSD2SS from to) = pprRegReg platform (sLit "cvtsd2ss") from to +pprInstr platform (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttss2si") FF32 sz from to +pprInstr platform (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttsd2si") FF64 sz from to +pprInstr platform (CVTSI2SS sz from to) = pprSizeOpReg platform (sLit "cvtsi2ss") sz from to +pprInstr platform (CVTSI2SD sz from to) = pprSizeOpReg platform (sLit "cvtsi2sd") sz from to -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) +pprInstr platform (FETCHGOT reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ], hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), - pprReg II32 reg ] + pprReg platform II32 reg ] ] -- FETCHPC for PIC on Darwin/x86 -- get the instruction pointer into a register -- (Terminology note: the IP is called Program Counter on PPC, -- and it's a good thing to use the same name on both platforms) -pprInstr (FETCHPC reg) +pprInstr platform (FETCHPC reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ] ] @@ -661,36 +659,36 @@ pprInstr (FETCHPC reg) -- Simulating a flat register set on the x86 FP stack is tricky. -- you have to free %st(7) before pushing anything on the FP reg stack -- so as to preclude the possibility of a FP stack overflow exception. -pprInstr g@(GMOV src dst) +pprInstr platform g@(GMOV src dst) | src == dst = empty | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) -- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1) -pprInstr g@(GLD sz addr dst) - = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, - pprAddr addr, gsemi, gpop dst 1]) +pprInstr platform g@(GLD sz addr dst) + = pprG platform g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, + pprAddr platform addr, gsemi, gpop dst 1]) -- GST sz src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(GST sz src addr) +pprInstr platform g@(GST sz src addr) | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist - = pprG g (hcat [gtab, - text "fst", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, + text "fst", pprSize_x87 sz, gsp, pprAddr platform addr]) | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, - text "fstp", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, + text "fstp", pprSize_x87 sz, gsp, pprAddr platform addr]) -pprInstr g@(GLDZ dst) - = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1]) -pprInstr g@(GLD1 dst) - = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) +pprInstr platform g@(GLDZ dst) + = pprG platform g (hcat [gtab, text "fldz ; ", gpop dst 1]) +pprInstr platform g@(GLD1 dst) + = pprG platform g (hcat [gtab, text "fld1 ; ", gpop dst 1]) -pprInstr (GFTOI src dst) - = pprInstr (GDTOI src dst) +pprInstr platform (GFTOI src dst) + = pprInstr platform (GDTOI src dst) -pprInstr g@(GDTOI src dst) - = pprG g (vcat [ +pprInstr platform g@(GDTOI src dst) + = pprG platform g (vcat [ hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"], hcat [gtab, gpush src 0], hcat [gtab, text "movzwl 4(%esp), ", reg, @@ -701,20 +699,20 @@ pprInstr g@(GDTOI src dst) hcat [gtab, text "addl $8, %esp"] ]) where - reg = pprReg II32 dst + reg = pprReg platform II32 dst -pprInstr (GITOF src dst) - = pprInstr (GITOD src dst) +pprInstr platform (GITOF src dst) + = pprInstr platform (GITOD src dst) -pprInstr g@(GITOD src dst) - = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, - text " ; fildl (%esp) ; ", - gpop dst 1, text " ; addl $4,%esp"]) +pprInstr platform g@(GITOD src dst) + = pprG platform g (hcat [gtab, text "pushl ", pprReg platform II32 src, + text " ; fildl (%esp) ; ", + gpop dst 1, text " ; addl $4,%esp"]) -pprInstr g@(GDTOF src dst) - = pprG g (vcat [gtab <> gpush src 0, - gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", - gtab <> gpop dst 1]) +pprInstr platform g@(GDTOF src dst) + = pprG platform g (vcat [gtab <> gpush src 0, + gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", + gtab <> gpop dst 1]) {- Gruesome swamp follows. If you're unfortunate enough to have ventured this far into the jungle AND you give a Rat's Ass (tm) what's going @@ -754,9 +752,9 @@ pprInstr g@(GDTOF src dst) decb %al -- if (incomparable || different) then (%al == 0, ZF=1) else (%al == 0xFF, ZF=0) -} -pprInstr g@(GCMP cond src1 src2) +pprInstr platform g@(GCMP cond src1 src2) | case cond of { NE -> True; _ -> False } - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpe %ah"], @@ -764,7 +762,7 @@ pprInstr g@(GCMP cond src1 src2) text "orb %ah,%al ; decb %al ; popl %eax"] ]) | otherwise - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpo %ah"], @@ -786,95 +784,95 @@ pprInstr g@(GCMP cond src1 src2) -- there should be no others -pprInstr g@(GABS _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) +pprInstr platform g@(GABS _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) -pprInstr g@(GNEG _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) +pprInstr platform g@(GNEG _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) -pprInstr g@(GSQRT sz src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr platform g@(GSQRT sz src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GSIN sz l1 l2 src dst) - = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz) +pprInstr platform g@(GSIN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fsin" False l1 l2 src dst sz) -pprInstr g@(GCOS sz l1 l2 src dst) - = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz) +pprInstr platform g@(GCOS sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fcos" False l1 l2 src dst sz) -pprInstr g@(GTAN sz l1 l2 src dst) - = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz) +pprInstr platform g@(GTAN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fptan" True l1 l2 src dst sz) -- In the translations for GADD, GMUL, GSUB and GDIV, -- the first two cases are mere optimisations. The otherwise clause -- generates correct code under all circumstances. -pprInstr g@(GADD _ src1 src2 dst) +pprInstr platform g@(GADD _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GADD-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; faddp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GADD-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; faddp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GADD-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; faddp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GADD-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; faddp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fadd ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fadd ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GMUL _ src1 src2 dst) +pprInstr platform g@(GMUL _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GMUL-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fmulp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GMUL-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fmulp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GMUL-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fmulp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GMUL-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fmulp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fmul ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fmul ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GSUB _ src1 src2 dst) +pprInstr platform g@(GSUB _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GSUB-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fsubrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GSUB-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fsubrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GSUB-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fsubp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GSUB-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fsubp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fsub ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fsub ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GDIV _ src1 src2 dst) +pprInstr platform g@(GDIV _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GDIV-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fdivrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GDIV-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fdivrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GDIV-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fdivp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GDIV-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fdivp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fdiv ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fdiv ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr GFREE +pprInstr _ GFREE = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"), ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] -pprInstr _ +pprInstr _ _ = panic "X86.Ppr.pprInstr: no match" @@ -953,49 +951,49 @@ gregno (RegReal (RealRegSingle i)) = i gregno _ = --pprPanic "gregno" (ppr other) 999 -- bogus; only needed for debug printing -pprG :: Instr -> Doc -> Doc -pprG fake actual - = (char '#' <> pprGInstr fake) $$ actual +pprG :: Platform -> Instr -> Doc -> Doc +pprG platform fake actual + = (char '#' <> pprGInstr platform fake) $$ actual -pprGInstr :: Instr -> Doc -pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst -pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst -pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst +pprGInstr :: Platform -> Instr -> Doc +pprGInstr platform (GMOV src dst) = pprSizeRegReg platform (sLit "gmov") FF64 src dst +pprGInstr platform (GLD sz src dst) = pprSizeAddrReg platform (sLit "gld") sz src dst +pprGInstr platform (GST sz src dst) = pprSizeRegAddr platform (sLit "gst") sz src dst -pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst -pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst +pprGInstr platform (GLDZ dst) = pprSizeReg platform (sLit "gldz") FF64 dst +pprGInstr platform (GLD1 dst) = pprSizeReg platform (sLit "gld1") FF64 dst -pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst -pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst +pprGInstr platform (GFTOI src dst) = pprSizeSizeRegReg platform (sLit "gftoi") FF32 II32 src dst +pprGInstr platform (GDTOI src dst) = pprSizeSizeRegReg platform (sLit "gdtoi") FF64 II32 src dst -pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst -pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst -pprGInstr (GDTOF src dst) = pprSizeSizeRegReg (sLit "gdtof") FF64 FF32 src dst +pprGInstr platform (GITOF src dst) = pprSizeSizeRegReg platform (sLit "gitof") II32 FF32 src dst +pprGInstr platform (GITOD src dst) = pprSizeSizeRegReg platform (sLit "gitod") II32 FF64 src dst +pprGInstr platform (GDTOF src dst) = pprSizeSizeRegReg platform (sLit "gdtof") FF64 FF32 src dst -pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst -pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst -pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst -pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst -pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst -pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst -pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst +pprGInstr platform (GCMP co src dst) = pprCondRegReg platform (sLit "gcmp_") FF64 co src dst +pprGInstr platform (GABS sz src dst) = pprSizeRegReg platform (sLit "gabs") sz src dst +pprGInstr platform (GNEG sz src dst) = pprSizeRegReg platform (sLit "gneg") sz src dst +pprGInstr platform (GSQRT sz src dst) = pprSizeRegReg platform (sLit "gsqrt") sz src dst +pprGInstr platform (GSIN sz _ _ src dst) = pprSizeRegReg platform (sLit "gsin") sz src dst +pprGInstr platform (GCOS sz _ _ src dst) = pprSizeRegReg platform (sLit "gcos") sz src dst +pprGInstr platform (GTAN sz _ _ src dst) = pprSizeRegReg platform (sLit "gtan") sz src dst -pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst -pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst -pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst -pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst +pprGInstr platform (GADD sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gadd") sz src1 src2 dst +pprGInstr platform (GSUB sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gsub") sz src1 src2 dst +pprGInstr platform (GMUL sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gmul") sz src1 src2 dst +pprGInstr platform (GDIV sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gdiv") sz src1 src2 dst -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" +pprGInstr _ _ = panic "X86.Ppr.pprGInstr: no match" pprDollImm :: Imm -> Doc pprDollImm i = ptext (sLit "$") <> pprImm i -pprOperand :: Size -> Operand -> Doc -pprOperand s (OpReg r) = pprReg s r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea +pprOperand :: Platform -> Size -> Operand -> Doc +pprOperand platform s (OpReg r) = pprReg platform s r +pprOperand _ _ (OpImm i) = pprDollImm i +pprOperand platform _ (OpAddr ea) = pprAddr platform ea pprMnemonic_ :: LitString -> Doc @@ -1008,164 +1006,164 @@ pprMnemonic name size = char '\t' <> ptext name <> pprSize size <> space -pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc -pprSizeImmOp name size imm op1 +pprSizeImmOp :: Platform -> LitString -> Size -> Imm -> Operand -> Doc +pprSizeImmOp platform name size imm op1 = hcat [ pprMnemonic name size, char '$', pprImm imm, comma, - pprOperand size op1 + pprOperand platform size op1 ] -pprSizeOp :: LitString -> Size -> Operand -> Doc -pprSizeOp name size op1 +pprSizeOp :: Platform -> LitString -> Size -> Operand -> Doc +pprSizeOp platform name size op1 = hcat [ pprMnemonic name size, - pprOperand size op1 + pprOperand platform size op1 ] -pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprSizeOpOp name size op1 op2 +pprSizeOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprSizeOpOp platform name size op1 op2 = hcat [ pprMnemonic name size, - pprOperand size op1, + pprOperand platform size op1, comma, - pprOperand size op2 + pprOperand platform size op2 ] -pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprOpOp name size op1 op2 +pprOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprOpOp platform name size op1 op2 = hcat [ pprMnemonic_ name, - pprOperand size op1, + pprOperand platform size op1, comma, - pprOperand size op2 + pprOperand platform size op2 ] -pprSizeReg :: LitString -> Size -> Reg -> Doc -pprSizeReg name size reg1 +pprSizeReg :: Platform -> LitString -> Size -> Reg -> Doc +pprSizeReg platform name size reg1 = hcat [ pprMnemonic name size, - pprReg size reg1 + pprReg platform size reg1 ] -pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc -pprSizeRegReg name size reg1 reg2 +pprSizeRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg platform name size reg1 reg2 = hcat [ pprMnemonic name size, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprRegReg :: LitString -> Reg -> Reg -> Doc -pprRegReg name reg1 reg2 +pprRegReg :: Platform -> LitString -> Reg -> Reg -> Doc +pprRegReg platform name reg1 reg2 = hcat [ pprMnemonic_ name, - pprReg archWordSize reg1, + pprReg platform archWordSize reg1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc -pprSizeOpReg name size op1 reg2 +pprSizeOpReg :: Platform -> LitString -> Size -> Operand -> Reg -> Doc +pprSizeOpReg platform name size op1 reg2 = hcat [ pprMnemonic name size, - pprOperand size op1, + pprOperand platform size op1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc -pprCondRegReg name size cond reg1 reg2 +pprCondRegReg :: Platform -> LitString -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg platform name size cond reg1 reg2 = hcat [ char '\t', ptext name, pprCond cond, space, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc -pprSizeSizeRegReg name size1 size2 reg1 reg2 +pprSizeSizeRegReg :: Platform -> LitString -> Size -> Size -> Reg -> Reg -> Doc +pprSizeSizeRegReg platform name size1 size2 reg1 reg2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprReg size1 reg1, + pprReg platform size1 reg1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] -pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc -pprSizeSizeOpReg name size1 size2 op1 reg2 +pprSizeSizeOpReg :: Platform -> LitString -> Size -> Size -> Operand -> Reg -> Doc +pprSizeSizeOpReg platform name size1 size2 op1 reg2 = hcat [ pprMnemonic name size2, - pprOperand size1 op1, + pprOperand platform size1 op1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc -pprSizeRegRegReg name size reg1 reg2 reg3 +pprSizeRegRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg platform name size reg1 reg2 reg3 = hcat [ pprMnemonic name size, - pprReg size reg1, + pprReg platform size reg1, comma, - pprReg size reg2, + pprReg platform size reg2, comma, - pprReg size reg3 + pprReg platform size reg3 ] -pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc -pprSizeAddrReg name size op dst +pprSizeAddrReg :: Platform -> LitString -> Size -> AddrMode -> Reg -> Doc +pprSizeAddrReg platform name size op dst = hcat [ pprMnemonic name size, - pprAddr op, + pprAddr platform op, comma, - pprReg size dst + pprReg platform size dst ] -pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc -pprSizeRegAddr name size src op +pprSizeRegAddr :: Platform -> LitString -> Size -> Reg -> AddrMode -> Doc +pprSizeRegAddr platform name size src op = hcat [ pprMnemonic name size, - pprReg size src, + pprReg platform size src, comma, - pprAddr op + pprAddr platform op ] -pprShift :: LitString -> Size -> Operand -> Operand -> Doc -pprShift name size src dest +pprShift :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprShift platform name size src dest = hcat [ pprMnemonic name size, - pprOperand II8 src, -- src is 8-bit sized + pprOperand platform II8 src, -- src is 8-bit sized comma, - pprOperand size dest + pprOperand platform size dest ] -pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc -pprSizeOpOpCoerce name size1 size2 op1 op2 +pprSizeOpOpCoerce :: Platform -> LitString -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce platform name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprOperand size1 op1, + pprOperand platform size1 op1, comma, - pprOperand size2 op2 + pprOperand platform size2 op2 ] diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 140ff57ae9..c09ebc5b15 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -28,20 +28,17 @@ mkVirtualReg u size FF80 -> VirtualRegD u _other -> VirtualRegI u -regDotColor :: RealReg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = let Just str = lookupUFM (regColors platform) reg + in text str -regColors :: UniqFM [Char] -regColors = listToUFM (normalRegColors ++ fpRegColors) +regColors :: Platform -> UniqFM [Char] +regColors platform = listToUFM (normalRegColors platform ++ fpRegColors) --- TODO: We shouldn't be using defaultTargetPlatform here. --- We should be passing DynFlags in instead, and looking at --- its targetPlatform. - -normalRegColors :: [(Reg,String)] -normalRegColors = case platformArch defaultTargetPlatform of +normalRegColors :: Platform -> [(Reg,String)] +normalRegColors platform + = case platformArch platform of ArchX86 -> [ (eax, "#00ff00") , (ebx, "#0000ff") , (ecx, "#00ffff") @@ -61,6 +58,7 @@ normalRegColors = case platformArch defaultTargetPlatform of ArchPPC -> panic "X86 normalRegColors ArchPPC" ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64" ArchSPARC -> panic "X86 normalRegColors ArchSPARC" + ArchARM -> panic "X86 normalRegColors ArchARM" ArchUnknown -> panic "X86 normalRegColors ArchUnknown" fpRegColors :: [(Reg,String)] diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 736ab0967b..fd1e1afa05 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -21,7 +21,7 @@ -- - pragma-end should be only valid in a pragma -- qualified operator NOTES. --- +-- -- - If M.(+) is a single lexeme, then.. -- - Probably (+) should be a single lexeme too, for consistency. -- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. @@ -47,10 +47,10 @@ module Lexer ( Token(..), lexer, pragState, mkPState, PState(..), - P(..), ParseResult(..), getSrcLoc, + P(..), ParseResult(..), getSrcLoc, getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, activeContext, nextIsEOF, getLexState, popLexState, pushLexState, @@ -69,8 +69,8 @@ import UniqFM import DynFlags import Module import Ctype -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) -import Util ( readRational ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) +import Util ( readRational ) import Control.Monad import Data.Bits @@ -108,7 +108,7 @@ $small = [$ascsmall $unismall \_] $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar. $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\'] -$octit = 0-7 +$octit = 0-7 $hexit = [$decdigit A-F a-f] $symchar = [$symbol \:] $nl = [\n\r] @@ -142,7 +142,7 @@ $docsym = [\| \^ \* \$] haskell :- -- everywhere: skip whitespace and comments -$white_no_nl+ ; +$white_no_nl+ ; $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out @@ -159,7 +159,7 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- have to exclude those. -- Since Haddock comments aren't valid in every state, we need to rule them --- out here. +-- out here. -- The following two rules match comments that begin with two dashes, but -- continue with a different character. The rules test that this character @@ -202,53 +202,53 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- as a nested comment. We don't bother with this: if the line begins -- with {-#, then we'll assume it's a pragma we know about and go for do_bol. <bol> { - \n ; - ^\# (line)? { begin line_prag1 } - ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently - ^\# \! .* \n ; -- #!, for scripts - () { do_bol } + \n ; + ^\# (line)? { begin line_prag1 } + ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently + ^\# \! .* \n ; -- #!, for scripts + () { do_bol } } -- after a layout keyword (let, where, do, of), we begin a new layout -- context if the curly brace is missing. -- Careful! This stuff is quite delicate. <layout, layout_do> { - \{ / { notFollowedBy '-' } { hopefully_open_brace } - -- we might encounter {-# here, but {- has been handled already - \n ; - ^\# (line)? { begin line_prag1 } + \{ / { notFollowedBy '-' } { hopefully_open_brace } + -- we might encounter {-# here, but {- has been handled already + \n ; + ^\# (line)? { begin line_prag1 } } -- do is treated in a subtly different way, see new_layout_context -<layout> () { new_layout_context True } -<layout_do> () { new_layout_context False } +<layout> () { new_layout_context True } +<layout_do> () { new_layout_context False } -- after a new layout context which was found to be to the left of the -- previous context, we have generated a '{' token, and we now need to -- generate a matching '}' token. -<layout_left> () { do_layout_left } +<layout_left> () { do_layout_left } -<0,option_prags> \n { begin bol } +<0,option_prags> \n { begin bol } "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } { dispatch_pragmas linePrags } -- single-line line pragmas, of the form -- # <line> "<file>" <extra-stuff> \n -<line_prag1> $decdigit+ { setLine line_prag1a } -<line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b } -<line_prag1b> .* { pop } +<line_prag1> $decdigit+ { setLine line_prag1a } +<line_prag1a> \" [$graphic \ ]* \" { setFile line_prag1b } +<line_prag1b> .* { pop } -- Haskell-style line pragmas, of the form -- {-# LINE <line> "<file>" #-} -<line_prag2> $decdigit+ { setLine line_prag2a } -<line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b } -<line_prag2b> "#-}"|"-}" { pop } +<line_prag2> $decdigit+ { setLine line_prag2a } +<line_prag2a> \" [$graphic \ ]* \" { setFile line_prag2b } +<line_prag2b> "#-}"|"-}" { pop } -- NOTE: accept -} at the end of a LINE pragma, for compatibility -- with older versions of GHC which generated these. <0,option_prags> { - "{-#" $whitechar* $pragmachar+ + "{-#" $whitechar* $pragmachar+ $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } { dispatch_pragmas twoWordPrags } @@ -260,14 +260,14 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } { dispatch_pragmas ignoredPrags } -- ToDo: should only be valid inside a pragma: - "#-}" { endPrag } + "#-}" { endPrag } } <option_prags> { "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } { dispatch_pragmas fileHeaderPrags } - "-- #" { multiline_doc_comment } + "-- #" { multiline_doc_comment } } <0> { @@ -297,19 +297,19 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- "special" symbols <0> { - "[:" / { ifExtension parrEnabled } { token ITopabrack } - ":]" / { ifExtension parrEnabled } { token ITcpabrack } + "[:" / { ifExtension parrEnabled } { token ITopabrack } + ":]" / { ifExtension parrEnabled } { token ITcpabrack } } - + <0> { - "[|" / { ifExtension thEnabled } { token ITopenExpQuote } - "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } - "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } - "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } - "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } - "|]" / { ifExtension thEnabled } { token ITcloseQuote } - \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } - "$(" / { ifExtension thEnabled } { token ITparenEscape } + "[|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } + "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } + "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } + "|]" / { ifExtension thEnabled } { token ITcloseQuote } + \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } + "$(" / { ifExtension thEnabled } { token ITparenEscape } -- For backward compatibility, accept the old dollar syntax "[$" @varid "|" / { ifExtension qqEnabled } @@ -321,12 +321,12 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } <0> { "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol } - { special IToparenbar } + { special IToparenbar } "|)" / { ifExtension arrowsEnabled } { special ITcparenbar } } <0> { - \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } + \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } <0> { @@ -337,23 +337,23 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } } <0,option_prags> { - \( { special IToparen } - \) { special ITcparen } - \[ { special ITobrack } - \] { special ITcbrack } - \, { special ITcomma } - \; { special ITsemi } - \` { special ITbackquote } - - \{ { open_brace } - \} { close_brace } + \( { special IToparen } + \) { special ITcparen } + \[ { special ITobrack } + \] { special ITcbrack } + \, { special ITcomma } + \; { special ITsemi } + \` { special ITbackquote } + + \{ { open_brace } + \} { close_brace } } <0,option_prags> { - @qual @varid { idtoken qvarid } - @qual @conid { idtoken qconid } - @varid { varid } - @conid { idtoken conid } + @qual @varid { idtoken qvarid } + @qual @conid { idtoken qconid } + @varid { varid } + @conid { idtoken conid } } <0> { @@ -410,8 +410,8 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- lexer, we would still have to parse the string afterward in order -- to convert it to a String. <0> { - \' { lex_char_tok } - \" { lex_string_tok } + \' { lex_char_tok } + \" { lex_string_tok } } { @@ -419,7 +419,7 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- The token type data Token - = ITas -- Haskell keywords + = ITas -- Haskell keywords | ITcase | ITclass | ITdata @@ -443,15 +443,14 @@ data Token | ITthen | ITtype | ITwhere - | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) + | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) - | ITforall -- GHC extension keywords + | ITforall -- GHC extension keywords | ITforeign | ITexport | ITlabel | ITdynamic | ITsafe - | ITthreadsafe | ITinterruptible | ITunsafe | ITstdcallconv @@ -463,10 +462,10 @@ data Token | ITby | ITusing - -- Pragmas + -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo - | ITspec_prag -- SPECIALISE - | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) + | ITspec_prag -- SPECIALISE + | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag | ITrules_prag | ITwarning_prag @@ -485,7 +484,7 @@ data Token | ITvect_scalar_prag | ITnovect_prag - | ITdotdot -- reserved symbols + | ITdotdot -- reserved symbols | ITcolon | ITdcolon | ITequal @@ -501,17 +500,17 @@ data Token | ITstar | ITdot - | ITbiglam -- GHC-extension symbols + | ITbiglam -- GHC-extension symbols - | ITocurly -- special symbols + | ITocurly -- special symbols | ITccurly | ITocurlybar -- {|, for type applications | ITccurlybar -- |}, for type applications | ITvocurly | ITvccurly | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParallelArrays - | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen @@ -522,7 +521,7 @@ data Token | ITunderscore | ITbackquote - | ITvarid FastString -- identifiers + | ITvarid FastString -- identifiers | ITconid FastString | ITvarsym FastString | ITconsym FastString @@ -533,7 +532,7 @@ data Token | ITprefixqvarsym (FastString,FastString) | ITprefixqconsym (FastString,FastString) - | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITdupipvarid FastString -- GHC extension: implicit param: ?x | ITchar Char | ITstring FastString @@ -548,29 +547,29 @@ data Token | ITprimdouble FractionalLit -- Template Haskell extension tokens - | ITopenExpQuote -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote -- |] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITvarQuote -- ' - | ITtyQuote -- '' + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITvarQuote -- ' + | ITtyQuote -- '' | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc | ITrec - | IToparenbar -- (| - | ITcparenbar -- |) - | ITlarrowtail -- -< - | ITrarrowtail -- >- - | ITLarrowtail -- -<< - | ITRarrowtail -- >>- + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- - | ITunknown String -- Used when the lexer can't make sense of it - | ITeof -- end of file token + | ITunknown String -- Used when the lexer can't make sense of it + | ITeof -- end of file token -- Documentation annotations | ITdocCommentNext String -- something beginning '-- |' @@ -586,33 +585,6 @@ data Token deriving Show -- debugging #endif -{- -isSpecial :: Token -> Bool --- If we see M.x, where x is a keyword, but --- is special, we treat is as just plain M.x, --- not as a keyword. -isSpecial ITas = True -isSpecial IThiding = True -isSpecial ITqualified = True -isSpecial ITforall = True -isSpecial ITexport = True -isSpecial ITlabel = True -isSpecial ITdynamic = True -isSpecial ITsafe = True -isSpecial ITthreadsafe = True -isSpecial ITinterruptible = True -isSpecial ITunsafe = True -isSpecial ITccallconv = True -isSpecial ITstdcallconv = True -isSpecial ITprimcallconv = True -isSpecial ITmdo = True -isSpecial ITfamily = True -isSpecial ITgroup = True -isSpecial ITby = True -isSpecial ITusing = True -isSpecial _ = False --} - -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the @@ -622,55 +594,56 @@ isSpecial _ = False -- reservedWordsFM :: UniqFM (Token, Int) reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - ( "_scc_", ITscc, 0 ), -- ToDo: remove - - ( "forall", ITforall, bit explicitForallBit .|. bit inRulePragBit), - ( "mdo", ITmdo, bit recursiveDoBit), - ( "family", ITfamily, bit tyFamBit), - ( "group", ITgroup, bit transformComprehensionsBit), - ( "by", ITby, bit transformComprehensionsBit), - ( "using", ITusing, bit transformComprehensionsBit), - - ( "foreign", ITforeign, bit ffiBit), - ( "export", ITexport, bit ffiBit), - ( "label", ITlabel, bit ffiBit), - ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit .|. bit safeHaskellBit), - ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove - ( "interruptible", ITinterruptible, bit ffiBit), - ( "unsafe", ITunsafe, bit ffiBit), - ( "stdcall", ITstdcallconv, bit ffiBit), - ( "ccall", ITccallconv, bit ffiBit), - ( "prim", ITprimcallconv, bit ffiBit), - - ( "rec", ITrec, bit recBit), - ( "proc", ITproc, bit arrowsBit) + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + ( "_scc_", ITscc, 0 ), -- ToDo: remove + + ( "forall", ITforall, bit explicitForallBit .|. + bit inRulePragBit), + ( "mdo", ITmdo, bit recursiveDoBit), + ( "family", ITfamily, bit tyFamBit), + ( "group", ITgroup, bit transformComprehensionsBit), + ( "by", ITby, bit transformComprehensionsBit), + ( "using", ITusing, bit transformComprehensionsBit), + + ( "foreign", ITforeign, bit ffiBit), + ( "export", ITexport, bit ffiBit), + ( "label", ITlabel, bit ffiBit), + ( "dynamic", ITdynamic, bit ffiBit), + ( "safe", ITsafe, bit ffiBit .|. + bit safeHaskellBit), + ( "interruptible", ITinterruptible, bit interruptibleFfiBit), + ( "unsafe", ITunsafe, bit ffiBit), + ( "stdcall", ITstdcallconv, bit ffiBit), + ( "ccall", ITccallconv, bit ffiBit), + ( "prim", ITprimcallconv, bit ffiBit), + + ( "rec", ITrec, bit recBit), + ( "proc", ITproc, bit arrowsBit) ] reservedSymsFM :: UniqFM (Token, Int -> Bool) @@ -736,16 +709,16 @@ idtoken :: (StringBuffer -> Int -> Token) -> Action idtoken f span buf len = return (L span $! (f buf len)) skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len +skip_one_varid f span buf len = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) strtoken :: (String -> Token) -> Action -strtoken f span buf len = +strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) init_strtoken :: Int -> (String -> Token) -> Action -- like strtoken, but drops the last N character(s) -init_strtoken drop f span buf len = +init_strtoken drop f span buf len = return (L span $! (f $! lexemeToString buf (len-drop))) begin :: Int -> Action @@ -777,7 +750,7 @@ nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool nextCharIs buf p = not (atEnd buf) && p (currentChar buf) notFollowedBy :: Char -> AlexAccPred Int -notFollowedBy char _ _ _ (AI _ buf) +notFollowedBy char _ _ _ (AI _ buf) = nextCharIs buf (/=char) notFollowedBySymbol :: AlexAccPred Int @@ -800,11 +773,6 @@ isNormalComment bits _ _ (AI _ buf) spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) -{- -haddockDisabledAnd p bits _ _ (AI _ buf) - = if haddockEnabled bits then False else (p buf) --} - atEOL :: AlexAccPred Int atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' @@ -815,14 +783,14 @@ multiline_doc_comment :: Action multiline_doc_comment span buf _len = withLexedDocType (worker "") where worker commentAcc input docType oneLine = case alexGetChar input of - Just ('\n', input') + Just ('\n', input') | oneLine -> docCommentEnd input commentAcc docType buf span | otherwise -> case checkIfCommentLine input' of Just input -> worker ('\n':commentAcc) input docType False Nothing -> docCommentEnd input commentAcc docType buf span Just (c, input) -> worker (c:commentAcc) input docType oneLine Nothing -> docCommentEnd input commentAcc docType buf span - + checkIfCommentLine input = check (dropNonNewlineSpace input) where check input = case alexGetChar input of @@ -834,7 +802,7 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") _ -> Nothing dropNonNewlineSpace input = case alexGetChar input of - Just (c, input') + Just (c, input') | isSpace c && c /= '\n' -> dropNonNewlineSpace input' | otherwise -> input Nothing -> input @@ -900,8 +868,8 @@ withLexedDocType lexDocComment = do '*' -> lexDocSection 1 input '#' -> lexDocComment input ITdocOptionsOld False _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar input of + where + lexDocSection n input = case alexGetChar input of Just ('*', input) -> lexDocSection (n+1) input Just (_, _) -> lexDocComment input (ITdocSection n) True Nothing -> do setInput input; lexToken -- eof reached, lex it normally @@ -922,31 +890,31 @@ endPrag span _buf _len = do ------------------------------------------------------------------------------- -- This function is quite tricky. We can't just return a new token, we also -- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- than what was lexed by Alex, and the lexToken function doesn't know this, so -- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. +-- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - RealSrcSpan -> P (RealLocated Token) + RealSrcSpan -> P (RealLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc span' = mkRealSrcSpan (realSrcSpanStart span) loc last_len = byteDiff buf nextBuf - + span `seq` setLastToken span' last_len return (L span' (docType comment)) - + errBrace :: AlexInput -> RealSrcSpan -> P a errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action -open_brace span _str _len = do +open_brace span _str _len = do ctx <- getContext setContext (NoLayout:ctx) return (L span ITocurly) -close_brace span _str _len = do +close_brace span _str _len = do popContext return (L span ITccurly) @@ -961,44 +929,44 @@ splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) splitQualName orig_buf len parens = split orig_buf orig_buf where split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf where (c,buf') = nextChar buf - + -- careful, we might get names like M.... -- so, if the character after the dot is not upper-case, this is -- the end of the qualifier part. found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf + | isUpper c = split buf' buf + | otherwise = done buf where (c,buf') = nextChar buf done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) else lexemeToFastString dot_buf (len - qual_size)) where - qual_size = orig_buf `byteDiff` dot_buf + qual_size = orig_buf `byteDiff` dot_buf varid :: Action varid span buf len = fs `seq` case lookupUFM reservedWordsFM fs of - Just (keyword,0) -> do - maybe_layout keyword - return (L span keyword) - Just (keyword,exts) -> do - b <- extension (\i -> exts .&. i /= 0) - if b then do maybe_layout keyword - return (L span keyword) - else return (L span (ITvarid fs)) - _other -> return (L span (ITvarid fs)) + Just (keyword,0) -> do + maybe_layout keyword + return (L span keyword) + Just (keyword,exts) -> do + b <- extension (\i -> exts .&. i /= 0) + if b then do maybe_layout keyword + return (L span keyword) + else return (L span (ITvarid fs)) + _other -> return (L span (ITvarid fs)) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len conid :: StringBuffer -> Int -> Token conid buf len = ITconid fs @@ -1016,25 +984,25 @@ consym = sym ITconsym sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) -sym con span buf len = +sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword,exts) -> do - b <- extension exts - if b then return (L span keyword) - else return (L span $! con fs) - _other -> return (L span $! con fs) + Just (keyword,exts) -> do + b <- extension exts + if b then return (L span keyword) + else return (L span $! con fs) + _other -> return (L span $! con fs) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len -- Variations on the integral numeric literal. tok_integral :: (Integer -> Token) - -> (Integer -> Integer) - -- -> (StringBuffer -> StringBuffer) -> (Int -> Int) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = - return $ L span $ itint $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len + = return $ L span $ itint $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int -- some conveniences for use with tok_integral tok_num :: (Integer -> Integer) @@ -1071,20 +1039,20 @@ readFractionalLit str = (FL $! str) $! readRational str -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action do_bol span _str _len = do - pos <- getOffside - case pos of - LT -> do + pos <- getOffside + case pos of + LT -> do --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ -> do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ -> do --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - GT -> do - _ <- popLexState - lexToken + _ <- popLexState + return (L span ITsemi) + GT -> do + _ <- popLexState + lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. @@ -1124,16 +1092,16 @@ new_layout_context strict span _buf _len = do nondecreasing <- extension nondecreasingIndentation let strict' = strict || not nondecreasing case ctx of - Layout prev_off : _ | - (strict' && prev_off >= offset || - not strict' && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span ITvocurly) - _ -> do - setContext (Layout offset : ctx) - return (L span ITvocurly) + Layout prev_off : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span ITvocurly) + _ -> do + setContext (Layout offset : ctx) + return (L span ITvocurly) do_layout_left :: Action do_layout_left span _buf _len = do @@ -1148,7 +1116,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line + -- subtract one: the line number refers to the *following* line _ <- popLexState pushLexState code lexToken @@ -1201,7 +1169,7 @@ lex_string_prag mkTok span _buf _len lex_string_tok :: Action lex_string_tok span _buf _len = do tok <- lex_string "" - end <- getSrcLoc + end <- getSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok) lex_string :: String -> P Token @@ -1211,32 +1179,32 @@ lex_string s = do Nothing -> lit_error i Just ('"',i) -> do - setInput i - magicHash <- extension magicHashEnabled - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - if any (> '\xFF') s + setInput i + magicHash <- extension magicHashEnabled + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" else let s' = mkZFastString (reverse s) in - return (ITprimstring s') - -- mkZFastString is a hack to avoid encoding the - -- string in UTF-8. We just want the exact bytes. - _other -> - return (ITstring (mkFastString (reverse s))) - else - return (ITstring (mkFastString (reverse s))) + return (ITprimstring s') + -- mkZFastString is a hack to avoid encoding the + -- string in UTF-8. We just want the exact bytes. + _other -> + return (ITstring (mkFastString (reverse s))) + else + return (ITstring (mkFastString (reverse s))) Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do -- is_space only works for <= '\x7f' (#3751) - setInput i; lex_stringgap s - where next = alexGetChar' i + setInput i; lex_stringgap s + where next = alexGetChar' i Just (c, i1) -> do case c of @@ -1257,172 +1225,172 @@ lex_stringgap s = do lex_char_tok :: Action -- Here we are basically parsing character literals, such as 'x' or '\n' -- but, when Template Haskell is on, we additionally spot --- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, +-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, -- but WITHOUT CONSUMING the x or T part (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote -lex_char_tok span _buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character +lex_char_tok span _buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character let loc = realSrcSpanStart span case alexGetChar' i1 of - Nothing -> lit_error i1 - - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - th_exts <- extension thEnabled - if th_exts then do - setInput i2 - return (L (mkRealSrcSpan loc end2) ITtyQuote) - else lit_error i1 - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape + Nothing -> lit_error i1 + + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + th_exts <- extension thEnabled + if th_exts then do + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + else lit_error i1 + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok loc lit_ch - else lit_error i3 + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok loc lit_ch + else lit_error i3 Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> - - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- If TH is on, just parse the quote only - th_exts <- extension thEnabled - let (AI end _) = i1 - if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) - else lit_error i2 + | not (isAny c) -> lit_error i1 + | otherwise -> + + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- If TH is on, just parse the quote only + th_exts <- extension thEnabled + let (AI end _) = i1 + if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) + else lit_error i2 finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token) -finish_char_tok loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- extension magicHashEnabled - i@(AI end _) <- getInput - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkRealSrcSpan loc end) (ITprimchar ch)) - _other -> - return (L (mkRealSrcSpan loc end) (ITchar ch)) - else do - return (L (mkRealSrcSpan loc end) (ITchar ch)) +finish_char_tok loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- extension magicHashEnabled + i@(AI end _) <- getInput + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) (ITprimchar ch)) + _other -> + return (L (mkRealSrcSpan loc end) (ITchar ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c + | otherwise = is_any c lex_escape :: P Char lex_escape = do i0 <- getInput c <- getCharOrFail i0 case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do input <- getInput read i input where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do + case alexGetChar' input of + Just (c,input') | is_digit c -> do let i' = i*base + conv c if i' > 0x10ffff then setInput input >> lexError "numeric escape sequence out of range" else read i' input' - _other -> do + _other -> do setInput input; return (chr i) silly_escape_chars :: [(String, Char)] silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] -- before calling lit_error, ensure that the current input is pointing to -- the position of the error in the buffer. This is so that we can report @@ -1434,8 +1402,8 @@ lit_error i = do setInput i; lexError "lexical error in string/character literal getCharOrFail :: AlexInput -> P Char getCharOrFail i = do case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c -- ----------------------------------------------------------------------------- -- QuasiQuote @@ -1443,11 +1411,11 @@ getCharOrFail i = do lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getSrcLoc quote <- lex_quasiquote "" - end <- getSrcLoc + end <- getSrcLoc return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), @@ -1460,29 +1428,29 @@ lex_quasiquote s = do Nothing -> lit_error i Just ('\\',i) - | Just ('|',i) <- next -> do - setInput i; lex_quasiquote ('|' : s) - | Just (']',i) <- next -> do - setInput i; lex_quasiquote (']' : s) - where next = alexGetChar' i + | Just ('|',i) <- next -> do + setInput i; lex_quasiquote ('|' : s) + | Just (']',i) <- next -> do + setInput i; lex_quasiquote (']' : s) + where next = alexGetChar' i Just ('|',i) - | Just (']',i) <- next -> do - setInput i; return s - where next = alexGetChar' i + | Just (']',i) <- next -> do + setInput i; return s + where next = alexGetChar' i Just (c, i) -> do - setInput i; lex_quasiquote (c : s) + setInput i; lex_quasiquote (c : s) -- ----------------------------------------------------------------------------- -- Warnings -warn :: DynFlag -> SDoc -> Action +warn :: WarningFlag -> SDoc -> Action warn option warning srcspan _buf _len = do addWarning option (RealSrcSpan srcspan) warning lexToken -warnThen :: DynFlag -> SDoc -> Action -> Action +warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do addWarning option (RealSrcSpan srcspan) warning action srcspan buf len @@ -1497,22 +1465,23 @@ data LayoutContext data ParseResult a = POk PState a - | PFailed - SrcSpan -- The start and end of the text span related to - -- the error. Might be used in environments which can - -- show this span, e.g. by highlighting it. - Message -- The error message - -data PState = PState { - buffer :: StringBuffer, + | PFailed + SrcSpan -- The start and end of the text span related to + -- the error. Might be used in environments which can + -- show this span, e.g. by highlighting it. + Message -- The error message + +data PState = PState { + buffer :: StringBuffer, dflags :: DynFlags, messages :: Messages, - last_loc :: RealSrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: RealSrcLoc, -- current loc (end of prev token + 1) - extsBitmap :: !Int, -- bitmap that determines permitted extensions - context :: [LayoutContext], - lex_state :: [Int], + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + extsBitmap :: !Int, -- bitmap that determines permitted + -- extensions + context :: [LayoutContext], + lex_state :: [Int], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: @@ -1532,11 +1501,11 @@ data PState = PState { -- token doesn't need to close anything: alr_justClosedExplicitLetBlock :: Bool } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} @@ -1558,9 +1527,9 @@ returnP a = a `seq` (P $ \s -> POk s a) thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed span err -> PFailed span err + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err failP :: String -> P a failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) @@ -1582,8 +1551,8 @@ getDynFlags = P $ \s -> POk s (dflags s) withThisPackage :: (PackageId -> a) -> P a withThisPackage f - = do pkg <- liftM thisPackage getDynFlags - return $ f pkg + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1601,8 +1570,8 @@ getSrcLoc :: P RealSrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc setLastToken :: RealSrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, last_len=len } () @@ -1612,63 +1581,63 @@ alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI _ buf) = prevChar buf '\n' alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI loc s) +alexGetChar (AI loc s) | atEnd s = Nothing - | otherwise = adj_c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (adj_c, (AI loc' s')) + | otherwise = adj_c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (adj_c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - non_graphic = '\x0' - upper = '\x1' - lower = '\x2' - digit = '\x3' - symbol = '\x4' - space = '\x5' - other_graphic = '\x6' - - adj_c - | c <= '\x06' = non_graphic - | c <= '\x7f' = c + non_graphic = '\x0' + upper = '\x1' + lower = '\x2' + digit = '\x3' + symbol = '\x4' + space = '\x5' + other_graphic = '\x6' + + adj_c + | c <= '\x06' = non_graphic + | c <= '\x7f' = c -- Alex doesn't handle Unicode, so when Unicode -- character is encountered we output these values -- with the actual character value hidden in the state. - | otherwise = - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> other_graphic - OtherLetter -> lower -- see #1103 - NonSpacingMark -> other_graphic - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic + | otherwise = + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> other_graphic + OtherLetter -> lower -- see #1103 + NonSpacingMark -> other_graphic + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic OtherNumber -> digit -- see #4373 - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) +alexGetChar' (AI loc s) | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c @@ -1753,30 +1722,28 @@ setAlrExpectingOCurly :: Maybe ALRLayout -> P () setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed --- integer - --- The "genericsBit" is now unused, available for others --- genericsBit :: Int --- genericsBit = 0 -- {|, |} and "generic" +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap +-- stored in an unboxed Int ffiBit :: Int -ffiBit = 1 +ffiBit= 0 +interruptibleFfiBit :: Int +interruptibleFfiBit = 1 parrBit :: Int -parrBit = 2 +parrBit = 3 arrowsBit :: Int arrowsBit = 4 thBit :: Int -thBit = 5 +thBit = 5 ipBit :: Int -ipBit = 6 +ipBit = 6 explicitForallBit :: Int explicitForallBit = 7 -- the 'forall' keyword and '.' symbol bangPatBit :: Int -bangPatBit = 8 -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) +bangPatBit = 8 -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) tyFamBit :: Int -tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs +tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs haddockBit :: Int haddockBit = 10 -- Lex and parse Haddock comments magicHashBit :: Int @@ -1794,7 +1761,7 @@ datatypeContextsBit = 16 transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int -qqBit = 18 -- enable quasiquoting +qqBit = 18 -- enable quasiquoting inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int @@ -1880,41 +1847,42 @@ mkPState flags buf loc = alr_justClosedExplicitLetBlock = False } where - bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags - .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags - .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags - .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags + bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags + .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags + .|. haddockBit `setBitIf` dopt Opt_Haddock flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags + .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags + .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags - .|. safeHaskellBit `setBitIf` safeHaskellOn flags + .|. safeHaskellBit `setBitIf` safeHaskellOn flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b | otherwise = 0 -addWarning :: DynFlag -> SrcSpan -> SDoc -> P () +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=(ws,es), dflags=d} -> let warning' = mkWarnMsg srcspan alwaysQualify warning - ws' = if dopt option d then ws `snocBag` warning' else ws + ws' = if wopt option d then ws `snocBag` warning' else ws in POk s{messages=(ws', es)} () getMessages :: PState -> Messages @@ -1927,40 +1895,40 @@ setContext :: [LayoutContext] -> P () setContext ctx = P $ \s -> POk s{context=ctx} () popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, context = ctx, +popContext = P $ \ s@(PState{ buffer = buf, context = ctx, last_len = len, last_loc = last_loc }) -> case ctx of - (_:tl) -> POk s{ context = tl } () - [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) + (_:tl) -> POk s{ context = tl } () + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- Push a new layout context at the indentation of the last token read. -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> POk s{context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: P Ordering getOffside = P $ \s@PState{last_loc=loc, context=stk} -> let offs = srcSpanStartCol loc in - let ord = case stk of - (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + let ord = case stk of + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ compare offs n - _ -> GT - in POk s ord + _ -> GT + in POk s ord -- --------------------------------------------------------------------------- -- Construct a parse error srcParseErr - :: StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token + :: StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token -> Message srcParseErr buf len - = hcat [ if null token - then ptext (sLit "parse error (possibly incorrect indentation)") - else hcat [ptext (sLit "parse error on input "), - char '`', text token, char '\''] + = hcat [ if null token + then ptext (sLit "parse error (possibly incorrect indentation)") + else hcat [ptext (sLit "parse error on input "), + char '`', text token, char '\''] ] where token = lexemeToString (offsetBytes (-len) buf) len @@ -1968,8 +1936,8 @@ srcParseErr buf len -- the location of the error. This is the entry point for errors -- detected during parsing. srcParseFail :: P a -srcParseFail = P $ \PState{ buffer = buf, last_len = len, - last_loc = last_loc } -> +srcParseFail = P $ \PState{ buffer = buf, last_len = len, + last_loc = last_loc } -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- A lexical error is reported at a particular position in the source file, @@ -2238,12 +2206,10 @@ reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") | otherwise = - let - c = fst (nextChar buf) - in - if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState @@ -2274,7 +2240,7 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("inline", token (ITinline_prag Inline FunLike)), ("inlinable", token (ITinline_prag Inlinable FunLike)), ("inlineable", token (ITinline_prag Inlinable FunLike)), - -- Spelling variant + -- Spelling variant ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index bb82aaa2d1..d199fb534f 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -238,7 +238,6 @@ incorrect. 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } - 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias 'interruptible' { L _ ITinterruptible } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } @@ -427,14 +426,18 @@ header :: { Located (HsModule RdrName) } {% fileSrcSpan >>= \ loc -> return (L loc (HsModule (Just $3) $5 $7 [] $4 $1 ))} - | missing_module_keyword importdecls + | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $2 [] Nothing + return (L loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl RdrName] } : '{' importdecls { $2 } - | vocurly importdecls { $2 } + | vocurly importdecls { $2 } + +header_body2 :: { [LImportDecl RdrName] } + : '{' importdecls { $2 } + | missing_module_keyword importdecls { $2 } ----------------------------------------------------------------------------- -- The Export List @@ -890,7 +893,7 @@ fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.LL } | 'import' callconv fspec - {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3); + {% do { d <- mkImport $2 PlaySafe (unLoc $3); return (LL d) } } | 'export' callconv fspec {% mkExport $2 (unLoc $3) >>= return.LL } @@ -902,9 +905,8 @@ callconv :: { CCallConv } safety :: { Safety } : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe False } + | 'safe' { PlaySafe } | 'interruptible' { PlayInterruptible } - | 'threadsafe' { PlaySafe True } -- deprecated alias fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -1435,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 @@ -1804,7 +1806,6 @@ tyvarid :: { Located RdrName } | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } - | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } tyvarsym :: { Located RdrName } -- Does not include "!", because that is used for strictness marks @@ -1838,7 +1839,6 @@ varid :: { Located RdrName } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") } - | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 3f2b32a8b3..c99fcb6695 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -279,7 +279,7 @@ exp :: { IfaceExpr } -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2) Nothing) - CCallConv (PlaySafe False))) + CCallConv PlaySafe)) $3 } alts1 :: { [IfaceAlt] } diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 87bb94a148..ac19974976 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -62,10 +62,6 @@ data Safety -- by a separate OS thread, i.e., _concurrently_ to the -- execution of other Haskell threads. - Bool -- Indicates the deprecated "threadsafe" annotation - -- which is now an alias for "safe". This information - -- is never used except to emit a deprecation warning. - | PlayInterruptible -- Like PlaySafe, but additionally -- the worker thread running this foreign call may -- be unceremoniously killed, so it must be scheduled @@ -78,15 +74,14 @@ data Safety {-! derive: Binary !-} instance Outputable Safety where - ppr (PlaySafe False) = ptext (sLit "safe") - ppr (PlaySafe True) = ptext (sLit "threadsafe") + ppr PlaySafe = ptext (sLit "safe") ppr PlayInterruptible = ptext (sLit "interruptible") ppr PlayRisky = ptext (sLit "unsafe") playSafe :: Safety -> Bool -playSafe PlaySafe{} = True +playSafe PlaySafe = True playSafe PlayInterruptible = True -playSafe PlayRisky = False +playSafe PlayRisky = False playInterruptible :: Safety -> Bool playInterruptible PlayInterruptible = True @@ -244,9 +239,8 @@ instance Binary ForeignCall where get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where - put_ bh (PlaySafe aa) = do + put_ bh PlaySafe = do putByte bh 0 - put_ bh aa put_ bh PlayInterruptible = do putByte bh 1 put_ bh PlayRisky = do @@ -254,8 +248,7 @@ instance Binary Safety where get bh = do h <- getByte bh case h of - 0 -> do aa <- get bh - return (PlaySafe aa) + 0 -> do return PlaySafe 1 -> do return PlayInterruptible _ -> do return PlayRisky diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 4fd23ee712..c5f123d61c 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,26 +265,26 @@ 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, @@ -282,63 +293,64 @@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, 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, - gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP, 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 = mkIntegerModule (fsLit "GHC.Integer") 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") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +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 @@ -348,13 +360,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") @@ -388,9 +400,9 @@ mkMainModule_ m = mkModule mainPackageId m \end{code} %************************************************************************ -%* * +%* * \subsection{Constructing the names of tuples -%* * +%* * %************************************************************************ \begin{code} @@ -402,16 +414,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") @@ -419,101 +431,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 @@ -533,7 +545,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") @@ -541,15 +553,15 @@ 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, mkTypeRep_RDR, mkTyConRep_RDR :: RdrName -typeOf_RDR = varQual_RDR tYPEABLE (fsLit "typeOf") -mkTypeRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp") -mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon") +typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName +typeOf_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf") +mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon") +mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") @@ -557,13 +569,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, @@ -608,11 +613,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 @@ -624,9 +629,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 @@ -634,7 +639,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} @@ -644,18 +649,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 @@ -688,35 +696,38 @@ 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 +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 @@ -735,12 +746,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 @@ -768,21 +779,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 (fsLit "plusInteger") plusIntegerIdKey +timesIntegerName = varQual gHC_INTEGER (fsLit "timesInteger") timesIntegerIdKey +smallIntegerName = varQual gHC_INTEGER (fsLit "smallInteger") smallIntegerIdKey +integerToWordName = varQual gHC_INTEGER (fsLit "integerToWord") integerToWordIdKey +integerToIntName = varQual gHC_INTEGER (fsLit "integerToInt") integerToIntIdKey +minusIntegerName = varQual gHC_INTEGER (fsLit "minusInteger") minusIntegerIdKey +negateIntegerName = varQual gHC_INTEGER (fsLit "negateInteger") negateIntegerIdKey +eqIntegerName = varQual gHC_INTEGER (fsLit "eqInteger") eqIntegerIdKey +neqIntegerName = varQual gHC_INTEGER (fsLit "neqInteger") neqIntegerIdKey +absIntegerName = varQual gHC_INTEGER (fsLit "absInteger") absIntegerIdKey +signumIntegerName = varQual gHC_INTEGER (fsLit "signumInteger") signumIntegerIdKey +leIntegerName = varQual gHC_INTEGER (fsLit "leInteger") leIntegerIdKey +gtIntegerName = varQual gHC_INTEGER (fsLit "gtInteger") gtIntegerIdKey +ltIntegerName = varQual gHC_INTEGER (fsLit "ltInteger") ltIntegerIdKey +geIntegerName = varQual gHC_INTEGER (fsLit "geInteger") geIntegerIdKey +compareIntegerName = varQual gHC_INTEGER (fsLit "compareInteger") compareIntegerIdKey +gcdIntegerName = varQual gHC_INTEGER (fsLit "gcdInteger") gcdIntegerIdKey +lcmIntegerName = varQual gHC_INTEGER (fsLit "lcmInteger") lcmIntegerIdKey +andIntegerName = varQual gHC_INTEGER (fsLit "andInteger") andIntegerIdKey +orIntegerName = varQual gHC_INTEGER (fsLit "orInteger") orIntegerIdKey +xorIntegerName = varQual gHC_INTEGER (fsLit "xorInteger") xorIntegerIdKey +complementIntegerName = varQual gHC_INTEGER (fsLit "complementInteger") complementIntegerIdKey +shiftLIntegerName = varQual gHC_INTEGER (fsLit "shiftLInteger") shiftLIntegerIdKey +shiftRIntegerName = varQual gHC_INTEGER (fsLit "shiftRInteger") shiftRIntegerIdKey -- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, @@ -790,9 +830,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 @@ -815,19 +855,19 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey typeableClassName, typeable1ClassName, typeable2ClassName, typeable3ClassName, typeable4ClassName, typeable5ClassName, typeable6ClassName, typeable7ClassName :: Name -typeableClassName = clsQual tYPEABLE (fsLit "Typeable") typeableClassKey -typeable1ClassName = clsQual tYPEABLE (fsLit "Typeable1") typeable1ClassKey -typeable2ClassName = clsQual tYPEABLE (fsLit "Typeable2") typeable2ClassKey -typeable3ClassName = clsQual tYPEABLE (fsLit "Typeable3") typeable3ClassKey -typeable4ClassName = clsQual tYPEABLE (fsLit "Typeable4") typeable4ClassKey -typeable5ClassName = clsQual tYPEABLE (fsLit "Typeable5") typeable5ClassKey -typeable6ClassName = clsQual tYPEABLE (fsLit "Typeable6") typeable6ClassKey -typeable7ClassName = clsQual tYPEABLE (fsLit "Typeable7") typeable7ClassKey +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeable1ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable1") typeable1ClassKey +typeable2ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable2") typeable2ClassKey +typeable3ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable3") typeable3ClassKey +typeable4ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable4") typeable4ClassKey +typeable5ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable5") typeable5ClassKey +typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6ClassKey +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 @@ -835,31 +875,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, @@ -894,16 +934,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 @@ -924,8 +964,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 @@ -934,21 +974,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 @@ -972,9 +1012,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 @@ -991,9 +1031,9 @@ pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey \end{code} %************************************************************************ -%* * +%* * \subsection{Local helpers} -%* * +%* * %************************************************************************ All these are original names; hence mkOrig @@ -1005,7 +1045,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 @@ -1018,9 +1058,9 @@ methName modu occ unique \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} -%* * +%* * %************************************************************************ --MetaHaskell extension hand allocate keys here @@ -1029,51 +1069,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 @@ -1086,9 +1126,9 @@ selectorClassKey = mkPreludeClassUnique 41 \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} -%* * +%* * %************************************************************************ \begin{code} @@ -1102,39 +1142,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, @@ -1143,42 +1183,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 @@ -1213,14 +1253,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, @@ -1258,7 +1298,7 @@ repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 ---------------- Template Haskell ------------------- --- USES TyConUniques 200-299 +-- USES TyConUniques 200-299 ----------------------------------------------------- unitTyConKey :: Unique @@ -1266,9 +1306,9 @@ unitTyConKey = mkTupleTyConUnique Boxed 0 \end{code} %************************************************************************ -%* * +%* * \subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} -%* * +%* * %************************************************************************ \begin{code} @@ -1276,169 +1316,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 155 \end{code} @@ -1447,9 +1511,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, @@ -1457,93 +1521,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@ @@ -1553,37 +1608,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 93cc576a81..f86e6a4a29 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -24,9 +24,10 @@ import Id import Literal import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn +import TysPrim import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr ) +import CoreUtils ( cheapEqExpr, exprIsHNF ) import CoreUnfold ( exprIsConApp_maybe ) import Type import OccName ( occNameFS ) @@ -37,6 +38,7 @@ import Outputable import FastString import StaticFlags ( opt_SimplExcessPrecision ) import Constants +import BasicTypes import Data.Bits as Bits import Data.Int ( Int64 ) @@ -174,9 +176,10 @@ primOpRules op op_name = primop_rule op primop_rule WordEqOp = relop (==) primop_rule WordNeOp = relop (/=) - primop_rule _ = [] - + primop_rule SeqOp = mkBasicRule op_name 4 seqRule + primop_rule SparkOp = mkBasicRule op_name 4 sparkRule + primop_rule _ = [] \end{code} %************************************************************************ @@ -458,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 @@ -540,6 +549,27 @@ dataToTagRule _ _ = Nothing %************************************************************************ %* * +\subsection{Rules for seq# and spark#} +%* * +%************************************************************************ + +\begin{code} +-- seq# :: forall a s . a -> State# s -> (# State# s, a #) +seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a + = Just (mkConApp (tupleCon Unboxed 2) + [Type (mkStatePrimTy ty_s), ty_a, s, a]) +seqRule _ _ = Nothing + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? +\end{code} + +%************************************************************************ +%* * \subsection{Built in rules} %* * %************************************************************************ @@ -580,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 } --------------------------------------------------- @@ -643,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/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index ce2462c99f..49498466e3 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -1650,6 +1650,21 @@ primop ParOp "par#" GenPrimOp has_side_effects = True code_size = { primOpCodeSizeForeignCall } +primop SparkOp "spark#" GenPrimOp + a -> State# s -> (# State# s, a #) + with has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop SeqOp "seq#" GenPrimOp + a -> State# s -> (# State# s, a #) + + -- why return the value? So that we can control sharing of seq'd + -- values: in + -- let x = e in x `seq` ... x ... + -- we don't want to inline x, so better to represent it as + -- let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + -- also it matches the type of rseq in the Eval monad. + primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) with diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 86acfa46b0..2a1330370a 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -702,18 +702,18 @@ renameSig _ (IdSig x) = return (IdSig x) -- Actually this never occurs renameSig mb_names sig@(TypeSig vs ty) = do { new_vs <- mapM (lookupSigOccRn mb_names sig) vs - ; new_ty <- rnHsSigType (quotes (ppr vs)) ty + ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty ; return (TypeSig new_vs new_ty) } renameSig mb_names sig@(GenericSig vs ty) = do { defaultSigs_on <- xoptM Opt_DefaultSignatures ; unless defaultSigs_on (addErr (defaultSigErr sig)) ; new_v <- mapM (lookupSigOccRn mb_names sig) vs - ; new_ty <- rnHsSigType (quotes (ppr vs)) ty + ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty ; return (GenericSig new_v new_ty) } renameSig _ (SpecInstSig ty) - = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty + = do { new_ty <- rnLHsType (text "In a SPECIALISE instance pragma") ty ; return (SpecInstSig new_ty) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids @@ -734,6 +734,9 @@ renameSig mb_names sig@(InlineSig v s) renameSig mb_names sig@(FixSig (FixitySig v f)) = do { new_v <- lookupSigOccRn mb_names sig v ; return (FixSig (FixitySig new_v f)) } + +ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) \end{code} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 58df462532..9374b5ca17 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -11,7 +11,8 @@ module RnEnv ( lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields, + lookupInstDeclBndr, lookupSubBndr, + lookupSubBndrGREs, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -288,32 +289,19 @@ lookupSubBndr parent doc rdr_name = lookupOrig rdr_mod rdr_occ | otherwise -- Find all the things the rdr-name maps to - = do { -- and pick the one with the right parent name - ; env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - ; case pick parent gres of + = do { -- and pick the one with the right parent namep + env <- getGlobalRdrEnv + ; case lookupSubBndrGREs env parent rdr_name of -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope [gre] -> do { addUsedRdrName gre (used_rdr_name gre) ; return (gre_name gre) } [] -> do { addErr (unknownSubordinateErr doc rdr_name) - ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres)) ; return (mkUnboundName rdr_name) } gres -> do { addNameClashErrRn rdr_name gres ; return (gre_name (head gres)) } } where - rdr_occ = rdrNameOcc rdr_name - - pick NoParent gres -- Normal lookup - = pickGREs rdr_name gres - pick (ParentIs p) gres -- Disambiguating lookup - | isUnqual rdr_name = filter (right_parent p) gres - | otherwise = filter (right_parent p) (pickGREs rdr_name gres) - - right_parent p (GRE { gre_par = ParentIs p' }) = p==p' - right_parent _ _ = False - -- Note [Usage for sub-bndrs] used_rdr_name gre | isQual rdr_name = rdr_name @@ -328,7 +316,26 @@ lookupSubBndr parent doc rdr_name = -- Only qualified imports available, so make up -- a suitable qualifed name from the first imp_spec ASSERT( not (null imp_specs) ) - mkRdrQual (is_as (is_decl (head imp_specs))) rdr_occ + mkRdrQual (is_as (is_decl (head imp_specs))) (rdrNameOcc rdr_name) + +lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt] +-- If Parent = NoParent, just do a normal lookup +-- If Parent = Parent p then find all GREs that +-- (a) have parent p +-- (b) for Unqual, are in scope qualified or unqualified +-- for Qual, are in scope with that qualification +lookupSubBndrGREs env parent rdr_name + = case parent of + NoParent -> pickGREs rdr_name gres + ParentIs p + | isUnqual rdr_name -> filter (parent_is p) gres + | otherwise -> filter (parent_is p) (pickGREs rdr_name gres) + + where + gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + + parent_is p (GRE { gre_par = ParentIs p' }) = p == p' + parent_is _ _ = False newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) @@ -980,7 +987,7 @@ checkDupAndShadowedNames envs names ------------------------------------- checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () checkShadowedOccs (global_env,local_env) loc_occs - = ifDOptM Opt_WarnNameShadowing $ + = ifWOptM Opt_WarnNameShadowing $ do { traceRn (text "shadow" <+> ppr loc_occs) ; mapM_ check_shadow loc_occs } where @@ -1214,7 +1221,7 @@ mapFvRnCPS f (x:xs) cont = f x $ \ x' -> \begin{code} warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedTopBinds gres - = ifDOptM Opt_WarnUnusedBinds + = ifWOptM Opt_WarnUnusedBinds $ do isBoot <- tcIsHsBoot let noParent gre = case gre_par gre of NoParent -> True @@ -1230,9 +1237,9 @@ warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM () warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds warnUnusedMatches = check_unused Opt_WarnUnusedMatches -check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () check_unused flag bound_names used_names - = ifDOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) + = ifWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) ------------------------- -- Helpers diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index d841ad8b1f..c6c941c4ca 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -18,7 +18,7 @@ import HsSyn import TcEnv ( isBrackStage ) import RnEnv import RnHsDoc ( rnHsDoc ) -import IfaceEnv ( ifaceExportNames ) +import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad @@ -53,6 +53,55 @@ import qualified Data.Map as Map %* * %************************************************************************ +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependcy +graph. So we can just worry mostly about direct imports. There is one trust +property that can change for a package though without recompliation being +triggered, package trust. So we must check that all packages a module +tranitively depends on to be trusted are still trusted when we are compiling +this module (as due to recompilation avoidance some modules below may not be +considered trusted any more without recompilation being triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +HscMain.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + Note [Trust Transitive Property] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ So there is an interesting design question in regards to transitive trust @@ -64,7 +113,7 @@ requirements from B? Should A now also require that a package p is trusted since B required it? We currently say no but I saying yes also makes sense. The difference is, if a -module M that doesn't use SafeHaskell imports a module N that does, should all +module M that doesn't use Safe Haskell imports a module N that does, should all the trusted package requirements be dropped since M didn't declare that it cares about Safe Haskell (so -XSafe is more strongly associated with the module doing the importing) or should it be done still since the author of the module N that @@ -72,8 +121,8 @@ uses Safe Haskell said they cared (so -XSafe is more strongly associated with the module that was compiled that used it). Going with yes is a simpler semantics we think and harder for the user to stuff -up but it does mean that SafeHaskell will affect users who don't care about -SafeHaskell as they might grab a package from Cabal which uses safe haskell (say +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say network) and that packages imports -XTrustworthy modules from another package (say bytestring), so requires that package is trusted. The user may now get compilation errors in code that doesn't do anything with Safe Haskell simply @@ -81,44 +130,48 @@ because they are using the network package. They will have to call 'ghc-pkg trust network' to get everything working. Due to this invasive nature of going with yes we have gone with no for now. + \begin{code} -rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) +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) implicit_prelude imports + 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 - ifDOptM Opt_WarnImplicitPrelude ( - when (notNull prel_imports) $ addWarn (implicitPreludeWarn) - ) + ifWOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ addWarn (implicitPreludeWarn) stuff1 <- mapM (rnImportDecl this_mod True) prel_imports stuff2 <- mapM (rnImportDecl this_mod False) ordinary stuff3 <- mapM (rnImportDecl this_mod False) source - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2 ++ stuff3) + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = + combine (stuff1 ++ stuff2 ++ stuff3) return (decls, rdr_env, imp_avails, hpc_usage) where - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) - combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails,False) - where plus (decl, gbl_env1, imp_avails1,hpc_usage1) - (decls, gbl_env2, imp_avails2,hpc_usage2) - = (decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1 `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2) + combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) + where + plus (decl, gbl_env1, imp_avails1,hpc_usage1) + (decls, gbl_env2, imp_avails2,hpc_usage2) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1 `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2 ) rnImportDecl :: Module -> Bool -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage) + -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod implicit_prelude (L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg @@ -137,14 +190,14 @@ rnImportDecl this_mod implicit_prelude imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") - -- Check for a missing import list - -- (Opt_WarnMissingImportList also checks for T(..) items - -- but that is done in checkDodgyImport below) + -- Check for a missing import list + -- (Opt_WarnMissingImportList also checks for T(..) items + -- but that is done in checkDodgyImport below) case imp_details of - Just (False, _) -> return () -- Explicit import list + Just (False, _) -> return () -- Explicit import list _ | implicit_prelude -> return () - | qual_only -> return () - | otherwise -> ifDOptM Opt_WarnMissingImportList $ + | qual_only -> return () + | otherwise -> ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg @@ -171,6 +224,8 @@ rnImportDecl this_mod implicit_prelude orph_iface = mi_orphan iface has_finsts = mi_finsts iface deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface filtered_exports = filter not_this_mod (mi_exports iface) not_this_mod (mod,_) = mod /= this_mod @@ -220,7 +275,11 @@ rnImportDecl this_mod implicit_prelude pkg = modulePackageId (mi_module iface) - (dependent_mods, dependent_pkgs) + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) | pkg == thisPackage dflags = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself @@ -233,14 +292,15 @@ rnImportDecl this_mod implicit_prelude -- know if any of them depended on CM.hi-boot, in -- which case we should do the hi-boot consistency -- check. See LoadIface.loadHiBootInterface - ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) + ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps, ptrust) | otherwise = -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)), ppr pkg <+> ppr (dep_pkgs deps) ) - ([], (pkg, False) : dep_pkgs deps) + ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) + , ppr pkg <+> ppr (dep_pkgs deps) ) + ([], (pkg, False) : dep_pkgs deps, False) -- True <=> import M () import_all = case imp_details of @@ -253,7 +313,8 @@ rnImportDecl this_mod implicit_prelude || (implicit_prelude && safeImplicitImpsReq dflags) imports = ImportAvails { - imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe')], + imp_mods = unitModuleEnv imp_mod + [(qual_mod_name, import_all, loc, mod_safe')], imp_orphs = orphans, imp_finsts = finsts, imp_dep_mods = mkModDeps dependent_mods, @@ -261,14 +322,18 @@ rnImportDecl this_mod implicit_prelude -- Add in the imported modules trusted package -- requirements. ONLY do this though if we import the -- module as a safe import. - -- see Note [Trust Transitive Property] + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] imp_trust_pkgs = if mod_safe' then map fst $ filter snd dependent_pkgs - else [] + else [], + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req } -- Complain if we import a deprecated module - ifDOptM Opt_WarnWarningsDeprecations ( + ifWOptM Opt_WarnWarningsDeprecations ( case warns of WarnAll txt -> addWarn (moduleWarn imp_mod_name txt) _ -> return () @@ -625,11 +690,11 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails -- Warn when importing T(..) if T was exported abstractly checkDodgyImport stuff | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff - = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) - -- NB. use the RdrName for reporting the warning - | IEThingAll {} <- ieRdr - , not (is_qual decl_spec) - = ifDOptM Opt_WarnMissingImportList $ + = ifWOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) + -- NB. use the RdrName for reporting the warning + | IEThingAll {} <- ieRdr + , not (is_qual decl_spec) + = ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListItem ieRdr) checkDodgyImport _ = return () @@ -956,13 +1021,13 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod (L loc (IEModuleContents mod)) | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] , mod `elem` earlier_mods -- Duplicate export of M - = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; + = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; warnIf warn_dup_exports (dupModuleExport mod) ; return acc } | otherwise = do { implicit_prelude <- xoptM Opt_ImplicitPrelude - ; warnDodgyExports <- doptM Opt_WarnDodgyExports + ; warnDodgyExports <- woptM Opt_WarnDodgyExports ; let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gres = filter (isModuleExported implicit_prelude mod) @@ -1025,7 +1090,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod Nothing -> mkRdrUnqual Just (modName, _) -> mkRdrQual modName addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids - warnDodgyExports <- doptM Opt_WarnDodgyExports + warnDodgyExports <- woptM Opt_WarnDodgyExports when (null kids) $ if isTyConName name then when warnDodgyExports $ addWarn (dodgyExportWarn name) @@ -1108,7 +1173,7 @@ check_occs ie occs names -- 'names' are the entities specifed by 'ie' -- But we don't want to warn if the same thing is exported -- by two different module exports. See ticket #4478. -> do unless (dupExport_ok name ie ie') $ do - warn_dup_exports <- doptM Opt_WarnDuplicateExports + warn_dup_exports <- woptM Opt_WarnDuplicateExports warnIf warn_dup_exports (dupExportWarn name_occ ie ie') return occs @@ -1174,7 +1239,7 @@ finishWarnings :: DynFlags -> Maybe WarningTxt -- All this happens only once per module finishWarnings dflags mod_warn tcg_env = do { (eps,hpt) <- getEpsAndHpt - ; ifDOptM Opt_WarnWarningsDeprecations $ + ; ifWOptM Opt_WarnWarningsDeprecations $ mapM_ (check hpt (eps_PIT eps)) all_gres -- By this time, typechecking is complete, -- so the PIT is fully populated @@ -1328,18 +1393,20 @@ warnUnusedImportDecls gbl_env ; let usage :: [ImportDeclUsage] usage = findImportUsage imports rdr_env (Set.elems uses) - ; traceRn (ptext (sLit "Import usage") <+> ppr usage) - ; ifDOptM Opt_WarnUnusedImports $ + ; 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/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 3a60066342..8f99b33aad 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -47,7 +47,8 @@ import Name import NameSet import RdrName import BasicTypes -import ListSetOps ( removeDups, minusList ) +import Util ( notNull ) +import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString @@ -468,15 +469,13 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } Nothing -> ptext (sLit "constructor field name") Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) - name_to_arg (L loc n) = L loc (mk_arg (mkRdrUnqual (nameOccName n))) - rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld , hsRecFieldArg = arg , hsRecPun = pun }) - = do { fld' <- wrapLocM (lookupSubBndr parent doc) fld + = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndr parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) - ; return (name_to_arg fld') } + ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } else return arg ; return (HsRecField { hsRecFieldId = fld' , hsRecFieldArg = arg' @@ -491,30 +490,54 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM Opt_RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) - + ; (rdr_env, lcl_env) <- getRdrEnvs ; con_fields <- lookupConstructorFields con ; let present_flds = getFieldIds flds - absent_flds = con_fields `minusList` present_flds + parent_tc = find_tycon rdr_env con extras = [ HsRecField - { hsRecFieldId = L loc f - , hsRecFieldArg = name_to_arg (L loc f) + { hsRecFieldId = loc_f + , hsRecFieldArg = L loc (mk_arg arg_rdr) , hsRecPun = False } - | f <- absent_flds ] + | f <- con_fields + , let loc_f = L loc f + arg_rdr = mkRdrUnqual (nameOccName f) + , not (f `elem` present_flds) + , fld_in_scope f + , case ctxt of + HsRecFieldCon {} -> arg_in_scope arg_rdr + _other -> True ] + + -- Only fill in fields whose selectors are in scope (somehow) + fld_in_scope fld = not (null (lookupGRE_Name rdr_env fld)) + + -- For constructor uses, the arg should be in scope (unqualified) + -- ignoring the record field itself + -- Eg. data R = R { x,y :: Int } + -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} + arg_in_scope rdr = rdr `elemLocalRdrEnv` lcl_env + || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env + , case gre_par gre of + ParentIs p -> p /= parent_tc + _ -> True ] ; return (flds ++ extras) } check_disambiguation :: Bool -> Maybe Name -> RnM Parent - -- When disambiguation is on, return the parent *type constructor* - -- That is, the parent of the data constructor. That's the parent - -- to use for looking up record fields. + -- When disambiguation is on, check_disambiguation disambig_ok mb_con | disambig_ok, Just con <- mb_con - = do { env <- getGlobalRdrEnv - ; return (case lookupGRE_Name env con of - [gre] -> gre_par gre - gres -> WARN( True, ppr con <+> ppr gres ) NoParent) } + = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) } | otherwise = return NoParent + find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -} + -- Return the parent *type constructor* of the data constructor + -- That is, the parent of the data constructor. + -- That's the parent to use for looking up record fields. + find_tycon env con + = case lookupGRE_Name env con of + [GRE { gre_par = ParentIs p }] -> p + gres -> pprPanic "find_tycon" (ppr con $$ ppr gres) + dup_flds :: [[RdrName]] -- Each list represents a RdrName that occurred more than once -- (the list contains all occurrences) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 12d4375606..0ddfa0a2ae 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -19,7 +19,7 @@ import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn -import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields ) +import RnTypes import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, @@ -169,7 +169,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (H) Rename Everything else (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; - (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ + (rn_rule_decls, src_fvs3) <- setXOptM Opt_ScopedTypeVariables $ rnList rnHsRuleDecl rule_decls ; -- Inside RULES, scoped type variables are on (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; @@ -531,7 +531,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; ty' <- rnLHsType (text "a deriving decl") ty + ; ty' <- rnLHsType (text "In a deriving declaration") ty ; let fvs = extractHsTyNames ty' ; return (DerivDecl ty', fvs) } @@ -919,12 +919,16 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; rdr_env <- getLocalRdrEnv ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc arg_tys = hsConDeclArgTys details - implicit_tvs = case res_ty of + mentioned_tvs = case res_ty of ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) - new_tvs = case expl of - Explicit -> tvs - Implicit -> userHsTyVarBndrs implicit_tvs + + -- With an Explicit forall, check for unused binders + -- With Implicit, find the mentioned ones, and use them as binders + ; new_tvs <- case expl of + Implicit -> return (userHsTyVarBndrs mentioned_tvs) + Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs + ; return tvs } ; mb_doc' <- rnMbLHsDoc mb_doc diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index be90d7d0a9..392e411b37 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -11,7 +11,7 @@ module RnTypes ( -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, + checkPrecMatch, checkSectionPrec, warnUnusedForAlls, -- Splice related stuff rnSplice, checkTH @@ -36,6 +36,7 @@ import Name import SrcLoc import NameSet +import Util ( filterOut ) import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) import Outputable @@ -93,19 +94,16 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do rnForAll doc Implicit tyvar_bndrs ctxt ty -rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do - -- Explicit quantification. - -- Check that the forall'd tyvars are actually - -- mentioned in the type, and produce a warning if not - let - mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau) - forall_tyvar_names = hsLTyVarLocNames forall_tyvars - - -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names +rnHsType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) + = do { -- Explicit quantification. + -- Check that the forall'd tyvars are actually + -- mentioned in the type, and produce a warning if not + let mentioned = extractHsRhoRdrTyVars ctxt tau + in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) + ; warnUnusedForAlls (in_type_doc $$ doc) forall_tyvars mentioned - mapM_ (forAllWarn doc tau) warn_guys - rnForAll doc Explicit forall_tyvars ctxt tau + ; -- rnForAll does the rest + rnForAll doc Explicit forall_tyvars ctxt tau } rnHsType _ (HsTyVar tyvar) = do tyvar' <- lookupOccRn tyvar @@ -560,14 +558,19 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) %********************************************************* \begin{code} -forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName - -> TcRnIf TcGblEnv TcLclEnv () -forAllWarn doc ty (L loc tyvar) - = ifDOptM Opt_WarnUnusedMatches $ - addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar), - nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))] - $$ - doc) +warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [Located RdrName] -> TcM () +warnUnusedForAlls in_doc bound used + = ifWOptM Opt_WarnUnusedMatches $ + mapM_ add_warn bound_but_not_used + where + bound_names = hsLTyVarLocNames bound + bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names + mentioned_rdrs = map unLoc used + + add_warn (L loc tv) + = addWarnAt loc $ + vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) + , in_doc ] opTyErr :: RdrName -> HsType RdrName -> SDoc opTyErr op ty@(HsOpTy ty1 _ _) diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 5bec8f0c3d..6a287f4564 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -10,12 +10,14 @@ module CSE ( #include "HsVersions.h" +import CoreSubst +import Var ( Var ) import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) -import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap ) +import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr + , exprIsTrivial, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) import CoreSyn -import VarEnv import Outputable import StaticFlags ( opt_PprStyle_Debug ) import BasicTypes ( isAlwaysActive ) @@ -61,12 +63,6 @@ Here we must *not* do CSE on the inner x+x! The simplifier used to guarantee no shadowing, but it doesn't any more (it proved too hard), so we clone as we go. We can simply add clones to the substitution already described. -However, we do NOT clone type variables. It's just too hard, because then we need -to run the substitution over types and IdInfo. No no no. Instead, we just throw - -(In fact, I think the simplifier does guarantee no-shadowing for type variables.) - - Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -187,47 +183,52 @@ cseBinds env (b:bs) = (b':bs') bs' = cseBinds env1 bs cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e) - in (env', NonRec b' e') -cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs - in (env', Rec pairs') - - -do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr)) -do_one env (id, rhs) +cseBind env (NonRec b e) + = (env2, NonRec b' e') + where + (env1, b') = addBinder env b + (env2, e') = cseRhs env1 (b',e) + +cseBind env (Rec pairs) + = (env2, Rec (bs' `zip` es')) + where + (bs,es) = unzip pairs + (env1, bs') = addRecBinders env bs + (env2, es') = mapAccumL cseRhs env1 (bs' `zip` es) + +cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr) +cseRhs env (id',rhs) = case lookupCSEnv env rhs' of - Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id)) - Just other_expr -> (env', (id', other_expr)) - Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs')) + Just other_expr -> (env, other_expr) + Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') where - (env', id') = addBinder env id - rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs - | otherwise = rhs + rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs + | otherwise = rhs -- See Note [CSE for INLINE and NOINLINE] -tryForCSE :: CSEnv -> CoreExpr -> CoreExpr -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 - -cseExpr :: CSEnv -> CoreExpr -> CoreExpr -cseExpr _ (Type t) = Type t -cseExpr _ (Coercion co) = Coercion co +tryForCSE :: CSEnv -> InExpr -> OutExpr +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 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) = Var (lookupSubst env v) +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 in Let bind' (cseExpr env' e) -cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts) +cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' where + alts' = cseAlts env' scrut' bndr bndr'' alts scrut' = tryForCSE env scrut (env', bndr') = addBinder env bndr bndr'' = zapIdOccInfo bndr' @@ -235,7 +236,7 @@ cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scru -- cause a dead case binder to be alive, so we -- play safe here and bring them all to life -cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt] +cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] | isUnboxedTupleCon con @@ -256,11 +257,11 @@ cseAlts env scrut' bndr bndr' alts where (con_target, alt_env) = case scrut' of - Var v' -> (v', extendSubst env bndr v') -- See Note [Case binders 1] + Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] -- map: bndr -> v' - _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] - -- map: scrut' -> bndr' + _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] + -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) @@ -291,19 +292,28 @@ cseAlts env scrut' bndr bndr' alts %************************************************************************ \begin{code} -data CSEnv = CS CSEMap InScopeSet (IdEnv Id) - -- Simple substitution +type InExpr = CoreExpr -- Pre-cloning +type InBndr = CoreBndr +type InAlt = CoreAlt + +type OutExpr = CoreExpr -- Post-cloning +type OutBndr = CoreBndr +type OutAlt = CoreAlt -type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping +data CSEnv = CS CSEMap 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 emptyInScopeSet emptyVarEnv +emptyCSEnv = CS emptyUFM emptySubst -lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr -lookupCSEnv (CS cs in_scope _) expr +csEnvSubst :: CSEnv -> Subst +csEnvSubst (CS _ subst) = subst + +lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr +lookupCSEnv (CS cs sub) expr = case lookupUFM cs (hashExpr expr) of Nothing -> Nothing Just pairs -> lookup_list pairs @@ -312,20 +322,21 @@ lookupCSEnv (CS cs in_scope _) expr -- 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 :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr - lookup_list [] = Nothing - lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e' - | otherwise = lookup_list es + lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr + lookup_list ((e,e'):es) + | eqExpr (substInScope sub) e expr = Just e' + | otherwise = lookup_list es + lookup_list [] = Nothing -addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv +addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv addCSEnvItem env expr expr' | exprIsBig expr = env | otherwise = extendCSEnv env expr expr' -- We don't try to CSE big expressions, because they are expensive to compare -- (and are unlikely to be the same anyway) -extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv -extendCSEnv (CS cs in_scope sub) expr expr' - = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub +extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv +extendCSEnv (CS cs sub) expr expr' + = CS (addToUFM_C combine cs hash [(expr, expr')]) sub where hash = hashExpr expr combine old new @@ -336,26 +347,24 @@ extendCSEnv (CS cs in_scope sub) expr expr' long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result | otherwise = empty -lookupSubst :: CSEnv -> Id -> Id -lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of - Just y -> y - Nothing -> x - -extendSubst :: CSEnv -> Id -> Id -> CSEnv -extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y) - -addBinder :: CSEnv -> Id -> (CSEnv, Id) -addBinder (CS cs in_scope sub) v - | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v) - | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v') - | otherwise = WARN( True, ppr v ) - (CS emptyUFM in_scope sub, v) - -- This last case is the unusual situation where we have shadowing of - -- a type variable; we have to discard the CSE mapping - -- See Note [Shadowing] - where - v' = uniqAway in_scope v +lookupSubst :: CSEnv -> Id -> OutExpr +lookupSubst (CS _ 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)) + +addBinder :: CSEnv -> Var -> (CSEnv, Var) +addBinder (CS cs sub) v = (CS cs sub', v') + where + (sub', v') = substBndr sub v + +addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) +addBinders (CS cs sub) vs = (CS cs sub', vs') + where + (sub', vs') = substBndrs sub vs -addBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addBinders env vs = mapAccumL addBinder env vs +addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) +addRecBinders (CS cs sub) vs = (CS cs sub', vs') + where + (sub', vs') = substRecBndrs sub vs \end{code} diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 8e6ec5c870..d03d2c4f37 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -11,10 +11,8 @@ module CoreMonad ( CoreToDo(..), runWhen, runMaybe, SimplifierMode(..), FloatOutSwitches(..), - dumpSimplPhase, + dumpSimplPhase, pprPassDetails, - defaultGentleSimplToDo, - -- * Plugins PluginPass, Plugin(..), CommandLineOption, defaultPlugin, bindsOnlyPass, @@ -41,7 +39,7 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Debug output - showPass, endPass, endIteration, dumpIfSet, + showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, @@ -118,49 +116,53 @@ showPass :: DynFlags -> CoreToDo -> IO () showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO () -endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass) - --- Same as endPass but doesn't dump Core even with -dverbose-core2core -endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO () -endIteration dflags pass n - = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n) - (Just Opt_D_dump_simpl_iterations) +endPass dflags pass binds rules + = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules + ; lintPassResult dflags pass binds } + where + mb_flag = case coreDumpFlag pass of + Just dflag | dopt dflag dflags -> Just dflag + | dopt Opt_D_verbose_core2core dflags -> Just dflag + _ -> Nothing dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO () dumpIfSet dump_me pass extra_info doc = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc -dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag - -> [CoreBind] -> [CoreRule] -> IO () --- The "show_all" parameter says to print dump if -dverbose-core2core is on -dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules - = do { -- Report result size if required +dumpPassResult :: DynFlags + -> Maybe DynFlag -- Just df => show details in a file whose + -- name is specified by df + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> [CoreBind] -> [CoreRule] + -> IO () +dumpPassResult dflags mb_flag hdr extra_info binds rules + | Just dflag <- mb_flag + = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc + + | otherwise + = Err.debugTraceMsg dflags 2 $ + (text "Result size of" <+> hdr <+> equals <+> int (coreBindsSize binds)) + -- Report result size -- This has the side effect of forcing the intermediate to be evaluated - ; Err.debugTraceMsg dflags 2 $ - (text " Result size =" <+> int (coreBindsSize binds)) - - -- Report verbosely, if required - ; let pass_name = showSDoc (ppr pass <+> extra_info) - dump_doc = pprCoreBindings binds - $$ ppUnless (null rules) pp_rules - - ; case mb_dump_flag of - Nothing -> return () - Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc - where - dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core] - | otherwise = [dump_flag] - - -- Type check - ; when (dopt Opt_DoCoreLinting dflags) $ - do { let (warns, errs) = lintCoreBindings binds - ; Err.showPass dflags ("Core Linted result of " ++ pass_name) - ; displayLintResults dflags pass warns errs binds } } + where + dump_doc = vcat [ text "Result size =" <+> int (coreBindsSize binds) + , extra_info + , blankLine + , pprCoreBindings binds + , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine , ptext (sLit "------ Local rules for imported ids --------") , pprRules rules ] +lintPassResult :: DynFlags -> CoreToDo -> [CoreBind] -> IO () +lintPassResult dflags pass binds + = when (dopt Opt_DoCoreLinting dflags) $ + do { let (warns, errs) = lintCoreBindings binds + ; Err.showPass dflags ("Core Linted result of " ++ showSDoc (ppr pass)) + ; displayLintResults dflags pass warns errs binds } + displayLintResults :: DynFlags -> CoreToDo -> Bag Err.Message -> Bag Err.Message -> [CoreBind] -> IO () @@ -222,7 +224,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 @@ -259,13 +260,10 @@ 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 - ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier") - <+> ppr md - <+> ptext (sLit "max-iterations=") <> int n + ppr (CoreDoSimplify _ _) = ptext (sLit "Simplifier") ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s ppr CoreDoFloatInwards = ptext (sLit "Float inwards") ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) @@ -282,9 +280,12 @@ 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") + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n +pprPassDetails _ = empty \end{code} \begin{code} @@ -340,17 +341,6 @@ pprFloatOutSwitches sw , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw) , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ]) --- | A reasonably gentle simplification pass for doing "obvious" simplifications -defaultGentleSimplToDo :: CoreToDo -defaultGentleSimplToDo = CoreDoSimplify 4 -- 4 is the default maxSimpleIterations - (SimplMode { sm_phase = InitialPhase - , sm_names = ["Gentle"] - , sm_rules = True -- Note [RULEs enabled in SimplGently] - , sm_inline = False - , sm_eta_expand = False - , sm_case_case = False - }) - -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo runWhen True do_this = do_this diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index e5db7d93ce..4f6d7b4690 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -16,10 +16,10 @@ import CoreMonad ( FloatOutSwitches(..) ) import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) -import Id ( Id, idType, idArity, isBottomingId ) -import Type ( isUnLiftedType ) -import SetLevels ( Level(..), LevelledExpr, LevelledBind, - setLevels, isTopLvl ) +import DataCon ( DataCon ) +import Id ( Id, idArity, isBottomingId ) +import Var ( Var ) +import SetLevels import UniqSupply ( UniqSupply ) import Bag import Util @@ -132,13 +132,16 @@ floatOutwards float_sws dflags us pgm int ntlets, ptext (sLit " Lets floated elsewhere; from "), int lams, ptext (sLit " Lambda groups")]); - return (concat binds_s') + return (bagToList (unionManyBags binds_s')) } -floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) +floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) floatTopBind bind - = case (floatBind bind) of { (fs, floats) -> - (fs, bagToList (flattenFloats floats)) } + = case (floatBind bind) of { (fs, floats, bind') -> + let float_bag = flattenTopFloats floats + in case bind' of + Rec prs -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) + NonRec {} -> (fs, float_bag `snocBag` bind') } \end{code} %************************************************************************ @@ -148,45 +151,52 @@ floatTopBind bind %************************************************************************ \begin{code} -floatBind :: LevelledBind -> (FloatStats, FloatBinds) -floatBind (NonRec (TB var level) rhs) - = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> +floatBind :: LevelledBind -> (FloatStats, FloatBinds, CoreBind) +floatBind (NonRec (TB var _) rhs) + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> -- A tiresome hack: -- see Note [Bottoming floats: eta expansion] in SetLevels let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' | otherwise = rhs' - in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) } + in (fs, rhs_floats, NonRec var rhs'') } floatBind (Rec pairs) = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> - -- NB: the rhs floats may contain references to the - -- bound things. For example - -- f = ...(let v = ...f... in b) ... - if not (isTopLvl dest_lvl) then - -- Find which bindings float out at least one lambda beyond this one - -- These ones can't mention the binders, because they couldn't - -- be escaping a major level if so. - -- The ones that are not going further can join the letrec; - -- they may not be mutually recursive but the occurrence analyser will - -- find that out. In our example we make a Rec thus: - -- v = ...f... - -- f = ... b ... - case (partitionByMajorLevel dest_lvl rhs_floats) of { (floats', heres) -> - (fs, floats' `plusFloats` unitFloat dest_lvl - (Rec (floatsToBindPairs heres new_pairs))) } - else - -- For top level, no need to partition; just make them all recursive - -- (And the partition wouldn't work because they'd all end up in floats') - (fs, unitFloat dest_lvl - (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) } + (fs, rhs_floats, Rec (concat new_pairs)) } where - (((TB _ dest_lvl), _) : _) = pairs - - do_pair (TB name level, rhs) - = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (name, rhs')) } + do_pair (TB name spec, rhs) + | 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 -- 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]) @@ -196,6 +206,37 @@ 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 + letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } +The binding for bar will be in the "tops" part of the floating binds, +and thus not partioned by floatBody. + +We could perhaps get rid of the 'tops' component of the floating binds, +but this case works just as well. + %************************************************************************ @@ -204,94 +245,100 @@ floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> %************************************************************************ \begin{code} -floatExpr, floatRhs, floatCaseAlt - :: Level - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) - -floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss - = case (floatExpr lvl arg) of { (fsa, floats, arg') -> - case (partitionByMajorLevel lvl floats) of { (floats', heres) -> - -- Dump bindings that aren't going to escape from a lambda; - -- in particular, we must dump the ones that are bound by - -- the rec or case alternative +floatBody :: Level + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) + +floatBody lvl arg -- Used rec rhss, and case-alternative rhss + = case (floatExpr arg) of { (fsa, floats, arg') -> + case (partitionByLevel lvl floats) of { (floats', heres) -> + -- Dump bindings are bound here (fsa, floats', install heres arg') }} ----------------- -floatRhs lvl arg -- Used for nested non-rec rhss, and fn args - -- See Note [Floating out of RHS] - = floatExpr lvl arg - ------------------ -floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v) -floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty) -floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co) -floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit) +floatExpr :: LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatExpr (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) +floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) -floatExpr lvl (App e a) - = case (floatExpr lvl e) of { (fse, floats_e, e') -> - case (floatRhs lvl a) of { (fsa, floats_a, a') -> +floatExpr (App e a) + = case (floatExpr e) of { (fse, floats_e, e') -> + case (floatExpr a) of { (fsa, floats_a, a') -> (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} -floatExpr _ lam@(Lam (TB _ lam_lvl) _) +floatExpr lam@(Lam (TB _ lam_spec) _) = let (bndrs_w_lvls, body) = collectBinders lam bndrs = [b | TB b _ <- bndrs_w_lvls] + bndr_lvl = floatSpecLevel lam_spec -- All the binders have the same level -- See SetLevels.lvlLamBndrs in - case (floatExpr lam_lvl body) of { (fs, floats, body1) -> - - -- Dump anything that is captured by this lambda - -- Eg \x -> ...(\y -> let v = <blah> in ...)... - -- We'll have the binding (v = <blah>) in the floats, - -- but must dump it at the lambda-x - case (partitionByLevel lam_lvl floats) of { (floats1, heres) -> - (add_to_stats fs floats1, floats1, mkLams bndrs (install heres body1)) - }} - -floatExpr lvl (Note note@(SCC cc) expr) - = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> + case (floatBody bndr_lvl body) of { (fs, floats, body') -> + (add_to_stats fs floats, floats, mkLams bndrs body') } + +floatExpr (Note note@(SCC cc) expr) + = case (floatExpr expr) of { (fs, floating_defns, expr') -> let -- Annotate bindings floated outwards past an scc expression -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns in (fs, annotated_defns, Note note expr') } -floatExpr lvl (Note note expr) -- Other than SCCs - = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> +floatExpr (Note note expr) -- Other than SCCs + = case (floatExpr expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Note note expr') } -floatExpr lvl (Cast expr co) - = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> +floatExpr (Cast expr co) + = case (floatExpr expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Cast expr' co) } -floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body) - | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case - -- I.e. floatExpr for rhs, floatCaseAlt for body - = case floatExpr lvl rhs of { (_, rhs_floats, rhs') -> - case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') -> - (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }} - -floatExpr lvl (Let bind body) - = case (floatBind bind) of { (fsb, bind_floats) -> - case (floatExpr lvl body) of { (fse, body_floats, body') -> - case partitionByMajorLevel lvl (bind_floats `plusFloats` body_floats) - of { (floats, heres) -> - -- See Note [Avoiding unnecessary floating] - (add_stats fsb fse, floats, install heres body') } } } - -floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) - = case floatExpr lvl scrut of { (fse, fde, scrut') -> - case floatList float_alt alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') - }} +floatExpr (Let bind body) + = case bind_spec of + FloatMe dest_lvl + -> case (floatBind bind) of { (fsb, bind_floats, bind') -> + case (floatExpr body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` unitLetFloat dest_lvl bind' + `plusFloats` body_floats + , body') }} + + StayPut bind_lvl -- See Note [Avoiding unnecessary floating] + -> case (floatBind bind) of { (fsb, bind_floats, bind') -> + case (floatBody bind_lvl body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` body_floats + , Let bind' body') }} where - -- Use floatCaseAlt for the alternatives, so that we - -- don't gratuitiously float bindings out of the RHSs - float_alt (con, bs, rhs) - = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') -> + bind_spec = case bind of + NonRec (TB _ s) _ -> s + Rec ((TB _ s, _) : _) -> s + Rec [] -> panic "floatExpr:rec" + +floatExpr (Case scrut (TB case_bndr case_spec) ty alts) + = case case_spec of + FloatMe dest_lvl -- Case expression moves + | [(DataAlt con, bndrs, rhs)] <- alts + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatExpr rhs of { (fsb, fdb, rhs') -> + let + float = unitCaseFloat dest_lvl scrut' + case_bndr con [b | TB b _ <- bndrs] + in + (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} + | otherwise + -> pprPanic "Floating multi-case" (ppr alts) + + StayPut bind_lvl -- Case expression stays put + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') + }} + where + float_alt bind_lvl (con, bs, rhs) + = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } \end{code} @@ -391,22 +438,40 @@ partitionByMajorLevel. \begin{code} -type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted +data FloatBind + = FloatLet FloatLet + | FloatCase CoreExpr Id DataCon [Var] -- case e of y { C ys -> ... } -data FloatBinds = FB !(Bag FloatBind) -- Destined for top level - !MajorEnv -- Levels other than top - -- See Note [Representation of FloatBinds] +type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level -instance Outputable FloatBinds where - ppr (FB fbs env) = ptext (sLit "FB") <+> (braces $ vcat - [ ptext (sLit "binds =") <+> ppr fbs - , ptext (sLit "env =") <+> ppr env ]) +data FloatBinds = FB !(Bag FloatLet) -- Destined for top level + !MajorEnv -- Levels other than top + -- See Note [Representation of FloatBinds] -type MajorEnv = M.IntMap MinorEnv -- Keyed by major level -type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level +instance Outputable FloatBind where + ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b + ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) -flattenFloats :: FloatBinds -> Bag FloatBind -flattenFloats (FB tops others) = tops `unionBags` flattenMajor others +instance Outputable FloatBinds where + ppr (FB fbs defs) + = ptext (sLit "FB") <+> (braces $ vcat + [ ptext (sLit "tops =") <+> ppr fbs + , ptext (sLit "non-tops =") <+> ppr defs ]) + +flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats (FB tops defs) + = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) + tops + +addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +addTopFloatPairs float_bag prs + = foldrBag add prs float_bag + where + add (NonRec b r) prs = (b,r):prs + add (Rec prs1) prs2 = prs1 ++ prs2 flattenMajor :: MajorEnv -> Bag FloatBind flattenMajor = M.fold (unionBags . flattenMinor) emptyBag @@ -417,13 +482,20 @@ flattenMinor = M.fold unionBags emptyBag emptyFloats :: FloatBinds emptyFloats = FB emptyBag M.empty -unitFloat :: Level -> FloatBind -> FloatBinds -unitFloat lvl@(Level major minor) b +unitCaseFloat :: Level -> CoreExpr -> Id -> DataCon -> [Var] -> FloatBinds +unitCaseFloat (Level major minor) e b con bs + = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs)))) + +unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat lvl@(Level major minor) b | isTopLvl lvl = FB (unitBag b) M.empty - | otherwise = FB emptyBag (M.singleton major (M.singleton minor (unitBag b))) + | otherwise = FB emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatLet b) plusFloats :: FloatBinds -> FloatBinds -> FloatBinds -plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2) +plusFloats (FB t1 l1) (FB t2 l2) + = FB (t1 `unionBags` t2) (l1 `plusMajor` l2) plusMajor :: MajorEnv -> MajorEnv -> MajorEnv plusMajor = M.unionWith plusMinor @@ -431,26 +503,27 @@ plusMajor = M.unionWith plusMinor plusMinor :: MinorEnv -> MinorEnv -> MinorEnv plusMinor = M.unionWith unionBags -floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -floatsToBindPairs floats binds = foldrBag add binds floats - where - add (Rec pairs) binds = pairs ++ binds - add (NonRec binder rhs) binds = (binder,rhs) : binds - install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr = foldrBag install_group expr defn_groups where - install_group defns body = Let defns body + install_group (FloatLet defns) body + = Let defns body + install_group (FloatCase e b con bs) body + = Case e b (exprType body) [(DataAlt con, bs, body)] -partitionByMajorLevel, partitionByLevel +partitionByLevel :: Level -- Partitioning level -> FloatBinds -- Defns to be divided into 2 piles... -> (FloatBinds, -- Defns with level strictly < partition level, Bag FloatBind) -- The rest +{- -- ---- partitionByMajorLevel ---- --- Float it if we escape a value lambda, *or* if we get to the top level +-- Float it if we escape a value lambda, +-- *or* if we get to the top level +-- *or* if it's a case-float and its minor level is < current +-- -- If we can get to the top level, say "yes" anyway. This means that -- x = f e -- transforms to @@ -465,6 +538,7 @@ partitionByMajorLevel (Level major _) (FB tops defns) heres = case mb_heres of Nothing -> emptyBag Just h -> flattenMinor h +-} partitionByLevel (Level major minor) (FB tops defns) = (FB tops (outer_maj `plusMajor` M.singleton major outer_min), @@ -480,9 +554,13 @@ partitionByLevel (Level major minor) (FB tops defns) wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds wrapCostCentre cc (FB tops defns) - = FB (wrap_defns tops) (M.map (M.map wrap_defns) defns) + = FB (mapBag wrap_bind tops) (M.map (M.map wrap_defns) defns) where wrap_defns = mapBag wrap_one - wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs) - wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs) + + wrap_bind (NonRec binder rhs) = NonRec binder (mkSCC cc rhs) + wrap_bind (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (mkSCC cc e) b c bs \end{code} diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 06133d6bdb..95d1325730 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -21,10 +21,9 @@ import CoreSyn import CoreFVs import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce ) import Id -import NameEnv -import NameSet -import Name ( Name, localiseName ) +import Name( localiseName ) import BasicTypes +import Module( Module ) import Coercion import VarSet @@ -36,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 @@ -53,11 +52,20 @@ import Data.List Here's the externally-callable interface: \begin{code} -occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect] +occurAnalysePgm :: Module -- Used only in debug output + -> (Activation -> Bool) + -> [CoreRule] -> [CoreVect] -> [CoreBind] -> [CoreBind] -occurAnalysePgm active_rule imp_rules vects binds - = snd (go (initOccEnv active_rule imp_rules) binds) +occurAnalysePgm this_mod active_rule imp_rules vects binds + | isEmptyVarEnv final_usage + = binds' + | otherwise -- See Note [Glomming] + = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage ) ) + [Rec (flattenBinds binds')] where + (final_usage, binds') = go (initOccEnv active_rule) binds + initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects) -- The RULES and VECTORISE declarations keep things alive! @@ -74,10 +82,10 @@ occurAnalysePgm active_rule imp_rules vects binds occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned occurAnalyseExpr expr - = snd (occAnal (initOccEnv all_active_rules []) expr) + = snd (occAnal (initOccEnv all_active_rules) expr) where -- To be conservative, we say that all inlines and rules are active - all_active_rules = Just (\_ -> True) + all_active_rules = \_ -> True \end{code} @@ -113,6 +121,21 @@ occAnalBind env _ (NonRec binder rhs) body_usage rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + +occAnalBind _ env (Rec pairs) body_usage + = foldr occAnalRec (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec + where + bndr_set = mkVarSet (map fst pairs) + + sccs :: [SCC (Node Details)] + sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes + + nodes :: [Node Details] + nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env bndr_set) pairs \end{code} Note [Dead code] @@ -147,12 +170,25 @@ dropped. It isn't easy to do a perfect job in one blow. Consider ...m... -Note [Loop breaking and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Loop breaking is surprisingly subtle. First read the section 4 of -"Secrets of the GHC inliner". This describes our basic plan. +------------------------------------------------------------ +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" +and "g uses f", no matter how indirectly. We do a SCC analysis +with an edge f -> g if "f uses g". + +More precisely, "f uses g" iff g should be in scope whereever f is. +That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f (Note [Rules are extra RHSs]) + c) or the LHS or a rule for f (Note [Rule dependency info]) -However things are made quite a bit more complicated by RULES. Remember +These conditions apply regardless of the activation of the RULE (eg it might be +inactive in this phase but become active later). Once a Rec is broken up +it can never be put back together, so we must be conservative. + +The principle is that, regardless of rule firings, every variale is +always in scope. * Note [Rules are extra RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -176,60 +212,86 @@ However things are made quite a bit more complicated by RULES. Remember will be put in the same Rec, even though their 'main' RHSs are both non-recursive. + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a SpecInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + * Note [Rules are visible in their own rec group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want the rules for 'f' to be visible in f's right-hand side. And we'd like them to be visible in other functions in f's Rec - group. E.g. in Example [Specialisation rules] we want f' rule + group. E.g. in Note [Specialisation rules] we want f' rule to be visible in both f's RHS, and fs's RHS. This means that we must simplify the RULEs first, before looking at any of the definitions. This is done by Simplify.simplRecBind, when it calls addLetIdInfo. - * Note [Choosing loop breakers] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We avoid infinite inlinings by choosing loop breakers, and - ensuring that a loop breaker cuts each loop. But what is a - "loop"? In particular, a RULE is like an equation for 'f' that - is *always* inlined if it is applicable. We do *not* disable - rules for loop-breakers. It's up to whoever makes the rules to - make sure that the rules themselves always terminate. See Note - [Rules for recursive functions] in Simplify.lhs - - Hence, if - f's RHS (or its INLINE template if it has one) mentions g, and - g has a RULE that mentions h, and - h has a RULE that mentions f - - then we *must* choose f to be a loop breaker. In general, take the - free variables of f's RHS, and augment it with all the variables - reachable by RULES from those starting points. That is the whole - reason for computing rule_fv_env in occAnalBind. (Of course we - only consider free vars that are also binders in this Rec group.) - See also Note [Finding rule RHS free vars] - - Note that when we compute this rule_fv_env, we only consider variables - free in the *RHS* of the rule, in contrast to the way we build the - Rec group in the first place (Note [Rule dependency info]) - - Note that if 'g' has RHS that mentions 'w', we should add w to - g's loop-breaker edges. More concretely there is an edge from f -> g - iff - (a) g is mentioned in f's RHS - (b) h is mentioned in f's RHS, and - g appears in the RHS of a RULE of h - or a transitive sequence of rules starting with h - - Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is - chosen as a loop breaker, because their RHSs don't mention each other. - And indeed both can be inlined safely. - - Note that the edges of the graph we use for computing loop breakers - are not the same as the edges we use for computing the Rec blocks. - That's why we compute - rec_edges for the Rec block analysis - loop_breaker_edges for the loop breaker analysis +------------------------------------------------------------ +Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. +We avoid infinite inlinings by choosing loop breakers, and +ensuring that a loop breaker cuts each loop. + +Fundamentally, we do SCC analysis on a graph. For each recursive +group we choose a loop breaker, delete all edges to that node, +re-analyse the SCC, and iterate. + +But what is the graph? NOT the same graph as was used for Note +[Forming Rec groups]! In particular, a RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in Simplify.lhs + +Hence, if + f's RHS (or its INLINE template if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. + +In general, take the free variables of f's RHS, and augment it with +all the variables reachable by RULES from those starting points. That +is the whole reason for computing rule_fv_env in occAnalBind. (Of +course we only consider free vars that are also binders in this Rec +group.) See also Note [Finding rule RHS free vars] + +Note that when we compute this rule_fv_env, we only consider variables +free in the *RHS* of the rule, in contrast to the way we build the +Rec group in the first place (Note [Rule dependency info]) + +Note that if 'g' has RHS that mentions 'w', we should add w to +g's loop-breaker edges. More concretely there is an edge from f -> g +iff + (a) g is mentioned in f's RHS `xor` f's INLINE rhs + (see Note [Inline rules]) + (b) or h is mentioned in f's RHS, and + g appears in the RHS of an active RULE of h + or a transitive sequence of active rules starting with h + +Why "active rules"? See Note [Finding rule RHS free vars] + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note again that the edges of the graph we use for computing loop breakers +are not the same as the edges we use for computing the Rec blocks. +That's why we compute + rec_edges for the Rec block analysis + loop_breaker_edges for the loop breaker analysis * Note [Finding rule RHS free vars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -245,7 +307,11 @@ However things are made quite a bit more complicated by RULES. Remember the RULE is only active *before* phase 1. So there's no problem. To make this work, we look for the RHS free vars only for - *active* rules. That's the reason for the is_active argument + *active* rules. More precisely, in the rules that are active now + or might *become* active in a later phase. We need the latter + because (curently) we don't + + That's the reason for the is_active argument to idRhsRuleVars, and the occ_rule_act field of the OccEnv. * Note [Weak loop breakers] @@ -268,10 +334,24 @@ However things are made quite a bit more complicated by RULES. Remember 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! + + 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: - 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 + 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 @@ -279,32 +359,111 @@ However things are made quite a bit more complicated by RULES. Remember 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 [Rule dependency info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a SpecInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. - Why both? Consider - x = y - RULE f x = 4 - Then if we substitute y for x, we'd better do so in the - rule's LHS too, so we'd better ensure the dependency is respected +Note [Rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +Note that RULES for imported functions are important in practice; they +occur a lot in the libraries. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Specialising imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT for *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [Rules for imported +functions]. In paricular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might +not be as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to something at the bottom: + f = \x -> B.g (q x) + h = \y -> 3 + + RULE: B.g (q x) = h x + +Applying this rule makes f refer to h, although f doesn't appear to +depend on h. (And, as in Note [Rules for imported functions], the +dependency might be more indirect. For example, f might mention C.t +rather than B.g, where C.t eventually inlines to B.g.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.g in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +------------------------------------------------------------ +Note [Inline rules] +~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to Inline Rules, +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs - * Note [Inline rules] - ~~~~~~~~~~~~~~~~~~~ - None of the above stuff about RULES applies to Inline Rules, - stored in a CoreUnfolding. The unfolding, if any, is simplified - at the same time as the regular RHS of the function, so it should - be treated *exactly* like an extra RHS. - There is a danger that we'll be sub-optimal if we see this - f = ...f... - [INLINE f = ..no f...] - where f is recursive, but the INLINE is not. This can just about - happen with a sufficiently odd set of rules; eg +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg foo :: Int -> Int {-# INLINE [1] foo #-} @@ -316,18 +475,17 @@ However things are made quite a bit more complicated by RULES. Remember {-# RULES "foo" [~1] forall x. foo x = bar x #-} - Here the RULE makes bar recursive; but it's INLINE pragma remains - non-recursive. It's tempting to then say that 'bar' should not be - a loop breaker, but an attempt to do so goes wrong in two ways: - a) We may get - $df = ...$cfoo... - $cfoo = ...$df.... - [INLINE $cfoo = ...no-$df...] - But we want $cfoo to depend on $df explicitly so that we - put the bindings in the right order to inline $df in $cfoo - and perhaps break the loop altogether. (Maybe this - b) - +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) Example [eftInt] @@ -346,8 +504,8 @@ Example (from GHC.Enum): "eftIntList" [1] eftIntFB (:) [] = eftInt #-} -Example [Specialisation rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this group, which is typical of what SpecConstr builds: fs a = ....f (C a).... @@ -357,141 +515,158 @@ Consider this group, which is typical of what SpecConstr builds: So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - - fs is inlined (say it's small) - - now there's another opportunity to apply the RULE + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE This showed up when compiling Control.Concurrent.Chan.getChanContents. \begin{code} -occAnalBind _ env (Rec pairs) body_usage - = foldr (occAnalRec env) (body_usage, []) sccs - -- For a recursive group, we - -- * occ-analyse all the RHSs - -- * compute strongly-connected components - -- * feed those components to occAnalRec - where - -------------Dependency analysis ------------------------------ - bndr_set = mkVarSet (map fst pairs) +type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, + -- which is gotten from the Id. +data Details + = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS, already occ-analysed - sccs :: [SCC (Node Details)] - sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges + , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and InlineRule unfolding + -- ignoring phase (ie assuming all are active) + -- See Note [Forming Rec groups] - rec_edges :: [Node Details] - rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs - - make_node (bndr, rhs) - = (details, varUnique bndr, keysUFM out_edges) - where - details = ND { nd_bndr = bndr, nd_rhs = rhs' - , nd_uds = rhs_usage3, nd_inl = inl_fvs} - - (rhs_usage1, rhs') = occAnalRhs env Nothing rhs - rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs] - rhs_usage3 = addIdOccs rhs_usage2 unf_fvs - unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag - unf_fvs = stableUnfoldingVars unf - rule_fvs = idRuleVars bndr -- See Note [Rule dependency info] - - inl_fvs = rhs_fvs `unionVarSet` unf_fvs - rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1 - out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3 - -- (a -> b) means a mentions b - -- Given the usage details (a UFM that gives occ info for each free var of - -- the RHS) we can get the list of free vars -- or rather their Int keys -- - -- by just extracting the keys from the finite map. Grimy, but fast. - -- Previously we had this: - -- [ bndr | bndr <- bndrs, - -- maybeToBool (lookupVarEnv rhs_usage bndr)] - -- which has n**2 cost, and this meant that edges_from alone - -- consumed 10% of total runtime! + , nd_inl :: IdSet -- Free variables of + -- the InlineRule (if present and active) + -- or the RHS (ir no InlineRule) + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , 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 + } + +makeNode :: OccEnv -> VarSet -> (Var, CoreExpr) -> Node Details +makeNode env bndr_set (bndr, rhs) + = (details, varUnique bndr, keysUFM (udFreeVars bndr_set rhs_usage3)) + where + details = ND { nd_bndr = bndr + , nd_rhs = rhs' + , nd_uds = rhs_usage3 + , nd_inl = inl_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 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 + rules = filterOut isBuiltinRule (idCoreRules bndr) + rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs + rules_w_fvs = [ (ru_act rule, fvs) + | rule <- rules + , let fvs = exprFreeVars (ru_rhs rule) + `delVarSetList` ru_bndrs rule + , not (isEmptyVarSet 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 + active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_fvs, is_active a] + + -- Finding the free variables of the INLINE pragma (if any) + unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag + mb_unf_fvs = stableUnfoldingVars isLocalId unf + + -- Find the "nd_inl" free vars; for the loop-breaker phase + inl_fvs = case mb_unf_fvs of + Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS + Just unf_fvs -> unf_fvs + -- We could check for an *active* INLINE (returning + -- emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about + -- RULE activation), so we'd need more plumbing ----------------------------- -occAnalRec :: OccEnv -> SCC (Node Details) +occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind]) -> (UsageDetails, [CoreBind]) -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _)) - (body_usage, binds) - | not (bndr `usedIn` body_usage) - = (body_usage, binds) +occAnalRec (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_uds}, _, _)) + (body_uds, binds) + | not (bndr `usedIn` body_uds) + = (body_uds, binds) | otherwise -- It's mentioned in the body - = (body_usage' +++ rhs_usage, + = (body_uds' +++ rhs_uds, NonRec tagged_bndr rhs : binds) where - (body_usage', tagged_bndr) = tagBinder body_usage bndr - + (body_uds', tagged_bndr) = tagBinder body_uds bndr -- The Rec case is the interesting one -- See Note [Loop breaking] -occAnalRec env (CyclicSCC nodes) (body_usage, binds) - | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage - = (body_usage, binds) -- Dead code +occAnalRec (CyclicSCC nodes) (body_uds, binds) + | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds + = (body_uds, binds) -- Dead code | otherwise -- At this point we always build a single Rec - = (final_usage, Rec pairs : binds) + = (final_uds, Rec pairs : binds) where bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes] bndr_set = mkVarSet bndrs - non_boring bndr = isId bndr && - (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr) ---------------------------- -- Tag the binders with their occurrence info - total_usage = foldl add_usage body_usage nodes - add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage - (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes - - tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details) - -- (a) Tag the binders in the details with occ info - -- (b) Mark the binder with "weak loop-breaker" OccInfo - -- saying "no preInlineUnconditionally" if it is used - -- in any rule (lhs or rhs) of the recursive group - -- See Note [Weak loop breakers] - tag_node usage (details@ND { nd_bndr = bndr }, k, ks) - = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks)) - where - bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1 - | otherwise = bndr1 - bndr1 = setBinderOcc usage bndr - all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) - emptyVarSet bndrs - - ---------------------------- - -- Now reconstruct the cycle - pairs | any non_boring bndrs - = foldr (reOrderRec 0) [] $ - stronglyConnCompFromEdgedVerticesR loop_breaker_edges - | otherwise - = reOrderCycle 0 tagged_nodes [] + tagged_nodes = map tag_node nodes + total_uds = foldl add_uds body_uds nodes + final_uds = total_uds `minusVarEnv` bndr_set + add_uds usage_so_far (nd, _, _) = usage_so_far +++ nd_uds nd + + tag_node :: Node Details -> Node Details + tag_node (details@ND { nd_bndr = bndr }, k, ks) + = (details { nd_bndr = setBinderOcc total_uds bndr }, k, ks) + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + 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 -- See Note [Choosing loop breakers] for loop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes - mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks) - where - new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs)) + mk_node (details@(ND { nd_inl = inl_fvs }), k, _) + = (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs)) ------------------------------------ - rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules - -- Domain is *subset* of bound vars (others have no rule fvs) - rule_fv_env = transClosureFV init_rule_fvs - init_rule_fvs - | Just is_active <- occ_rule_act env -- See Note [Finding rule RHS free vars] - = [ (b, rule_fvs) - | b <- bndrs - , isId b - , let rule_fvs = idRuleRhsVars is_active b - `intersectVarSet` bndr_set - , not (isEmptyVarSet rule_fvs)] - | otherwise - = [] + 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_active_rule_fvs = rule_fvs },_,_) <- nodes + , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set + , not (isEmptyVarSet trimmed_rule_fvs)] \end{code} -@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic +@loopBreakSCC@ is applied to the list of (binder,rhs) pairs for a cyclic strongly connected component (there's guaranteed to be a cycle). It returns the same pairs, but a) in a better order, @@ -506,66 +681,50 @@ on the no-inline Ids then the binds are topologically sorted. This means that the simplifier will generally do a good job if it works from top bottom, recording inlinings for any Ids which aren't marked as "no-inline" as it goes. -============== -[June 98: I don't understand the following paragraphs, and I've - changed the a=b case again so that it isn't a special case any more.] - -Here's a case that bit me: - - letrec - a = b - b = \x. BIG - in - ...a...a...a.... - -Re-ordering doesn't change the order of bindings, but there was no loop-breaker. - -My solution was to make a=b bindings record b as Many, rather like INLINE bindings. -Perhaps something cleverer would suffice. -=============== - - \begin{code} -type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, - -- which is gotten from the Id. -data Details - = ND { nd_bndr :: Id -- Binder - , nd_rhs :: CoreExpr -- RHS - - , nd_uds :: UsageDetails -- Usage from RHS, - -- including RULES and InlineRule unfolding - - , nd_inl :: IdSet -- Other binders *from this Rec group* mentioned in - } -- its InlineRule unfolding (if present) - -- AND the RHS - -- but *excluding* any RULES - -- This is the IdSet that may be used if the Id is inlined - -reOrderRec :: Int -> SCC (Node Details) - -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] --- Sorted into a plausible order. Enough of the Ids have --- IAmALoopBreaker pragmas that there are no loops left. -reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)) - pairs = (bndr, rhs) : pairs -reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs - -reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -reOrderCycle _ [] _ - = panic "reOrderCycle" -reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs - = -- Common case of simple self-recursion - (makeLoopBreaker False bndr, rhs) : pairs - -reOrderCycle depth (bind : binds) pairs - = -- Choose a loop breaker, mark it no-inline, - -- do SCC analysis on the rest, and recursively sort them out --- pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $ - foldr (reOrderRec new_depth) - ([ (makeLoopBreaker False bndr, rhs) - | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs) - (stronglyConnCompFromEdgedVerticesR unchosen) +type Binding = (Id,CoreExpr) + +mk_loop_breaker :: Node Details -> Binding +mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) + = (setIdOccInfo bndr strongLoopBreaker, rhs) + +mk_non_loop_breaker :: VarSet -> Node Details -> Binding +-- See Note [Weak loop breakers] +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 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_in_rules nodes binds + = go (stronglyConnCompFromEdgedVerticesR nodes) binds where - (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds + go [] binds = binds + go (scc:sccs) binds = loop_break_scc scc (go sccs binds) + + loop_break_scc scc binds + = case scc of + 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_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_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 approximate_loop_breaker = depth >= 2 new_depth | approximate_loop_breaker = 0 @@ -573,25 +732,30 @@ reOrderCycle depth (bind : binds) pairs -- After two iterations (d=0, d=1) give up -- and approximate, returning to d=0 + choose_loop_breaker :: Int -- Best score so far + -> [Node Details] -- Nodes with this score + -> [Node Details] -- Nodes with higher scores + -> [Node Details] -- Unprocessed nodes + -> ([Node Details], [Node Details]) -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in - choose_loop_breaker loop_binds _loop_sc acc [] - = (loop_binds, acc) -- Done + choose_loop_breaker _ loop_nodes acc [] + = (loop_nodes, acc) -- Done -- If approximate_loop_breaker is True, we pick *all* -- nodes with lowest score, else just one -- See Note [Complexity of loop breaking] - choose_loop_breaker loop_binds loop_sc acc (bind : binds) + choose_loop_breaker loop_sc loop_nodes acc (node : nodes) | sc < loop_sc -- Lower score so pick this new one - = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds + = choose_loop_breaker sc [node] (loop_nodes ++ acc) nodes | approximate_loop_breaker && sc == loop_sc - = choose_loop_breaker (bind : loop_binds) loop_sc acc binds + = choose_loop_breaker loop_sc (node : loop_nodes) acc nodes | otherwise -- Higher score so don't pick it - = choose_loop_breaker loop_binds loop_sc (bind : acc) binds + = choose_loop_breaker loop_sc loop_nodes (node : acc) nodes where - sc = score bind + sc = score node score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) @@ -606,7 +770,7 @@ reOrderCycle depth (bind : binds) pairs _other -> 3 -- Data structures are more important than this -- so that dictionary/method recursion unravels -- Note that this case hits all InlineRule things, so we - -- never look at 'rhs for InlineRule stuff. That's right, because + -- never look at 'rhs' for InlineRule stuff. That's right, because -- 'rhs' is irrelevant for inlining things with an InlineRule | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications] @@ -647,11 +811,6 @@ reOrderCycle depth (bind : binds) pairs is_con_app (Lam _ e) = is_con_app e is_con_app (Note _ e) = is_con_app e is_con_app _ = False - -makeLoopBreaker :: Bool -> Id -> Id --- Set the loop-breaker flag: see Note [Weak loop breakers] -makeLoopBreaker weak bndr - = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak) \end{code} Note [Complexity of loop breaking] @@ -786,8 +945,8 @@ inlined binder also occurs many times in its scope, but if it doesn't we'll catch it next time round. At worst this costs an extra simplifier pass. ToDo: try using the occurrence info for the inline'd binder. -[March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec. -[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec. +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. \begin{code} @@ -1173,12 +1332,10 @@ data OccEnv = OccEnv { occ_encl :: !OccEncl -- Enclosing context information , occ_ctxt :: !CtxtTy -- Tells about linearity , occ_proxy :: ProxyEnv - , occ_rule_fvs :: ImpRuleUsage - , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive + , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] } - ----------------------------- -- OccEncl is used to control whether to inline into constructor arguments -- For example: @@ -1208,13 +1365,11 @@ type CtxtTy = [Bool] -- be applied many times; but when it is, -- the CtxtTy inside applies -initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule] - -> OccEnv -initOccEnv active_rule imp_rules +initOccEnv :: (Activation -> Bool) -> OccEnv +initOccEnv active_rule = OccEnv { occ_encl = OccVanilla , occ_ctxt = [] , occ_proxy = PE emptyVarEnv emptyVarSet - , occ_rule_fvs = findImpRuleUsage active_rule imp_rules , occ_rule_act = active_rule } vanillaCtxt :: OccEnv -> OccEnv @@ -1254,88 +1409,16 @@ addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } \end{code} -%************************************************************************ -%* * - ImpRuleUsage -%* * -%************************************************************************ \begin{code} -type ImpRuleUsage = NameEnv UsageDetails - -- Maps an *imported* Id f to the UsageDetails for *local* Ids - -- used on the RHS for a *local* rule for f. -\end{code} - -Note [ImpRuleUsage] -~~~~~~~~~~~~~~~~ -Consider this, where A.g is an imported Id - - f x = A.g x - {-# RULE "foo" forall x. A.g x = f x #-} - -Obviously there's a loop, but the danger is that the occurrence analyser -will say that 'f' is not a loop breaker. Then the simplifier will -optimise 'f' to - f x = f x -and then gaily inline 'f'. Result infinite loop. More realistically, -these kind of rules are generated when specialising imported INLINABLE Ids. - -Solution: treat an occurrence of A.g as an occurrence of all the local Ids -that occur on the RULE's RHS. This mapping from imported Id to local Ids -is held in occ_rule_fvs. - -\begin{code} -findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage --- Find the *local* Ids that can be reached transitively, --- via local rules, from each *imported* Id. --- Sigh: this function seems more complicated than it is really worth -findImpRuleUsage Nothing _ = emptyNameEnv -findImpRuleUsage (Just is_active) rules - = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls) - | f <- rule_names - , let ls = find_lcl_deps f - , not (isEmptyVarSet ls) ] - where - rule_names = map ru_fn rules - rule_name_set = mkNameSet rule_names - - imp_deps :: NameEnv VarSet - -- (f,g) means imported Id 'g' appears in RHS of - -- rule for imported Id 'f', *or* does so transitively - imp_deps = foldr add_imp emptyNameEnv rules - add_imp rule acc - | is_active (ruleActivation rule) - = extendNameEnv_C unionVarSet acc (ru_fn rule) - (exprSomeFreeVars keep_imp (ru_rhs rule)) - | otherwise = acc - keep_imp v = isId v && (idName v `elemNameSet` rule_name_set) - full_imp_deps = transClosureFV (ufmToList imp_deps) - - lcl_deps :: NameEnv VarSet - -- (f, l) means localId 'l' appears immediately - -- in the RHS of a rule for imported Id 'f' - -- Remember, many rules might have the same ru_fn - -- so we do need to fold - lcl_deps = foldr add_lcl emptyNameEnv rules - add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule) - (exprFreeIds (ru_rhs rule)) - - find_lcl_deps :: Name -> VarSet - find_lcl_deps f - = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f) - (lookupNameEnv full_imp_deps f `orElse` emptyVarSet) - lookup_lcl :: Name -> VarSet - lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet - -------------- -transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet +transClosureFV :: UniqFM VarSet -> UniqFM VarSet -- If (f,g), (g,h) are in the input, then (f,h) is in the output -transClosureFV fv_list +-- as well as (f,g), (g,h) +transClosureFV env | no_change = env - | otherwise = transClosureFV new_fv_list + | otherwise = transClosureFV (listToUFM new_fv_list) where - env = listToUFM fv_list - (no_change, new_fv_list) = mapAccumL bump True fv_list + (no_change, new_fv_list) = mapAccumL bump True (ufmToList env) bump no_change (b,fvs) | no_change_here = (no_change, (b,fvs)) | otherwise = (False, (b,new_fvs)) @@ -1343,17 +1426,21 @@ transClosureFV fv_list (new_fvs, no_change_here) = extendFvs env fvs ------------- +extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) -- (extendFVs env s) returns -- (s `union` env(s), env(s) `subset` s) extendFvs env s - = foldVarSet add (s, True) s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) where - add v (vs, no_change_so_far) - = case lookupUFM env v of - Just fvs | not (fvs `subVarSet` s) - -> (vs `unionVarSet` fvs, False) - _ -> (vs, no_change_so_far) + extras :: VarSet -- env(s) + extras = foldUFM unionVarSet emptyVarSet $ + intersectUFM_C (\x _ -> x) env s \end{code} @@ -1777,12 +1864,15 @@ setBinderOcc usage bndr \begin{code} mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails mkOneOcc env id int_cxt - | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) + | isLocalId id + = unitVarEnv id (OneOcc False True int_cxt) + | PE env _ <- occ_proxy env - , id `elemVarEnv` env = unitVarEnv id NoOccInfo - | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id) - = uds - | otherwise = emptyDetails + , id `elemVarEnv` env + = unitVarEnv id NoOccInfo + + | otherwise + = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 21dca615c3..618bf35ab9 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -46,7 +46,8 @@ module SetLevels ( setLevels, Level(..), tOP_LEVEL, - LevelledBind, LevelledExpr, + LevelledBind, LevelledExpr, LevelledBndr, + FloatSpec(..), floatSpecLevel, incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where @@ -55,11 +56,11 @@ module SetLevels ( import CoreSyn import CoreMonad ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, mkPiTypes ) +import CoreUtils ( exprType, exprOkForSpeculation, mkPiTypes ) import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it -import CoreSubst ( Subst, emptySubst, extendInScope, extendInScopeList, - extendIdSubst, cloneIdBndr, cloneRecIdBndrs ) +import CoreSubst ( Subst, emptySubst, extendInScope, substBndr, substRecBndrs, + extendIdSubst, cloneBndrs, cloneIdBndr, cloneRecIdBndrs ) import Id import IdInfo import Var @@ -69,7 +70,7 @@ import Demand ( StrictSig, increaseStrictSigArity ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) import Type ( isUnLiftedType, Type ) -import BasicTypes ( TopLevelFlag(..), Arity ) +import BasicTypes ( Arity ) import UniqSupply import Util import Outputable @@ -83,9 +84,23 @@ import FastString %************************************************************************ \begin{code} +type LevelledExpr = TaggedExpr FloatSpec +type LevelledBind = TaggedBind FloatSpec +type LevelledBndr = TaggedBndr FloatSpec + data Level = Level Int -- Level number of enclosing lambdas Int -- Number of big-lambda and/or case expressions between -- here and the nearest enclosing lambda + +data FloatSpec + = FloatMe Level -- Float to just inside the binding + -- tagged with this level + | StayPut Level -- Stay where it is; binding is + -- tagged with tihs level + +floatSpecLevel :: FloatSpec -> Level +floatSpecLevel (FloatMe l) = l +floatSpecLevel (StayPut l) = l \end{code} The {\em level number} on a (type-)lambda-bound variable is the @@ -143,8 +158,9 @@ inlined into the floated expression, and an importing module won't see the worker at all. \begin{code} -type LevelledExpr = TaggedExpr Level -type LevelledBind = TaggedBind Level +instance Outputable FloatSpec where + ppr (FloatMe l) = char 'F' <> ppr l + ppr (StayPut l) = ppr l tOP_LEVEL :: Level tOP_LEVEL = Level 0 0 @@ -205,12 +221,18 @@ setLevels float_lams binds us ; return (lvld_bind : lvld_binds) } lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) -lvlTopBind env (NonRec binder rhs) - = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs)) - -- Rhs can have no free vars! +lvlTopBind env (NonRec bndr rhs) + = do rhs' <- lvlExpr tOP_LEVEL env (freeVars rhs) + let bndr' = TB bndr (StayPut tOP_LEVEL) + env' = extendLvlEnv env [bndr'] + return (NonRec bndr' rhs', env') lvlTopBind env (Rec pairs) - = lvlBind TopLevel tOP_LEVEL env (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs]) + = do let (bndrs,rhss) = unzip pairs + bndrs' = [TB b (StayPut tOP_LEVEL) | b <- bndrs] + env' = extendLvlEnv env bndrs' + rhss' <- mapM (lvlExpr tOP_LEVEL env' . freeVars) rhss + return (Rec (bndrs' `zip` rhss'), env') \end{code} %************************************************************************ @@ -313,41 +335,42 @@ lvlExpr ctxt_lvl env expr@(_, AnnLam {}) = do -- but not nearly so much now non-recursive newtypes are transparent. -- [See SetLevels rev 1.50 for a version with this approach.] -lvlExpr ctxt_lvl env (_, AnnLet (AnnNonRec bndr rhs) body) - | isUnLiftedType (idType bndr) = do - -- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e) - -- That is, leave it exactly where it is - -- We used to float unlifted bindings too (e.g. to get a cheap primop - -- outside a lambda (to see how, look at lvlBind in rev 1.58) - -- but an unrelated change meant that these unlifed bindings - -- could get to the top level which is bad. And there's not much point; - -- unlifted bindings are always cheap, and so hardly worth floating. - rhs' <- lvlExpr ctxt_lvl env rhs - body' <- lvlExpr incd_lvl env' body - return (Let (NonRec bndr' rhs') body') - where - incd_lvl = incMinorLvl ctxt_lvl - bndr' = TB bndr incd_lvl - env' = extendLvlEnv env [bndr'] - lvlExpr ctxt_lvl env (_, AnnLet bind body) = do - (bind', new_env) <- lvlBind NotTopLevel ctxt_lvl env bind - body' <- lvlExpr ctxt_lvl new_env body + (bind', new_lvl, new_env) <- lvlBind ctxt_lvl env bind + body' <- lvlExpr new_lvl new_env body return (Let bind' body') -lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do - expr' <- lvlMFE True ctxt_lvl env expr - let alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl - alts' <- mapM (lvl_alt alts_env) alts - return (Case expr' (TB case_bndr incd_lvl) ty alts') +lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) + | [(con@(DataAlt {}), bs, rhs)] <- alts + , exprOkForSpeculation (deAnnotate scrut) + , not (isTopLvl dest_lvl) -- Can't have top-level cases + = -- Float the case + do { scrut' <- lvlMFE True ctxt_lvl env scrut + ; (rhs_env, (case_bndr':bs')) <- cloneVars env (case_bndr:bs) dest_lvl + -- We don't need to use extendCaseBndrLvlEnv here + -- because we are floating the case outwards so + -- no need to do the binder-swap thing + ; rhs' <- lvlMFE True ctxt_lvl rhs_env rhs + ; let alt' = (con, [TB b (StayPut dest_lvl) | b <- bs'], rhs') + ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) } + + | otherwise -- Stays put + = do { scrut' <- lvlMFE True ctxt_lvl env scrut + ; let case_bndr' = TB case_bndr bndr_spec + alts_env = extendCaseBndrLvlEnv env scrut' case_bndr' + ; alts' <- mapM (lvl_alt alts_env) alts + ; return (Case scrut' case_bndr' ty alts') } where incd_lvl = incMinorLvl ctxt_lvl + bndr_spec = StayPut incd_lvl + dest_lvl = maxFvLevel (const True) env scrut_fvs + -- Don't abstact over type variables, hence const True - lvl_alt alts_env (con, bs, rhs) = do - rhs' <- lvlMFE True incd_lvl new_env rhs - return (con, bs', rhs') + lvl_alt alts_env (con, bs, rhs) + = do { rhs' <- lvlMFE True incd_lvl new_env rhs + ; return (con, bs', rhs') } where - bs' = [ TB b incd_lvl | b <- bs ] + bs' = [ TB b bndr_spec | b <- bs ] new_env = extendLvlEnv alts_env bs' \end{code} @@ -428,14 +451,14 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) -- This includes coercions, which we don't -- want to float anyway || notWorthFloating ann_expr abs_vars - || not good_destination + || not float_me = -- Don't float it out lvlExpr ctxt_lvl env ann_expr | otherwise -- Float it out! = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr var <- newLvlVar abs_vars ty mb_bot - return (Let (NonRec (TB var dest_lvl) expr') + return (Let (NonRec (TB var (FloatMe dest_lvl)) expr') (mkVarApps (Var var) abs_vars)) where expr = deAnnotate ann_expr @@ -446,16 +469,13 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. - good_destination - | dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda - = True - -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl - -- see Note [Escaping a value lambda] - - | otherwise -- Does not escape a value lambda - = isTopLvl dest_lvl -- Only float if we are going to the top level - && floatConsts env -- and the floatConsts flag is on - && not strict_ctxt -- Don't float from a strict context + float_me = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda + -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl + -- see Note [Escaping a value lambda] + + || (isTopLvl dest_lvl -- Only float if we are going to the top level + && floatConsts env -- and the floatConsts flag is on + && not strict_ctxt) -- Don't float from a strict context -- We are keen to float something to the top level, even if it does not -- escape a lambda, because then it needs no allocation. But it's controlled -- by a flag, because doing this too early loses opportunities for RULES @@ -465,9 +485,12 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) -- Beware: -- concat = /\ a -> foldr ..a.. (++) [] -- was getting turned into - -- concat = /\ a -> lvl a -- lvl = /\ a -> foldr ..a.. (++) [] + -- concat = /\ a -> lvl a -- which is pretty stupid. Hence the strict_ctxt test + -- + -- Also a strict contxt includes uboxed values, and they + -- can't be bound at top level annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id annotateBotStr id Nothing = id @@ -560,30 +583,39 @@ OLD comment was: The binding stuff works for top level too. \begin{code} -lvlBind :: TopLevelFlag -- Used solely to decide whether to clone - -> Level -- Context level; might be Top even for bindings nested in the RHS - -- of a top level binding +lvlBind :: Level -- Context level; might be Top even for bindings + -- nested in the RHS of a top level binding -> LevelEnv -> CoreBindWithFVs - -> LvlM (LevelledBind, LevelEnv) - -lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | isTyVar bndr -- Don't do anything for TyVar binders - -- (simplifier gets rid of them pronto) - = do rhs' <- lvlExpr ctxt_lvl env rhs - return (NonRec (TB bndr ctxt_lvl) rhs', env) - + -> LvlM (LevelledBind, Level, LevelEnv) + +lvlBind ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) + || not (profitableFloat ctxt_lvl dest_lvl) + || (isTopLvl dest_lvl && isUnLiftedType (idType bndr)) + -- We can't float an unlifted binding to top level, so we don't + -- float it at all. It's a bit brutal, but unlifted bindings + -- aren't expensive either + = -- No float + do rhs' <- lvlExpr ctxt_lvl env rhs + let (env', bndr') = substLetBndrNonRec env bndr bind_lvl + bind_lvl = incMinorLvl ctxt_lvl + tagged_bndr = TB bndr' (StayPut bind_lvl) + return (NonRec tagged_bndr rhs', bind_lvl, env') + + -- Otherwise we are going to float | null abs_vars = do -- No type abstraction; clone existing binder rhs' <- lvlExpr dest_lvl env rhs - (env', bndr') <- cloneVar top_lvl env bndr ctxt_lvl dest_lvl - return (NonRec (TB bndr' dest_lvl) rhs', env') + (env', bndr') <- cloneVar env bndr dest_lvl + return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', ctxt_lvl, env') | otherwise = do -- Yes, type abstraction; create a new binder, extend substitution, etc rhs' <- lvlFloatRhs abs_vars dest_lvl env rhs (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr_w_str] - return (NonRec (TB bndr' dest_lvl) rhs', env') + return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', ctxt_lvl, env') where bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr @@ -591,15 +623,21 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) dest_lvl = destLevel env bind_fvs (isFunction rhs) mb_bot mb_bot = exprBotStrictness_maybe (deAnnotate rhs) bndr_w_str = annotateBotStr bndr mb_bot -\end{code} +lvlBind ctxt_lvl env (AnnRec pairs) + | not (profitableFloat ctxt_lvl dest_lvl) + = do let bind_lvl = incMinorLvl ctxt_lvl + (env', bndrs') = substLetBndrsRec env bndrs bind_lvl + tagged_bndrs = [ TB bndr' (StayPut bind_lvl) + | bndr' <- bndrs' ] + rhss' <- mapM (lvlExpr bind_lvl env') rhss + return (Rec (tagged_bndrs `zip` rhss'), bind_lvl, env') -\begin{code} -lvlBind top_lvl ctxt_lvl env (AnnRec pairs) | null abs_vars - = do (new_env, new_bndrs) <- cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl + = do (new_env, new_bndrs) <- cloneRecVars env bndrs dest_lvl new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss - return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env) + return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , ctxt_lvl, new_env) -- ToDo: when enabling the floatLambda stuff, -- I think we want to stop doing this @@ -618,42 +656,50 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs) (bndr,rhs) = head pairs (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars rhs_env = extendLvlEnv env abs_vars_w_lvls - (rhs_env', new_bndr) <- cloneVar NotTopLevel rhs_env bndr rhs_lvl rhs_lvl + (rhs_env', new_bndr) <- cloneVar rhs_env bndr rhs_lvl let (lam_bndrs, rhs_body) = collectAnnBndrs rhs (body_lvl, new_lam_bndrs) = lvlLamBndrs rhs_lvl lam_bndrs body_env = extendLvlEnv rhs_env' new_lam_bndrs new_rhs_body <- lvlExpr body_lvl body_env rhs_body (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] - return (Rec [(TB poly_bndr dest_lvl, - mkLams abs_vars_w_lvls $ - mkLams new_lam_bndrs $ - Let (Rec [(TB new_bndr rhs_lvl, mkLams new_lam_bndrs new_rhs_body)]) - (mkVarApps (Var new_bndr) lam_bndrs))], - poly_env) + return (Rec [(TB poly_bndr (FloatMe dest_lvl) + , mkLams abs_vars_w_lvls $ + mkLams new_lam_bndrs $ + Let (Rec [( TB new_bndr (StayPut rhs_lvl) + , mkLams new_lam_bndrs new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs))] + , ctxt_lvl + , poly_env) | otherwise = do -- Non-null abs_vars (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs new_rhss <- mapM (lvlFloatRhs abs_vars dest_lvl new_env) rhss - return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env) + return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , ctxt_lvl, new_env) where (bndrs,rhss) = unzip pairs -- Finding the free vars of the binding group is annoying - bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs - | (bndr, (rhs_fvs,_)) <- pairs]) - `minusVarSet` - mkVarSet bndrs + bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs + | (bndr, (rhs_fvs,_)) <- pairs]) + `minusVarSet` + mkVarSet bndrs dest_lvl = destLevel env bind_fvs (all isFunction rhss) Nothing abs_vars = abstractVars dest_lvl env bind_fvs +profitableFloat :: Level -> Level -> Bool +profitableFloat ctxt_lvl dest_lvl + = (dest_lvl `ltMajLvl` ctxt_lvl) -- Escapes a value lambda + || isTopLvl dest_lvl -- Going all the way to top level + ---------------------------------------------------- -- Three help functions for the type-abstraction case lvlFloatRhs :: [CoreBndr] -> Level -> LevelEnv -> CoreExprWithFVs - -> UniqSM (Expr (TaggedBndr Level)) + -> UniqSM (Expr LevelledBndr) lvlFloatRhs abs_vars dest_lvl env rhs = do rhs' <- lvlExpr rhs_lvl rhs_env rhs return (mkLams abs_vars_w_lvls rhs') @@ -670,7 +716,7 @@ lvlFloatRhs abs_vars dest_lvl env rhs = do %************************************************************************ \begin{code} -lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [TaggedBndr Level]) +lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [LevelledBndr]) -- Compute the levels for the binders of a lambda group -- The binders returned are exactly the same as the ones passed, -- but they are now paired with a level @@ -678,7 +724,7 @@ lvlLamBndrs lvl [] = (lvl, []) lvlLamBndrs lvl bndrs - = (new_lvl, [TB bndr new_lvl | bndr <- bndrs]) + = (new_lvl, [TB bndr (StayPut new_lvl) | bndr <- bndrs]) -- All the new binders get the same level, because -- any floating binding is either going to float past -- all or none. We never separate binders @@ -701,8 +747,9 @@ destLevel env fvs is_function mb_bot , is_function , countFreeIds fvs <= n_args = tOP_LEVEL -- Send functions to top level; see - -- the comments with isFunction - | otherwise = maxIdLevel env fvs + -- the comments with isFunction + | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars + -- will be abstracted isFunction :: CoreExprWithFVs -> Bool -- The idea here is that we want to float *functions* to @@ -782,7 +829,7 @@ floatConsts le = floatOutConstants (le_switches le) floatPAPs :: LevelEnv -> Bool floatPAPs le = floatOutPartialApplications (le_switches le) -extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv +extendLvlEnv :: LevelEnv -> [LevelledBndr] -> LevelEnv -- Used when *not* cloning extendLvlEnv le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) prs @@ -790,7 +837,7 @@ extendLvlEnv le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) , le_subst = foldl del_subst subst prs , le_env = foldl del_id id_env prs } where - add_lvl env (TB v l) = extendVarEnv env v l + add_lvl env (TB v s) = extendVarEnv env v (floatSpecLevel s) del_subst env (TB v _) = extendInScope env v del_id env (TB v _) = delVarEnv env v -- We must remove any clone for this variable name in case of @@ -807,26 +854,17 @@ extendLvlEnv le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) -- incorrectly, because the SubstEnv was still lying around. Ouch! -- KSW 2000-07. -extendInScopeEnv :: LevelEnv -> Var -> LevelEnv -extendInScopeEnv le@(LE { le_subst = subst }) v - = le { le_subst = extendInScope subst v } - -extendInScopeEnvList :: LevelEnv -> [Var] -> LevelEnv -extendInScopeEnvList le@(LE { le_subst = subst }) vs - = le { le_subst = extendInScopeList subst vs } - -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can -- (see point 4 of the module overview comment) -extendCaseBndrLvlEnv :: LevelEnv -> Expr (TaggedBndr Level) -> Var -> Level - -> LevelEnv -extendCaseBndrLvlEnv le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) - (Var scrut_var) case_bndr lvl - = le { le_lvl_env = extendVarEnv lvl_env case_bndr lvl - , le_subst = extendIdSubst subst case_bndr (Var scrut_var) +extendCaseBndrLvlEnv :: LevelEnv -> Expr LevelledBndr + -> LevelledBndr -> LevelEnv +extendCaseBndrLvlEnv le@(LE { le_subst = subst, le_env = id_env }) + (Var scrut_var) (TB case_bndr _) + = le { le_subst = extendIdSubst subst case_bndr (Var scrut_var) , le_env = extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var) } -extendCaseBndrLvlEnv env _scrut case_bndr lvl - = extendLvlEnv env [TB case_bndr lvl] +extendCaseBndrLvlEnv env _scrut case_bndr + = extendLvlEnv env [case_bndr] extendPolyLvlEnv :: Level -> LevelEnv -> [Var] -> [(Var, Var)] -> LevelEnv extendPolyLvlEnv dest_lvl @@ -843,26 +881,27 @@ extendPolyLvlEnv dest_lvl extendCloneLvlEnv :: Level -> LevelEnv -> Subst -> [(Var, Var)] -> LevelEnv extendCloneLvlEnv lvl le@(LE { le_lvl_env = lvl_env, le_env = id_env }) new_subst bndr_pairs - = le { le_lvl_env = foldl add_lvl lvl_env bndr_pairs + = le { le_lvl_env = foldl add_lvl lvl_env bndr_pairs , le_subst = new_subst - , le_env = foldl add_id id_env bndr_pairs } + , le_env = foldl add_id id_env bndr_pairs } where add_lvl env (_, v') = extendVarEnv env v' lvl add_id env (v, v') = extendVarEnv env v ([v'], Var v') -maxIdLevel :: LevelEnv -> VarSet -> Level -maxIdLevel (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set +maxFvLevel :: (Var -> Bool) -> LevelEnv -> VarSet -> Level +maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set = foldVarSet max_in tOP_LEVEL var_set where - max_in in_var lvl = foldr max_out lvl (case lookupVarEnv id_env in_var of - Just (abs_vars, _) -> abs_vars - Nothing -> [in_var]) + max_in in_var lvl + = foldr max_out lvl (case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> abs_vars + Nothing -> [in_var]) max_out out_var lvl - | isId out_var = case lookupVarEnv lvl_env out_var of + | max_me out_var = case lookupVarEnv lvl_env out_var of Just lvl' -> maxLvl lvl' lvl Nothing -> lvl - | otherwise = lvl -- Ignore tyvars in *maxIdLevel* + | otherwise = lvl -- Ignore some vars depending on max_me lookupVar :: LevelEnv -> Id -> LevelledExpr lookupVar le v = case lookupVarEnv (le_env le) v of @@ -967,39 +1006,70 @@ newLvlVar vars body_ty mb_bot -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. -cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id) -cloneVar TopLevel env v _ _ - = return (extendInScopeEnv env v, v) -- Don't clone top level things - -- But do extend the in-scope env, to satisfy the in-scope invariant +substLetBndrNonRec :: LevelEnv -> Id -> Level -> (LevelEnv, Id) +substLetBndrNonRec + le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + bndr bind_lvl + = ASSERT( isId bndr ) + (env', bndr' ) + where + (subst', bndr') = substBndr subst bndr + env' = le { le_lvl_env = extendVarEnv lvl_env bndr bind_lvl + , le_subst = subst' + , le_env = delVarEnv id_env bndr } + +substLetBndrsRec :: LevelEnv -> [Id] -> Level -> (LevelEnv, [Id]) +substLetBndrsRec + le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + bndrs bind_lvl + = ASSERT( all isId bndrs ) + (env', bndrs') + where + (subst', bndrs') = substRecBndrs subst bndrs + env' = le { le_lvl_env = extendVarEnvList lvl_env [(b,bind_lvl) | b <- bndrs] + , le_subst = subst' + , le_env = delVarEnvList id_env bndrs } + +cloneVar :: LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id) +cloneVar env v dest_lvl + = ASSERT( isId v ) + do { us <- getUniqueSupplyM + ; let (subst', v1) = cloneIdBndr (le_subst env) us v + v2 = zapDemandIdInfo v1 + env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] + ; return (env', v2) } + +cloneVars :: LevelEnv -> [Var] -> Level -> LvlM (LevelEnv, [Var]) +cloneVars env vs dest_lvl -- Works for tyvars etc too; typically case alts + = do { us <- getUniqueSupplyM + ; let (subst', vs1) = cloneBndrs (le_subst env) us vs + vs2 = map zap_demand vs1 + env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) + ; return (env', vs2) } + where + zap_demand :: Var -> Var -- Note [Zapping the demand info] + zap_demand v | not (isId v) = v + | otherwise = zapDemandIdInfo v -cloneVar NotTopLevel env v ctxt_lvl dest_lvl - = ASSERT( isId v ) do - us <- getUniqueSupplyM - let - (subst', v1) = cloneIdBndr (le_subst env) us v - v2 = zap_demand ctxt_lvl dest_lvl v1 - env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] - return (env', v2) - -cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) -cloneRecVars TopLevel env vs _ _ - = return (extendInScopeEnvList env vs, vs) -- Don't clone top level things -cloneRecVars NotTopLevel env vs ctxt_lvl dest_lvl + +cloneRecVars :: LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id]) +cloneRecVars env vs dest_lvl = ASSERT( all isId vs ) do us <- getUniqueSupplyM let (subst', vs1) = cloneRecIdBndrs (le_subst env) us vs - vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1 + vs2 = map zapDemandIdInfo vs1 -- Note [Zapping the demand info] env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) return (env', vs2) - - -- VERY IMPORTANT: we must zap the demand info - -- if the thing is going to float out past a lambda, - -- or if it's going to top level (where things can't be strict) -zap_demand :: Level -> Level -> Id -> Id -zap_demand dest_lvl ctxt_lvl id - | ctxt_lvl == dest_lvl, - not (isTopLvl dest_lvl) = id -- Stays, and not going to top level - | otherwise = zapDemandIdInfo id -- Floats out \end{code} + +Note [Zapping the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +VERY IMPORTANT: we must zap the demand info if the thing is going to +float out, becuause it may be less demanded than at its original +binding site. Eg + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict; but if we float v to top level, it isn't any more. + diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 34ffacb208..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} %* * %************************************************************************ @@ -579,7 +535,8 @@ simplifyPgmIO :: CoreToDo simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) hsc_env us hpt_rule_base - guts@(ModGuts { mg_binds = binds, mg_rules = rules + guts@(ModGuts { mg_module = this_mod + , mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration us 1 [] binds rules @@ -596,7 +553,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) dflags = hsc_dflags hsc_env dump_phase = dumpSimplPhase dflags mode simpl_env = mkSimplEnv mode - active_rule = activeRule dflags simpl_env + active_rule = activeRule simpl_env do_iteration :: UniqSupply -> Int -- Counts iterations @@ -634,7 +591,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) InitialPhase -> mg_vect_decls guts _ -> [] ; tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm active_rule rules maybeVects binds + occurAnalysePgm this_mod active_rule rules maybeVects binds } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); @@ -706,13 +663,18 @@ simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" ------------------- end_iteration :: DynFlags -> CoreToDo -> Int -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () --- Same as endIteration but with simplifier counts end_iteration dflags pass iteration_no counts binds rules - = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags) - pass (ptext (sLit "Simplifier counts")) - (pprSimplCount counts) - - ; endIteration dflags pass iteration_no binds rules } + = do { dumpPassResult dflags mb_flag hdr pp_counts binds rules + ; lintPassResult dflags pass binds } + where + mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no + pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr + , pprSimplCount counts + , ptext (sLit "---- End of simplifier counts for") <+> hdr ] \end{code} diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 677a1e9d02..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 @@ -498,7 +498,7 @@ Note [Global Ids in the substitution] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We look up even a global (eg imported) Id in the substitution. Consider case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } -The binder-swap in the occurence analyser will add a binding +The binder-swap in the occurrence analyser will add a binding for a LocalId version of g (with the same unique though): case X.g_34 of b { (a,b) -> let g_34 = b in ... case X.g_34 of { (p,q) -> ...} ... } diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 7d5d764fc6..dd0ce4b4e1 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -669,11 +669,11 @@ active_unfolding_gentle id prag = idInlinePragma id ---------------------- -activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool) +activeRule :: SimplEnv -> Activation -> Bool -- Nothing => No rules at all -activeRule _dflags env - | not (sm_rules mode) = Nothing -- Rewriting is off - | otherwise = Just (isActive (sm_phase mode)) +activeRule env + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) where mode = getMode env \end{code} @@ -906,7 +906,7 @@ postInlineUnconditionally -> Bool postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding | not active = False - | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" | isExportedId bndr = False | isStableUnfolding unfolding = False -- Note [InlineRule and postInlineUnconditionally] @@ -1000,6 +1000,7 @@ ones that are trivial): * There is less point, because the main goal is to get rid of local bindings used in multiple case branches. + * The inliner should inline trivial things at call sites anyway. Note [InlineRule and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1117,17 +1118,20 @@ tryEtaExpand env bndr rhs return (new_arity, new_rhs) } where try_expand dflags + | exprIsTrivial rhs + = return (exprArity rhs, rhs) + | sm_eta_expand (getMode env) -- Provided eta-expansion is on - , not (exprIsTrivial rhs) , let dicts_cheap = dopt Opt_DictsCheap dflags new_arity = findArity dicts_cheap bndr rhs old_arity - , new_arity > rhs_arity + , new_arity > manifest_arity -- And the curent manifest arity isn't enough + -- See Note [Eta expansion to manifes arity] = do { tick (EtaExpansion bndr) ; return (new_arity, etaExpand new_arity rhs) } | otherwise - = return (rhs_arity, rhs) + = return (manifest_arity, rhs) - rhs_arity = exprArity rhs + manifest_arity = manifestArity rhs old_arity = idArity bndr _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr @@ -1216,6 +1220,23 @@ because then 'genMap' will inline, and it really shouldn't: at least as far as the programmer is concerned, it's not applied to two arguments! +Note [Eta expansion to manifest arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Eta expansion does *not* eta-expand trivial RHSs, like + x = y +because these will get substituted out in short order. (Indeed +we *eta-contract* if that yields a trivial RHS.) + +Otherwise we eta-expand to produce enough manifest lambdas. +This *does* eta-expand partial applications. eg + x = map g --> x = \v -> map g v + y = \_ -> map g --> y = \_ v -> map g v +One benefit this is that in the definition of y there was +a danger that full laziness would transform to + lvl = map g + y = \_ -> lvl +which is stupid. This doesn't happen in the eta-expanded form. + Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~ The motivating example for arity analysis is this: diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index b187897f89..adcaf13133 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -212,6 +212,7 @@ simplTopBinds env0 binds0 -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. + -- See note [Glomming] in OccurAnal. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) ; dflags <- getDOptsSmpl ; let dump_flag = dopt Opt_D_verbose_core2core dflags @@ -707,7 +708,7 @@ simplUnfolding :: SimplEnv-> TopLevelFlag simplUnfolding env _ _ _ (DFunUnfolding ar con ops) = return (DFunUnfolding ar con ops') where - ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops + ops' = map (substExpr (text "simplUnfolding") env) ops simplUnfolding env top_lvl id _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity @@ -876,7 +877,15 @@ simplExprF :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) simplExprF env e cont - = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + {- , ppr (seFloats env) -} + ]) $ -} simplExprF1 env e cont simplExprF1 :: SimplEnv -> InExpr -> SimplCont @@ -1009,7 +1018,8 @@ simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM (SimplEnv, OutExpr) simplCast env body co0 cont0 = do { co1 <- simplCoercion env co0 - ; simplExprF env body (addCoerce co1 cont0) } + ; -- pprTrace "simplCast" (ppr co1) $ + simplExprF env body (addCoerce co1 cont0) } where addCoerce co cont = add_coerce co (coercionKind co) cont @@ -1082,7 +1092,8 @@ simplCast env body co0 cont0 -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co new_arg = mkCoerce (mkSymCo co1) arg' - arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg + arg' = substExpr (text "move-cast") arg_se' arg + arg_se' = arg_se `setInScope` env add_coerce co _ cont = CoerceIt co cont \end{code} @@ -1411,17 +1422,15 @@ tryRules env rules fn args call_cont | null rules = return Nothing | otherwise - = do { dflags <- getDOptsSmpl - ; case activeRule dflags env of { - Nothing -> return Nothing ; -- No rules apply - Just act_fn -> - case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of { + = do { case lookupRule (activeRule env) (getUnfoldingInRuleMatch env) + (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> do { tick (RuleFired (ru_name rule)) + ; dflags <- getDOptsSmpl ; trace_dump dflags rule rule_rhs $ - return (Just (ruleArity rule, rule_rhs)) }}}} + return (Just (ruleArity rule, rule_rhs)) }}} where trace_dump dflags rule rule_rhs stuff | not (dopt Opt_D_dump_rule_firings dflags) diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index c192b3f60a..7cd493400f 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -1138,6 +1138,9 @@ specCalls subst rules_for_me calls_for_me fn rhs -- Add a suitable unfolding if the spec_inl_prag says so -- See Note [Inline specialisations] spec_inl_prag + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal + | otherwise = case inl_prag of InlinePragma { inl_inline = Inlinable } -> inl_prag { inl_inline = EmptyInlineSpec } 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/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 391c07c089..1b8b270024 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -449,7 +449,7 @@ mkWWcpr body_ty RetCPR uniqs <- getUniquesM let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) - arg_vars = map Var args + arg_vars = varsToCoreExprs args ubx_tup_con = tupleCon Unboxed n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 33254c1b5a..ce40f56e24 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -1216,7 +1216,7 @@ checkStrictBinds top_lvl rec_group binds poly_ids -- This should be a checkTc, not a warnTc, but as of GHC 6.11 -- the versions of alex and happy available have non-conforming -- templates, so the GHC build fails if it's an error: - ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings + ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings ; warnTc (warnUnlifted && not bang_pat && lifted_pat) -- No outer bang, but it's a compound pattern -- E.g (I# x#) = blah diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 45d54123ef..7bc5d8c2e5 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -374,7 +374,7 @@ renameDeriv is_boot gen_binds insts | otherwise = discardWarnings $ -- Discard warnings about unused bindings etc - do { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns + do { (rn_gen, dus_gen) <- setXOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns -- are used in the generic binds rnTopBinds (ValBindsIn gen_binds []) ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive @@ -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/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 96dc2614e3..52096b6948 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -60,12 +60,10 @@ import TcType import TcIface import PrelNames import TysWiredIn --- import qualified Type import Id import Coercion import Var import VarSet --- import VarEnv import RdrName import InstEnv import FamInstEnv diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 31bd7214fd..7ed7145863 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -29,6 +29,7 @@ import VarEnv import SrcLoc import Bag import ListSetOps( equivClasses ) +import Maybes( mapCatMaybes ) import Util import FastString import Outputable @@ -122,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. @@ -137,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 @@ -216,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) @@ -555,13 +554,8 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ; case lookupInstEnv inst_envs clas tys_flat of ([], _, _) -> return (Just pred) -- No match - -- The case of exactly one match and no unifiers means a - -- successful lookup. That can't happen here, because dicts - -- only end up here if they didn't match in Inst.lookupInst - ([_],[], _) - | debugIsOn -> pprPanic "check_overlap" (ppr pred) - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return Nothing } } + res -> do { addErrorReport ctxt (mk_overlap_msg res) + ; return Nothing } } where -- Normal overlap error mk_overlap_msg (matches, unifiers, False) @@ -571,25 +565,29 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] - , if not (null overlapping_givens) then - sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)] + , if not (null matching_givens) then + sep [ptext (sLit "Matching givens (or their superclasses)") <> colon + , nest 2 (vcat matching_givens)] else empty - , if null overlapping_givens && isSingleton matches && null unifiers then - -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities) - -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten - -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem. - sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))] + , if null matching_givens && isSingleton matches && null unifiers then + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon + , nest 2 (vcat (pp_givens givens))] else empty , if not (isSingleton matches) then -- Two or more matches empty - else -- One match, plus some unifiers - ASSERT( not (null unifiers) ) + else -- One match parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), - if null (overlapping_givens) then + if null (matching_givens) then vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), ptext (sLit "when compiling the other instance declarations")] else empty])] @@ -597,15 +595,8 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ispecs = [ispec | (ispec, _) <- matches] givens = getUserGivens ctxt - overlapping_givens = unifiable_givens givens - - unifiable_givens [] = [] - unifiable_givens (gg:ggs) - | Just ggdoc <- matchable gg - = ggdoc : unifiable_givens ggs - | otherwise - = unifiable_givens ggs - + matching_givens = mapCatMaybes matchable givens + matchable (evvars,gloc) = case ev_vars_matching of [] -> Nothing @@ -621,7 +612,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) any ev_var_matches (immSuperClasses clas' tys') ev_var_matches _ = False - -- Overlap error because of SafeHaskell (first match should be the most + -- Overlap error because of Safe Haskell (first match should be the most -- specific match) mk_overlap_msg (matches, _unifiers, True) = ASSERT( length matches > 1 ) @@ -691,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] + mono_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 :: 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 @@ -818,7 +808,7 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) warnDefaulting :: [FlavoredEvVar] -> Type -> TcM () warnDefaulting wanteds default_ty - = do { warn_default <- doptM Opt_WarnTypeDefaults + = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let wanted_bag = listToBag wanteds tidy_env = tidyFreeTyVars env0 $ diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index ee6a34ac06..29a4756171 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1050,22 +1050,6 @@ Here's a concrete example that does this (test tc200): Current solution: only do the "method sharing" thing for the first type/dict application, not for the iterated ones. A horribly subtle point. -Note [No method sharing] -~~~~~~~~~~~~~~~~~~~~~~~~ -The -fno-method-sharing flag controls what happens so far as the LIE -is concerned. The default case is that for an overloaded function we -generate a "method" Id, and add the Method Inst to the LIE. So you get -something like - f :: Num a => a -> a - f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x -If you specify -fno-method-sharing, the dictionary application -isn't shared, so we get - f :: Num a => a -> a - f = /\a (d:Num a) (x:a) -> (+) a d x x -This gets a bit less sharing, but - a) it's better for RULEs involving overloaded functions - b) perhaps fewer separated lambdas - \begin{code} doStupidChecks :: TcId -> [TcType] @@ -1337,7 +1321,7 @@ checkMissingFields data_con rbinds unless (null missing_s_fields) (addErrTc (missingStrictFields data_con missing_s_fields)) - warn <- doptM Opt_WarnMissingFields + warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields)) diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index a24eb47b9d..ba3feef2f0 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -88,15 +88,14 @@ tcFImport d = pprPanic "tcFImport" (ppr d) \begin{code} tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) = ASSERT( null arg_tys ) do { checkCg checkCOrAsmOrLlvmOrInterp - ; checkSafety safety ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty) ; return idecl } -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well @@ -104,7 +103,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do -- is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok False isFFIExportResultTy res1_ty @@ -118,7 +116,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) @@ -149,7 +146,6 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCConv cconv - checkSafety safety checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys @@ -173,7 +169,7 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && - dopt Opt_WarnDodgyForeignImports dflags + wopt Opt_WarnDodgyForeignImports dflags = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) | otherwise = return () @@ -323,14 +319,6 @@ checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} -Deprecated "threadsafe" calls - -\begin{code} -checkSafety :: Safety -> TcM () -checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.") -checkSafety _ = return () -\end{code} - Warnings \begin{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index e4129103fe..b7a3a50649 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -52,13 +52,17 @@ import TysWiredIn import Type import TypeRep import VarSet +import Module import State import Util import MonadUtils import Outputable import FastString import Bag -import Data.List ( partition, intersperse ) +import Fingerprint +import Constants + +import Data.List ( partition, intersperse ) \end{code} \begin{code} @@ -1161,8 +1165,9 @@ From the data type we generate - instance Typeable2 T where - typeOf2 _ = mkTyConApp (mkTyConRep "T") [] + instance Typeable2 T where + typeOf2 _ = mkTyConApp (mkTyCon <hash-high> <hash-low> + <pkg> <module> "T") [] We are passed the Typeable2 class as well as T @@ -1173,13 +1178,34 @@ gen_Typeable_binds loc tycon mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] - (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) + (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) where - tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + tycon_name = tyConName tycon + modl = nameModule tycon_name + pkg = modulePackageId modl + + modl_fs = moduleNameFS (moduleName modl) + pkg_fs = packageIdFS pkg + name_fs = occNameFS (nameOccName tycon_name) + + tycon_rep = nlHsApps mkTyCon_RDR + (map nlHsLit [int64 high, + int64 low, + HsString pkg_fs, + HsString modl_fs, + HsString name_fs]) + + hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs] + Fingerprint high low = fingerprintString hashThis + + int64 + | wORD_SIZE == 4 = HsWord64Prim . fromIntegral + | otherwise = HsWordPrim . fromIntegral + mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function -mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) +mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix)) where arity = tyConArity tycon suffix | arity == 0 = "" diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 3b4afaea48..5887fb57e2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -44,7 +44,7 @@ import NameSet import Var import VarSet import VarEnv -import DynFlags( DynFlag(..) ) +import DynFlags import Literal import BasicTypes import Maybes @@ -107,6 +107,8 @@ hsLitType (HsStringPrim _) = addrPrimTy hsLitType (HsInt _) = intTy hsLitType (HsIntPrim _) = intPrimTy hsLitType (HsWordPrim _) = wordPrimTy +hsLitType (HsInt64Prim _) = int64PrimTy +hsLitType (HsWord64Prim _) = word64PrimTy hsLitType (HsInteger _ ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim _) = floatPrimTy @@ -284,7 +286,7 @@ zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords -- Warn about missing signatures -- Do this only when we we have a type to offer - ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; warn_missing_sigs <- woptM Opt_WarnMissingSigs ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns | otherwise = noSigWarn @@ -305,7 +307,7 @@ zonkLocalBinds _ (HsValBinds (ValBindsIn {})) = panic "zonkLocalBinds" -- Not in typechecker output zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) - = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs + = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; let sig_warn | not warn_missing_sigs = noSigWarn | otherwise = localSigWarn sig_ns sig_ns = getTypeSigNames vb diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index b641d23075..a0a5a503eb 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -8,11 +8,13 @@ TcInstDecls: Typechecking instance declarations \begin{code} module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where +#include "HsVersions.h" + import HsSyn import TcBinds import TcTyClsDecls import TcClassDcl -import TcPat( addInlinePrags ) +import TcPat ( addInlinePrags ) import TcRnMonad import TcMType import TcType @@ -23,39 +25,41 @@ import FamInst import FamInstEnv import TcDeriv import TcEnv -import RnSource ( addTcgDUs ) +import RnSource ( addTcgDUs ) import TcHsType import TcUnify -import MkCore ( nO_METHOD_BINDING_ERROR_ID ) +import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import Coercion import TyCon import DataCon import Class import Var +import VarEnv ( mkInScopeSet ) +import VarSet ( mkVarSet ) import Pair -import VarSet import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) -import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr ) +import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) +import PrelNames ( typeableClassNames ) + +import Bag +import BasicTypes +import DynFlags +import FastString +import HscTypes import Id import MkId import Name import NameSet -import DynFlags +import Outputable import SrcLoc import Util -import Outputable -import Bag -import BasicTypes -import HscTypes -import FastString -import Maybes ( orElse ) -import Data.Maybe + import Control.Monad import Data.List - -#include "HsVersions.h" +import Data.Maybe +import Maybes ( orElse ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -74,73 +78,73 @@ Note [How instance declarations are translated] Here is how we translation instance declarations into Core Running example: - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = <dm-rhs> + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = <dm-rhs> - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = <rhs> + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = <rhs> ===> - -- Method selectors - op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b - op1 = ... - op2 = ... - - -- Default methods get the 'self' dictionary as argument - -- so they can call other methods at the same type - -- Default methods get the same type as their method selector - $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b - $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs> - -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs> - -- Note [Tricky type variable scoping] - - -- A top-level definition for each instance method - -- Here op1_i, op2_i are the "instance method Ids" - -- The INLINE pragma comes from the user pragma - {-# INLINE [2] op1_i #-} -- From the instance decl bindings - op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b - op1_i = /\a. \(d:C a). - let this :: C [a] - this = df_i a d - -- Note [Subtle interaction of recursion and overlap] - - local_op1 :: forall b. Ix b => [a] -> b -> b - local_op1 = <rhs> - -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in <rhs> - -- Note [Tricky type variable scoping] - - in local_op1 a d - - op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) - - -- The dictionary function itself - {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions - df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) - -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-method call + -- Method selectors + op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b + op1 = ... + op2 = ... + + -- Default methods get the 'self' dictionary as argument + -- so they can call other methods at the same type + -- Default methods get the same type as their method selector + $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b + $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs> + -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs> + -- Note [Tricky type variable scoping] + + -- A top-level definition for each instance method + -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma + {-# INLINE [2] op1_i #-} -- From the instance decl bindings + op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b + op1_i = /\a. \(d:C a). + let this :: C [a] + this = df_i a d + -- Note [Subtle interaction of recursion and overlap] + + local_op1 :: forall b. Ix b => [a] -> b -> b + local_op1 = <rhs> + -- Source code; run the type checker on this + -- NB: Type variable 'a' (but not 'b') is in scope in <rhs> + -- Note [Tricky type variable scoping] + + in local_op1 a d + + op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) + + -- The dictionary function itself + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions + df_i :: forall a. C a -> C [a] + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) + -- But see Note [Default methods in instances] + -- We can't apply the type checker to the default-method call -- Use a RULE to short-circuit applications of the class ops - {-# RULE "op1@C[a]" forall a, d:C a. + {-# RULE "op1@C[a]" forall a, d:C a. op1 [a] (df_i d) = op1_i a d #-} Note [Instances and loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * Note that df_i may be mutually recursive with both op1_i and op2_i. - It's crucial that df_i is not chosen as the loop breaker, even + It's crucial that df_i is not chosen as the loop breaker, even though op1_i has a (user-specified) INLINE pragma. * Instead the idea is to inline df_i into op1_i, which may then select methods from the MkC record, and thereby break the recursion with df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at the same type, it won't mention df_i, so there won't be recursion in - the first place.) + the first place.) * If op1_i is marked INLINE by the user there's a danger that we won't inline df_i in it, and that in turn means that (since it'll be a - loop-breaker because df_i isn't), op1_i will ironically never be + loop-breaker because df_i isn't), op1_i will ironically never be inlined. But this is OK: the recursion breaking happens by way of a RULE (the magic ClassOp rule above), and RULES work inside InlineRule unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils @@ -155,13 +159,13 @@ where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* MkD _ op2 _ _ _ -> op2 And that will reduce to ($cop2 d1 d2) which is what we wanted. -But it's tricky to make this work in practice, because it requires us to +But it's tricky to make this work in practice, because it requires us to inline both 'op2' and 'df'. But neither is keen to inline without having -seen the other's result; and it's very easy to get code bloat (from the +seen the other's result; and it's very easy to get code bloat (from the big intermediate) if you inline a bit too much. Instead we use a cunning trick. - * We arrange that 'df' and 'op2' NEVER inline. + * We arrange that 'df' and 'op2' NEVER inline. * We arrange that 'df' is ALWAYS defined in the sylised form df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... @@ -170,7 +174,7 @@ Instead we use a cunning trick. that lists its methods. * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return - a suitable constructor application -- inlining df "on the fly" as it + a suitable constructor application -- inlining df "on the fly" as it were. * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece @@ -202,7 +206,7 @@ class-op selector. MkC = /\a.\op. op |> (sym Co:C a) The clever RULE stuff doesn't work now, because ($df a d) isn't -a constructor application, so exprIsConApp_maybe won't return +a constructor application, so exprIsConApp_maybe won't return Just <blah>. Instead, we simply rely on the fact that casts are cheap: @@ -227,7 +231,7 @@ which adds an extra indirection to every use, which seems stupid. See Trac #4138 for an example (although the regression reported there wasn't due to the indirction). -There is an awkward wrinkle though: we want to be very +There is an awkward wrinkle though: we want to be very careful when we have instance C a => C [a] where {-# INLINE op #-} @@ -235,10 +239,10 @@ careful when we have then we'll get an INLINE pragma on $cop_list but it's important that $cop_list only inlines when it's applied to *two* arguments (the dictionary and the list argument). So we nust not eta-expand $df -above. We ensure that this doesn't happen by putting an INLINE +above. We ensure that this doesn't happen by putting an INLINE pragma on the dfun itself; after all, it ends up being just a cast. -There is one more dark corner to the INLINE story, even more deeply +There is one more dark corner to the INLINE story, even more deeply buried. Consider this (Trac #3772): class DeepSeq a => C a where @@ -293,9 +297,9 @@ the call of op2). If we look up in the instance environment, we find an overlap. And in *general* the right thing is to complain (see Note [Overlapping instances] in InstEnv). But in *this* case it's wrong to complain, because we just want to delegate to the op2 of this same -instance. +instance. -Why is this justified? Because we generate a (C [a]) constraint in +Why is this justified? Because we generate a (C [a]) constraint in a context in which 'a' cannot be instantiated to anything that matches other overlapping instances, or else we would not be excecuting this version of op1 in the first place. @@ -323,13 +327,13 @@ tcInstDecl2. Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our example - class C a where - op1, op2 :: Ix b => a -> b -> b - op2 = <dm-rhs> + class C a where + op1, op2 :: Ix b => a -> b -> b + op2 = <dm-rhs> - instance C a => C [a] - {-# INLINE [2] op1 #-} - op1 = <rhs> + instance C a => C [a] + {-# INLINE [2] op1 #-} + op1 = <rhs> note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is in scope in <rhs>. In particular, we must make sure that 'b' is in @@ -366,14 +370,14 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (1) Do class and family instance declarations ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $ - filter (isFamInstDecl . unLoc) tycl_decls + filter (isFamInstDecl . unLoc) tycl_decls ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls ; let { (local_info, at_tycons_s) = unzip local_info_tycons ; at_idx_tycons = concat at_tycons_s ++ idx_tycons ; implicit_things = concatMap implicitTyConThings at_idx_tycons - ; aux_binds = mkRecSelBinds at_idx_tycons } + ; aux_binds = mkRecSelBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment @@ -392,10 +396,10 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- decl, so it needs to know about all the instances possible -- NB: class instance declarations can contain derivings as -- part of associated data type declarations - failIfErrsM -- If the addInsts stuff gave any errors, don't - -- try the deriving stuff, because that may give - -- more errors still - ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) + failIfErrsM -- If the addInsts stuff gave any errors, don't + -- try the deriving stuff, because that may give + -- more errors still + ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) <- tcDeriving tycl_decls inst_decls deriv_decls -- Extend the global environment also with the generated datatypes for @@ -405,10 +409,23 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ addFamInsts deriv_ty_insts $ addInsts deriv_inst_info getGblEnv + + -- Check that if the module is compiled with -XSafe, there are no + -- hand written instances of Typeable as then unsafe casts could be + -- performed. Derivied instances are OK. + ; dflags <- getDOpts + ; when (safeLanguageOn dflags) $ + mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames) + (addErrAt (getSrcSpan $ iSpec x) typInstErr)) + local_info + ; return ( addTcgDUs gbl_env deriv_dus, deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) }}} + where + typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" + ++ " Haskell! Can only derive them" addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside @@ -427,7 +444,7 @@ tcLocalInstDecl1 :: LInstDecl Name -- -- We check for respectable instance type, and context tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) - = setSrcSpan loc $ + = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ do { is_boot <- tcIsHsBoot @@ -439,16 +456,16 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) -- Next, process any associated types. ; idx_tycons <- recoverM (return []) $ - do { idx_tycons <- checkNoErrs $ + do { idx_tycons <- checkNoErrs $ mapAndRecoverM (tcFamInstDecl NotTopLevel) ats - ; checkValidAndMissingATs clas (tyvars, inst_tys) - (zip ats idx_tycons) - ; return idx_tycons } + ; checkValidAndMissingATs clas (tyvars, inst_tys) + (zip ats idx_tycons) + ; return idx_tycons } -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) - -- Dfun location is that of instance *header* + -- Dfun location is that of instance *header* ; overlap_flag <- getOverlapFlag ; let (eq_theta,dict_theta) = partition isEqPred theta theta' = eq_theta ++ dict_theta @@ -465,7 +482,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - TyCon)] -- Core form of AT + TyCon)] -- Core form of AT -> TcM () checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this @@ -473,7 +490,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; let class_ats = map tyConName (classATs clas) defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats omitted = filterOut (`elemNameSet` defined_ats) class_ats - ; warn <- doptM Opt_WarnMissingMethods + ; warn <- woptM Opt_WarnMissingMethods ; mapM_ (warnTc warn . omittedATWarn) omitted -- Ensure that all AT indexes that correspond to class parameters @@ -504,13 +521,13 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) -- which must be type variables; and (3) variables in AT and -- instance head will be different `Name's even if their -- source lexemes are identical. - -- - -- e.g. class C a b c where - -- data D b a :: * -> * -- NB (1) b a, omits c - -- instance C [x] Bool Char where - -- data D Bool [x] v = MkD x [v] -- NB (2) v - -- -- NB (3) the x in 'instance C...' have differnt - -- -- Names to x's in 'data D...' + -- + -- e.g. class C a b c where + -- data D b a :: * -> * -- NB (1) b a, omits c + -- instance C [x] Bool Char where + -- data D Bool [x] v = MkD x [v] -- NB (2) v + -- -- NB (3) the x in 'instance C...' have differnt + -- -- Names to x's in 'data D...' -- -- Re (1), `poss' contains a permutation vector to extract the -- class parameters in the right order. @@ -527,11 +544,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) let poss :: [Int] -- For *associated* type families, gives the position -- of that 'TyVar' in the class argument list (0-indexed) - -- e.g. class C a b c where { type F c a :: *->* } - -- Then we get Just [2,0] - poss = catMaybes [ tv `elemIndex` classTyVars clas + -- e.g. class C a b c where { type F c a :: *->* } + -- Then we get Just [2,0] + poss = catMaybes [ tv `elemIndex` classTyVars clas | tv <- tyConTyVars atycon] - -- We will get Nothings for the "extra" type + -- We will get Nothings for the "extra" type -- variables in an associated data type -- e.g. class C a where { data D a :: *->* } -- here D gets arity 2 and has two tyvars @@ -566,9 +583,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) %************************************************************************ -%* * +%* * Type checking family instances -%* * +%* * %************************************************************************ Family instances are somewhat of a hybrid. They are processed together with @@ -579,20 +596,20 @@ GADTs). \begin{code} tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon tcFamInstDecl top_lvl (L loc decl) - = -- Prime error recovery, set source location - setSrcSpan loc $ - tcAddDeclCtxt decl $ + = -- Prime error recovery, set source location + setSrcSpan loc $ + tcAddDeclCtxt decl $ do { -- type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file + -- and can't (currently) be in an hs-boot file ; type_families <- xoptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl (tcdLName decl) ; checkTc (not is_boot) $ badBootFamInstDeclErr - -- Perform kind and type checking + -- Perform kind and type checking ; tc <- tcFamInstDecl1 decl - ; checkValidTyCon tc -- Remember to check validity; - -- no recursion to worry about here + ; checkValidTyCon tc -- Remember to check validity; + -- no recursion to worry about here -- Check that toplevel type instances are not for associated types. ; when (isTopLevel top_lvl && isAssocFamily tc) @@ -600,7 +617,7 @@ tcFamInstDecl top_lvl (L loc decl) ; return tc } -isAssocFamily :: TyCon -> Bool -- Is an assocaited type +isAssocFamily :: TyCon -> Bool -- Is an assocaited type isAssocFamily tycon = case tyConFamInst_maybe tycon of Nothing -> panic "isAssocFamily: no family?!?" @@ -624,12 +641,12 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; -- (1) kind check the right-hand side of the type equation ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better + -- ToDo: the ExpKind could be better -- we need the exact same number of type parameters as the family - -- declaration + -- declaration ; let famArity = tyConArity family - ; checkTc (length k_typats == famArity) $ + ; checkTc (length k_typats == famArity) $ wrongNumberOfParmsErr famArity -- (2) type check type equation @@ -642,14 +659,14 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) - (typeKind t_rhs) + ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (typeKind t_rhs) NoParentTyCon (Just (family, t_typats)) }} -- "newtype instance" and "data instance" tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) + tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> do { -- check that the family declaration is for the right kind checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) @@ -658,7 +675,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs ; let k_ctxt = tcdCtxt k_decl - k_cons = tcdCons k_decl + k_cons = tcdCons k_decl -- result kind must be '*' (otherwise, we have too few patterns) ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) @@ -680,29 +697,29 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; let ex_ok = True -- Existentials ok for type families! - ; fixM (\ rep_tycon -> do - { let orig_res_ty = mkTyConApp fam_tycon t_typats - ; data_cons <- tcConDecls ex_ok rep_tycon - (t_tvs, orig_res_ty) k_cons - ; tc_rhs <- - case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) - ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) + ; let ex_ok = True -- Existentials ok for type families! + ; fixM (\ rep_tycon -> do + { let orig_res_ty = mkTyConApp fam_tycon t_typats + ; data_cons <- tcConDecls ex_ok rep_tycon + (t_tvs, orig_res_ty) k_cons + ; tc_rhs <- + case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. - }) + }) }} where - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - _ -> True + h98_syntax = case cons of -- All constructors have same shape + L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False + _ -> True tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) @@ -716,24 +733,24 @@ tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) -- check is only required for type synonym instances. kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) - -- ^^kinded tvs ^^kinded ty pats ^^res kind - -> TcM a + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) + -- ^^kinded tvs ^^kinded ty pats ^^res kind + -> TcM a kcIdxTyPats decl thing_inside - = kcHsTyVars (tcdTyVars decl) $ \tvs -> + = kcHsTyVars (tcdTyVars decl) $ \tvs -> do { let tc_name = tcdLName decl ; fam_tycon <- tcLookupLocatedTyCon tc_name ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) - ; hs_typats = fromJust $ tcdTyPats decl } + ; hs_typats = fromJust $ tcdTyPats decl } -- we may not have more parameters than the kind indicates ; checkTc (length kinds >= length hs_typats) $ - tooManyParmsErr (tcdLName decl) + tooManyParmsErr (tcdLName decl) -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckLHsType hs_typats - [ EK kind (EkArg (ppr tc_name) n) + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) | (kind,n) <- kinds `zip` [1..]] ; thing_inside tvs typats resultKind fam_tycon } @@ -759,11 +776,11 @@ tcInstDecls2 tycl_decls inst_decls let class_decls = filter (isClassDecl . unLoc) tycl_decls ; dm_binds_s <- mapM tcClassDecl2 class_decls ; let dm_binds = unionManyBags dm_binds_s - + -- (b) instance declarations - ; let dm_ids = collectHsBindsBinders dm_binds - -- Add the default method Ids (again) - -- See Note [Default methods and instances] + ; let dm_ids = collectHsBindsBinders dm_binds + -- Add the default method Ids (again) + -- See Note [Default methods and instances] ; inst_binds_s <- tcExtendIdEnv dm_ids $ mapM tcInstDecl2 inst_decls @@ -791,7 +808,7 @@ tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) = recoverM (return emptyLHsBinds) $ setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) -- We instantiate the dfun_id with superSkolems. @@ -803,7 +820,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; dfun_ev_vars <- newEvVars dfun_theta ; (sc_args, sc_binds) - <- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars) + <- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars) (sc_sels `zip` sc_theta') -- Deal with 'SPECIALISE instance' pragmas @@ -811,7 +828,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods - ; (meth_ids, meth_binds) + ; (meth_ids, meth_binds) <- tcExtendTyVarEnv inst_tyvars $ -- The inst_tyvars scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit @@ -824,38 +841,48 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; self_dict <- newEvVar (ClassP clas inst_tys) ; let class_tc = classTyCon clas [dict_constr] = tyConDataCons class_tc - dict_bind = mkVarBind self_dict dict_rhs - dict_rhs = foldl mk_app inst_constr $ - map wrap_sc sc_args - ++ map (wrapId arg_wrapper) meth_ids - wrap_sc (DFunPolyArg (Var sc)) = wrapId arg_wrapper sc - wrap_sc (DFunConstArg (Var sc)) = HsVar sc - wrap_sc _ = panic "wrap_sc" - - inst_constr = L loc $ wrapId (mkWpTyApps inst_tys) - (dataConWrapId dict_constr) + dict_bind = mkVarBind self_dict (L loc con_app_args) + -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId - -- code rather than needing to be repeated here. - - mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id - mk_app fun arg = L loc (HsApp fun (L loc arg)) - - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars) - - -- Do not inline the dfun; instead give it a magic DFunFunfolding - -- See Note [ClassOp/DFun selection] - -- See also note [Single-method classes] + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. + -- con_app_tys = MkD ty1 ty2 + -- con_app_scs = MkD ty1 ty2 sc1 sc2 + -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 + con_app_tys = wrapId (mkWpTyApps inst_tys) + (dataConWrapId dict_constr) + con_app_scs = mkHsWrap (mkWpEvApps (map mk_sc_ev_term sc_args)) con_app_tys + con_app_args = foldl mk_app con_app_scs $ + map (wrapId arg_wrapper) meth_ids + + mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id + mk_app fun arg = HsApp (L loc fun) (L loc arg) + + mk_sc_ev_term :: EvVar -> EvTerm + mk_sc_ev_term sc + | null inst_tv_tys + , null dfun_ev_vars = evVarTerm sc + | otherwise = EvDFunApp sc inst_tv_tys dfun_ev_vars + + inst_tv_tys = mkTyVarTys inst_tyvars + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys + + -- Do not inline the dfun; instead give it a magic DFunFunfolding + -- See Note [ClassOp/DFun selection] + -- See also note [Single-method classes] dfun_id_w_fun | isNewTyCon class_tc = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } | otherwise - = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args) + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args `setInlinePragma` dfunInlinePragma - meth_args = map (DFunPolyArg . Var) meth_ids + + dfun_args :: [CoreExpr] + dfun_args = map varToCoreExpr sc_args ++ + map Var meth_ids main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars @@ -874,41 +901,31 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) loc = getSrcSpan dfun_id ------------------------------ -tcSuperClass :: [TcTyVar] -> [EvVar] - -> (Id, PredType) - -> TcM (DFunArg CoreExpr, LHsBinds Id) - --- For a constant superclass (no free tyvars) --- return sc_dict, no bindings, DFunConstArg --- For a non-constant superclass --- build a top level decl like --- sc_op = /\a \d. let sc = ... in --- sc --- and return sc_op, that binding, DFunPolyArg +tcSuperClass :: [TcTyVar] -> [EvVar] + -> (Id, PredType) + -> TcM (TcId, LHsBinds TcId) -tcSuperClass tyvars ev_vars (sc_sel, sc_pred) - | isEmptyVarSet (tyVarsOfPred sc_pred) -- Constant - = do { sc_dict <- emitWanted ScOrigin sc_pred - ; return (DFunConstArg (Var sc_dict), emptyBag) } +-- Build a top level decl like +-- sc_op = /\a \d. let sc = ... in +-- sc +-- and return sc_op, that binding - | otherwise +tcSuperClass tyvars ev_vars (sc_sel, sc_pred) = do { (ev_binds, sc_dict) <- newImplication InstSkol tyvars ev_vars $ emitWanted ScOrigin sc_pred ; uniq <- newUnique ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes ev_vars (varType sc_dict) - sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq - (getName sc_sel) - sc_op_id = mkLocalId sc_op_name sc_op_ty - sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False - , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict } + sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq + (getName sc_sel) + sc_op_id = mkLocalId sc_op_name sc_op_ty + sc_op_bind = mkVarBind sc_op_id (L noSrcSpan $ wrapId sc_wrapper sc_dict) sc_wrapper = mkWpTyLams tyvars <.> mkWpLams ev_vars - <.> mkWpLet ev_binds - binds = unitBag (noLoc sc_op_bind) + <.> mkWpLet ev_binds - ; return (DFunPolyArg (Var sc_op_id), binds) } + ; return (sc_op_id, unitBag sc_op_bind) } ------------------------------ tcSpecInstPrags :: DFunId -> InstBindings Name @@ -918,7 +935,7 @@ tcSpecInstPrags _ (NewTypeDerived {}) tcSpecInstPrags dfun_id (VanillaInst binds uprags _) = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $ filter isSpecInstLSig uprags - -- The filter removes the pragmas for methods + -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragFun uprags binds) } \end{code} @@ -939,12 +956,12 @@ argument: dfun = \d::D [a] -> MkD (scsel d) .. Rather, we want to get it by finding an instance for (C [a]). We -achieve this by +achieve this by not making the superclasses of a "wanted" available for solving wanted constraints. -Test case SCLoop tests this fix. - +Test case SCLoop tests this fix. + Note [SPECIALISE instance pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -971,7 +988,7 @@ Thus we should generate something like this: {-# RULE range ($dfIx da db) = $crange da db #-} -Note that +Note that * The RULE is unaffected by the specialisation. We don't want to specialise $dfIx, because then it would need a specialised RULE @@ -989,7 +1006,7 @@ The "it turns out" bit is delicate, but it works fine! \begin{code} tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig hs_ty) +tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $ do { let name = idName dfun_id ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty @@ -1021,14 +1038,14 @@ tcInstanceMethod \begin{code} tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] - -> [TcType] + -> [TcType] -> ([Located TcSpecPrag], PragFun) - -> [(Id, DefMeth)] - -> InstBindings Name - -> TcM ([Id], [LHsBind Id]) - -- The returned inst_meth_ids all have types starting - -- forall tvs. theta => ... -tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys + -> [(Id, DefMeth)] + -> InstBindings Name + -> TcM ([Id], [LHsBind Id]) + -- The returned inst_meth_ids all have types starting + -- forall tvs. theta => ... +tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys (spec_inst_prags, prag_fn) op_items (VanillaInst binds _ standalone_deriv) = mapAndUnzipM tc_item op_items @@ -1037,23 +1054,23 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id) tc_item (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of - Just user_bind -> tc_body sel_id standalone_deriv user_bind - Nothing -> tc_default sel_id dm_info + Just user_bind -> tc_body sel_id standalone_deriv user_bind + Nothing -> tc_default sel_id dm_info ---------------------- tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) - tc_body sel_id generated_code rn_bind + tc_body sel_id generated_code rn_bind = add_meth_ctxt sel_id generated_code rn_bind $ - do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars + do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; let prags = prag_fn (idName sel_id) ; meth_id1 <- addInlinePrags meth_id prags ; spec_prags <- tcSpecPrags meth_id1 prags ; bind <- tcInstanceMethodBody InstSkol tyvars dfun_ev_vars - meth_id1 local_meth_id meth_sig_fn + meth_id1 local_meth_id meth_sig_fn (mk_meth_spec_prags meth_id1 spec_prags) - rn_bind + rn_bind ; return (meth_id1, bind) } ---------------------- @@ -1063,99 +1080,97 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name ; tc_body sel_id False {- Not generated code? -} meth_bind } - tc_default sel_id NoDefMeth -- No default method at all + tc_default sel_id NoDefMeth -- No default method at all = do { warnMissingMethod sel_id - ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id - ; return (meth_id, mkVarBind meth_id $ + ; return (meth_id, mkVarBind meth_id $ mkLHsWrap lam_wrapper error_rhs) } where - error_rhs = L loc $ HsApp error_fun error_msg - error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID - error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) - meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) - error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) + error_rhs = L loc $ HsApp error_fun error_msg + error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID + error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) + meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) + error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars - tc_default sel_id (DefMeth dm_name) -- A polymorphic default method - = do { -- Build the typechecked version directly, - -- without calling typecheck_method; - -- see Note [Default methods in instances] + tc_default sel_id (DefMeth dm_name) -- A polymorphic default method + = do { -- Build the typechecked version directly, + -- without calling typecheck_method; + -- see Note [Default methods in instances] -- Generate /\as.\ds. let self = df as ds -- in $dm inst_tys self - -- The 'let' is necessary only because HsSyn doesn't allow - -- you to apply a function to a dictionary *expression*. + -- The 'let' is necessary only because HsSyn doesn't allow + -- you to apply a function to a dictionary *expression*. ; self_dict <- newEvVar (ClassP clas inst_tys) ; let self_ev_bind = EvBind self_dict $ EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars - ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars + ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ - HsVar dm_id + HsVar dm_id - meth_bind = L loc $ VarBind { var_id = local_meth_id - , var_rhs = L loc rhs - , var_inline = False } + meth_bind = mkVarBind local_meth_id (L loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag - -- Copy the inline pragma (if any) from the default - -- method to this version. Note [INLINE and default methods] - - bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars + -- Copy the inline pragma (if any) from the default + -- method to this version. Note [INLINE and default methods] + + bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id , mk_meth_spec_prags meth_id1 [])] , abs_ev_binds = EvBinds (unitBag self_ev_bind) , abs_binds = unitBag meth_bind } - -- Default methods in an instance declaration can't have their own - -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but - -- currently they are rejected with - -- "INLINE pragma lacks an accompanying binding" + -- Default methods in an instance declaration can't have their own + -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but + -- currently they are rejected with + -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, L loc bind) } + ; return (meth_id1, L loc bind) } ---------------------- mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags - -- Adapt the SPECIALISE pragmas to work for this method Id - -- There are two sources: + -- Adapt the SPECIALISE pragmas to work for this method Id + -- There are two sources: -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-} - -- These ones have the dfun inside, but [perhaps surprisingly] + -- These ones have the dfun inside, but [perhaps surprisingly] -- the correct wrapper -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-} mk_meth_spec_prags meth_id spec_prags_for_me - = SpecPrags (spec_prags_for_me ++ + = SpecPrags (spec_prags_for_me ++ [ L loc (SpecPrag meth_id wrap inl) - | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) - + | L loc (SpecPrag _ wrap inl) <- spec_inst_prags]) + loc = getSrcSpan dfun_id - meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig" - -- But there are no scoped type variables from local_method_id - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! + meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig" + -- But there are no scoped type variables from local_method_id + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = <rhs> } + -- In <rhs>, 'c' is scope but 'b' is not! -- For instance decls that come from standalone deriving clauses - -- we want to print out the full source code if there's an error - -- because otherwise the user won't see the code at all - add_meth_ctxt sel_id generated_code rn_bind thing + -- we want to print out the full source code if there's an error + -- because otherwise the user won't see the code at all + add_meth_ctxt sel_id generated_code rn_bind thing | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing | otherwise = thing -tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys +tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys _ op_items (NewTypeDerived coi _) -- Running example: -- class Show b => Foo a b where -- op :: a -> b -> b --- newtype N a = MkN (Tree [a]) +-- newtype N a = MkN (Tree [a]) -- deriving instance (Show p, Foo Int p) => Foo Int (N p) --- -- NB: standalone deriving clause means --- -- that the contex is user-specified +-- -- NB: standalone deriving clause means +-- -- that the contex is user-specified -- Hence op :: forall a b. Foo a b => a -> b -> b -- -- We're going to make an instance like @@ -1163,9 +1178,9 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys -- op = $copT -- -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p --- $copT p (d1:Show p) (d2:Foo Int p) +-- $copT p (d1:Show p) (d2:Foo Int p) -- = op Int (Tree [p]) rep_d |> op_co --- where +-- where -- rep_d :: Foo Int (Tree [p]) = ...d1...d2... -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p) -- We get op_co by substituting [Int/a] and [co/b] in type for op @@ -1177,7 +1192,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $ emitWanted ScOrigin rep_pred - + ; mapAndUnzipM (tc_item rep_d_stuff) op_items } where loc = getSrcSpan dfun_id @@ -1188,35 +1203,33 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty]) -- co : [p] ~ T p - co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $ + co = substCoWithTys (mkInScopeSet (mkVarSet tyvars)) + inst_tvs (mkTyVarTys tyvars) $ mkSymCo coi ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) tc_item (rep_ev_binds, rep_d) (sel_id, _) - = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars + = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id - meth_bind = VarBind { var_id = local_meth_id - , var_rhs = L loc meth_rhs - , var_inline = False } - - bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars - , abs_exports = [(tyvars, meth_id, + meth_bind = mkVarBind local_meth_id (L loc meth_rhs) + bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars + , abs_exports = [(tyvars, meth_id, local_meth_id, noSpecPrags)] - , abs_ev_binds = rep_ev_binds - , abs_binds = unitBag $ L loc meth_bind } + , abs_ev_binds = rep_ev_binds + , abs_binds = unitBag $ meth_bind } ; return (meth_id, L loc bind) } ---------------- mk_op_wrapper :: Id -> EvVar -> HsWrapper - mk_op_wrapper sel_id rep_d + mk_op_wrapper sel_id rep_d = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co]) local_meth_ty) <.> WpEvApp (EvId rep_d) - <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) + <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) where (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id) (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho @@ -1226,13 +1239,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId) mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id = do { uniq <- newUnique - ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name - ; local_meth_name <- newLocalName sel_name - -- Base the local_meth_name on the selector name, becuase - -- type errors from tcInstanceMethodBody come from here + ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name + ; local_meth_name <- newLocalName sel_name + -- Base the local_meth_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here - ; let meth_id = mkLocalId meth_name meth_ty - local_meth_id = mkLocalId local_meth_name local_meth_ty + ; let meth_id = mkLocalId meth_name meth_ty + local_meth_id = mkLocalId local_meth_name local_meth_ty ; return (meth_id, local_meth_id) } where local_meth_ty = instantiateMethod clas sel_id inst_tys @@ -1247,19 +1260,19 @@ derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc derivBindCtxt sel_id clas tys _bind = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id) , nest 2 (ptext (sLit "in a standalone derived instance for") - <+> quotes (pprClassPred clas tys) <> colon) + <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] -- Too voluminous --- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] +-- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] warnMissingMethod :: Id -> TcM () warnMissingMethod sel_id - = do { warn <- doptM Opt_WarnMissingMethods + = do { warn <- woptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods && not (startsWithUnderscore (getOccName sel_id))) - -- Don't warn about _foo methods - (ptext (sLit "No explicit method nor default method for") + -- Don't warn about _foo methods + (ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)) } \end{code} @@ -1268,7 +1281,7 @@ Note [Export helper functions] We arrange to export the "helper functions" of an instance declaration, so that they are not subject to preInlineUnconditionally, even if their RHS is trivial. Reason: they are mentioned in the DFunUnfolding of -the dict fun as Ids, not as CoreExprs, so we can't substitute a +the dict fun as Ids, not as CoreExprs, so we can't substitute a non-variable for them. We could change this by making DFunUnfoldings have CoreExprs, but it @@ -1314,12 +1327,12 @@ macros. For exmample instance Foo Int where -- op1 via default method op2 b x = <blah> - + The instance declaration should behave just as if 'op1' had been defined with the code, and INLINE pragma, from its original - definition. + definition. That is, just as if you'd written @@ -1349,11 +1362,11 @@ Note carefullly: instance $cop1. Otherwise we'll just inline the former in the latter and stop, which isn't what the user expected -* Regardless of its pragma, we give the default method an +* Regardless of its pragma, we give the default method an unfolding with an InlineCompulsory source. That means that it'll be inlined at every use site, notably in each instance declaration, such as $cop1. This inlining - must happen even though + must happen even though a) $dmop1 is not saturated in $cop1 b) $cop1 itself has an INLINE pragma @@ -1407,12 +1420,12 @@ wrongATArgErr ty instTy = tooManyParmsErr :: Located Name -> SDoc tooManyParmsErr tc_name - = ptext (sLit "Family instance has too many parameters:") <+> + = ptext (sLit "Family instance has too many parameters:") <+> quotes (ppr tc_name) tooFewParmsErr :: Arity -> SDoc tooFewParmsErr arity - = ptext (sLit "Family instance has too few parameters; expected") <+> + = ptext (sLit "Family instance has too few parameters; expected") <+> ppr arity wrongNumberOfParmsErr :: Arity -> SDoc @@ -1428,13 +1441,13 @@ notFamily :: TyCon -> SDoc notFamily tycon = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] - + wrongKindOfFamily :: TyCon -> SDoc wrongKindOfFamily family = ptext (sLit "Wrong category of family instance; declaration was for a") <+> kindOfFamily where kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") - | isAlgTyCon family = ptext (sLit "data type") - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) + | isAlgTyCon family = ptext (sLit "data type") + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) \end{code} diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 06d4596d35..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 @@ -1139,13 +1139,11 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys) how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this")) -check_pred_ty dflags ctxt pred@(EqPred ty1 ty2) +check_pred_ty dflags _ctxt pred@(EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) (eqPredTyErr pred) - ; checkTc (case ctxt of ClassSCCtxt {} -> False; _ -> True) - (eqSuperClassErr pred) -- Check the form of the argument types ; checkValidMonoType ty1 @@ -1302,11 +1300,6 @@ checkThetaCtxt ctxt theta = vcat [ptext (sLit "In the context:") <+> pprTheta theta, ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ] -eqSuperClassErr :: PredType -> SDoc -eqSuperClassErr pred - = hang (ptext (sLit "Alas, GHC 7.0 still cannot handle equality superclasses:")) - 2 (ppr pred) - badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred @@ -1392,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} + %************************************************************************ %* * @@ -1471,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 6850846950..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,12 +202,22 @@ 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) - ; dep_mods = imp_dep_mods imports + -- Make sure we record the dependencies from the DynFlags in the EPS or we + -- end up hitting the sanity check in LoadIface.loadInterface that + -- checks for unknown home-package modules being loaded. We put + -- these dependencies on the left so their (non-source) imports + -- take precedence over the (possibly-source) imports on the right. + -- We don't add them to any other field (e.g. the imp_dep_mods of + -- imports) because we don't want to load their instances etc. + ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] + `plusUFM` imp_dep_mods imports -- We want instance declarations from all home-package -- modules below this one, including boot modules, except @@ -315,10 +328,11 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; - mod_guts = ModGuts { mg_module = this_mod, + mod_guts = ModGuts { mg_module = this_mod, mg_boot = False, mg_used_names = emptyNameSet, -- ToDo: compute usage - mg_dir_imps = emptyModuleEnv, -- ?? + mg_used_th = False, + mg_dir_imps = emptyModuleEnv, -- ?? mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_types = final_type_env, @@ -338,7 +352,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_foreign = NoStubs, mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo + mg_vect_info = noVectInfo, + mg_trust_pkg = False } } ; tcCoreDump mod_guts ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index bd5cf8d0f5..6fb09c569d 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -74,7 +74,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tvs_var <- newIORef emptyVarSet ; keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; - th_var <- newIORef False ; + th_var <- newIORef False ; + th_splice_var<- newIORef False ; lie_var <- newIORef emptyWC ; dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { @@ -98,7 +99,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, tcg_th_used = th_var, - tcg_exports = [], + tcg_th_splice_used = th_splice_var, + tcg_exports = [], tcg_imports = emptyImportAvails, tcg_used_rdrnames = used_rdr_var, tcg_dus = emptyDUs, @@ -248,21 +250,30 @@ xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } --- XXX setOptM and unsetOptM operate on different types. One should be renamed. +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) } -setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) +setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) -unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) +unsetDOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetDOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} ) -- | Do it flag is true ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifDOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } +ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifWOptM flag thing_inside = do { b <- woptM flag; + if b then thing_inside else return () } + ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifXOptM flag thing_inside = do { b <- xoptM flag; if b then thing_inside else return () } @@ -1039,6 +1050,9 @@ traceTcConstraints msg recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } +recordThSpliceUse :: TcM () +recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } + keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set keepAliveTc id | isLocalId id = do { env <- getGblEnv; diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 46a322a93f..c618da0a65 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -236,6 +236,11 @@ data TcGblEnv -- is implicit rather than explicit, so we have to zap a -- mutable variable. + tcg_th_splice_used :: TcRef Bool, + -- ^ @True@ <=> A Template Haskell splice was used. + -- + -- Splices disable recompilation avoidance (see #481) + tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. @@ -599,17 +604,17 @@ data ImportAvails -- different packages. (currently not the case, but might be in the -- future). - imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), - -- ^ Home-package modules needed by the module being compiled - -- - -- It doesn't matter whether any of these dependencies - -- are actually /used/ when compiling the module; they - -- are listed if they are below it at all. For - -- example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X - -- is still listed in M's dependencies. - - imp_dep_pkgs :: [PackageId], + imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), + -- ^ Home-package modules needed by the module being compiled + -- + -- It doesn't matter whether any of these dependencies + -- are actually /used/ when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. + + imp_dep_pkgs :: [PackageId], -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. @@ -623,12 +628,19 @@ data ImportAvails -- where True for the bool indicates the package is required to be -- trusted is the more logical design, doing so complicates a lot -- of code not concerned with Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] - imp_orphs :: [Module], + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [RnNames . Trust Own Package] + + imp_orphs :: [Module], -- ^ Orphan modules below us in the import tree (and maybe including -- us for imported modules) - imp_finsts :: [Module] + imp_finsts :: [Module] -- ^ Family instance modules below us in the import tree (and maybe -- including us for imported modules) } @@ -640,34 +652,41 @@ mkModDeps deps = foldl add emptyUFM deps add env elt@(m,_) = addToUFM env m elt emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = [], - imp_trust_pkgs = [], - imp_orphs = [], - imp_finsts = [] } - +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = [], + imp_trust_pkgs = [], + imp_trust_own_pkg = False, + imp_orphs = [], + imp_finsts = [] } + +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a seperate ImportAvails structure +-- and then union them all together with this function. plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, - imp_trust_pkgs = tpkgs1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, - imp_trust_pkgs = tpkgs2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, - imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, - imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, - imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } where plus_mod_dep (m1, boot1) (m2, boot2) - = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) - -- Check mod-names match - (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that + = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + -- Check mod-names match + (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index 3925c6def3..8676555a03 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -90,11 +90,14 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs) -- c.f. TcSimplify.simplifyInfer ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; qtvs <- zonkQuantifiedTyVars $ - varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs) + ; let extra_bound_tvs = zonked_forall_tvs + `minusVarSet` gbl_tvs + `delVarSetList` tv_bndrs + ; qtvs <- zonkQuantifiedTyVars (varSetElems extra_bound_tvs) + -- The tv_bndrs are already skolems, so no need to zonk them ; return (HsRule name act - (map (RuleBndr . noLoc) (qtvs ++ tpl_ids)) -- yuk + (map (RuleBndr . noLoc) (tv_bndrs ++ qtvs ++ tpl_ids)) -- yuk (mkHsDictLet lhs_ev_binds lhs') fv_lhs (mkHsDictLet rhs_ev_binds rhs') fv_rhs) } 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/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 97ad485e6a..3bf26a6fc4 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -810,6 +810,8 @@ runMeta :: (Outputable hs_syn) -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr = do { traceTc "About to run" (ppr expr) + ; recordThSpliceUse -- seems to be the best place to do this, + -- we catch all kinds of splices and annotations. -- Desugar ; ds_expr <- initDsTc (dsLExpr expr) @@ -1315,8 +1317,9 @@ reifyFixity name conv_dir BasicTypes.InfixN = TH.InfixN reifyStrict :: BasicTypes.HsBang -> TH.Strict -reifyStrict bang | isBanged bang = TH.IsStrict - | otherwise = TH.NotStrict +reifyStrict bang | bang == HsUnpack = TH.Unpacked + | isBanged bang = TH.IsStrict + | otherwise = TH.NotStrict ------------------------------ noTH :: LitString -> SDoc -> TcM a diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index ca4f2c5ecd..031ffdf70d 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -91,6 +91,8 @@ tcTyAndClassDecls boot_details decls_s ; let rec_flags = calcRecFlags boot_details rec_tyclss ; concatMapM (tcTyClDecl rec_flags) kc_decls } + ; traceTc "tcTyAndCl3" (ppr tyclss) + ; tcExtendGlobalEnv tyclss $ do { -- Perform the validity check -- We can do this now because we are done with the recursive knot @@ -422,6 +424,7 @@ tcTyClDecl :: (Name -> RecFlag) -> LTyClDecl Name -> TcM [TyThing] tcTyClDecl calc_isrec (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ + traceTc "tcTyAndCl-x" (ppr decl) >> tcTyClDecl1 NoParentTyCon calc_isrec decl -- "type family" declarations 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/Class.lhs b/compiler/types/Class.lhs index d9e44e591c..6489a2fdac 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -13,7 +13,7 @@ module Class ( FunDep, pprFundeps, pprFunDep, - mkClass, classTyVars, classArity, classSCNEqs, + mkClass, classTyVars, classArity, classKey, className, classATs, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, classAllSelIds, classSCSelId @@ -33,6 +33,7 @@ import Util import Outputable import FastString +import Data.Typeable hiding (TyCon) import qualified Data.Data as Data \end{code} @@ -57,20 +58,19 @@ data Class -- We need value-level selectors for the dictionary -- superclasses, but not for the equality superclasses classSCTheta :: [PredType], -- Immediate superclasses, - --- *with equalities first* - classSCNEqs :: Int, -- How many equalities classSCSels :: [Id], -- Selector functions to extract the - -- *dictionary* superclasses from a + -- superclasses from a -- dictionary of this class -- Associated types classATs :: [TyCon], -- Associated type families - -- Class operations + -- Class operations (methods, not superclasses) classOpStuff :: [ClassOpItem], -- Ordered by tag classTyCon :: TyCon -- The data type constructor for -- dictionaries of this class } + deriving Typeable type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] @@ -100,20 +100,19 @@ The @mkClass@ function fills in the indirect superclasses. \begin{code} mkClass :: Name -> [TyVar] -> [([TyVar], [TyVar])] - -> [PredType] -> Int -> [Id] + -> [PredType] -> [Id] -> [TyCon] -> [ClassOpItem] -> TyCon -> Class -mkClass name tyvars fds super_classes n_eqs superdict_sels ats +mkClass name tyvars fds super_classes superdict_sels ats op_stuff tycon = Class { classKey = getUnique name, className = name, classTyVars = tyvars, classFunDeps = fds, classSCTheta = super_classes, - classSCNEqs = n_eqs, classSCSels = superdict_sels, classATs = ats, classOpStuff = op_stuff, @@ -142,11 +141,9 @@ classSCSelId :: Class -> Int -> Id -- Get the n'th superclass selector Id -- where n is 0-indexed, and counts -- *all* superclasses including equalities -classSCSelId (Class { classSCNEqs = n_eqs, classSCSels = sc_sels }) n - = ASSERT( sc_sel_index >= 0 && sc_sel_index < length sc_sels ) - sc_sels !! sc_sel_index - where - sc_sel_index = n - n_eqs -- 0-index into classSCSels +classSCSelId (Class { classSCSels = sc_sels }) n + = ASSERT( n >= 0 && n < length sc_sels ) + sc_sels !! n classMethods :: Class -> [Id] classMethods (Class {classOpStuff = op_stuff}) @@ -219,9 +216,6 @@ pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds)) pprFunDep :: Outputable a => FunDep a -> SDoc pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] -instance Data.Typeable Class where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") [] - instance Data.Data Class where -- don't traverse? toConstr _ = abstractConstr "Class" diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 7df5b8e38f..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] @@ -593,11 +592,9 @@ mkNthCo :: Int -> Coercion -> Coercion mkNthCo n (Refl ty) = Refl (getNth n ty) mkNthCo n co = NthCo n co --- | Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs --- the resulting beta-reduction, otherwise it creates a suspended instantiation. +-- | Instantiates a 'Coercion' with a 'Type' argument. mkInstCo :: Coercion -> Type -> Coercion -mkInstCo (ForAllCo tv co) ty = substCoWithTy tv ty co -mkInstCo co ty = InstCo co ty +mkInstCo co ty = InstCo co ty -- | Manufacture a coercion from thin air. Needless to say, this is -- not usually safe, but it is used when we know we are dealing with @@ -814,21 +811,16 @@ 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] -substCoWithTy :: TyVar -> Type -> Coercion -> Coercion -substCoWithTy tv ty = substCoWithTys [tv] [ty] - -substCoWithTys :: [TyVar] -> [Type] -> Coercion -> Coercion -substCoWithTys tvs tys co +substCoWithTys :: InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithTys in_scope tvs tys co | debugIsOn && (length tvs /= length tys) = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co | otherwise = ASSERT( length tvs == length tys ) substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co - where - in_scope = mkInScopeSet (tyVarsOfTypes tys) -- | Substitute within a 'Coercion' substCo :: CvSubst -> Coercion -> Coercion @@ -870,7 +862,7 @@ substCoVar :: CvSubst -> CoVar -> Coercion substCoVar (CvSubst in_scope _ cenv) cv | Just co <- lookupVarEnv cenv cv = co | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 - | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv ) + | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) ASSERT( isCoVar cv ) CoVarCo cv substCoVars :: CvSubst -> [CoVar] -> [Coercion] @@ -891,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) @@ -919,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. @@ -1025,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/InstEnv.lhs b/compiler/types/InstEnv.lhs index db310f3c7f..2789a331cc 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -432,7 +432,7 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> ([InstMatch], -- Successful matches [Instance], -- These don't match but do unify Bool) -- True if error condition caused by - -- SafeHaskell condition. + -- Safe Haskell condition. -- The second component of the result pair happens when we look up -- Foo [a] @@ -462,7 +462,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- misleading (complaining of multiple matches when some should be -- overlapped away) - -- SafeHaskell: We restrict code compiled in 'Safe' mode from + -- Safe Haskell: We restrict code compiled in 'Safe' mode from -- overriding code compiled in any other mode. The rational is -- that code compiled in 'Safe' mode is code that is untrusted -- by the ghc user. So we shouldn't let that code change the diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs index eef1ccf672..5d0eb58f4e 100644 --- a/compiler/types/OptCoercion.lhs +++ b/compiler/types/OptCoercion.lhs @@ -127,11 +127,12 @@ opt_co' env sym (UnsafeCo ty1 ty2) ty2' = substTy env ty2 opt_co' env sym (TransCo co1 co2) - | sym = opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g - | otherwise = opt_trans opt_co1 opt_co2 + | sym = opt_trans in_scope opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g + | otherwise = opt_trans in_scope opt_co1 opt_co2 where opt_co1 = opt_co env sym co1 opt_co2 = opt_co env sym co2 + in_scope = getCvInScope env opt_co' env sym (NthCo n co) | TyConAppCo tc cos <- co' @@ -149,9 +150,10 @@ opt_co' env sym (InstCo co ty) | Just (tv, co_body) <- splitForAllCo_maybe co = opt_co (extendTvSubst env tv ty') sym co_body - -- See if it is a forall after optimization + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution | Just (tv, co'_body) <- splitForAllCo_maybe co' - = substCoWithTy tv ty' co'_body -- An inefficient one-variable substitution + = substCoWithTy (getCvInScope env) tv ty' co'_body | otherwise = InstCo co' ty' @@ -160,111 +162,113 @@ opt_co' env sym (InstCo co ty) ty' = substTy env ty ------------- -opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList = zipWith opt_trans +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) -opt_trans :: NormalCo -> NormalCo -> NormalCo -opt_trans co1 co2 +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 | isReflCo co1 = co2 - | otherwise = opt_trans1 co1 co2 + | otherwise = opt_trans1 is co1 co2 -opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo -- First arg is not the identity -opt_trans1 co1 co2 +opt_trans1 is co1 co2 | isReflCo co2 = co1 - | otherwise = opt_trans2 co1 co2 + | otherwise = opt_trans2 is co1 co2 -opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo -- Neither arg is the identity -opt_trans2 (TransCo co1a co1b) co2 +opt_trans2 is (TransCo co1a co1b) co2 -- Don't know whether the sub-coercions are the identity - = opt_trans co1a (opt_trans co1b co2) + = opt_trans is co1a (opt_trans is co1b co2) -opt_trans2 co1 co2 - | Just co <- opt_trans_rule co1 co2 +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 = co -opt_trans2 co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule co1 co2a +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a = if isReflCo co1_2a then co2b - else opt_trans1 co1_2a co2b + else opt_trans1 is co1_2a co2b -opt_trans2 co1 co2 +opt_trans2 _ co1 co2 = mkTransCo co1 co2 ------ -- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo -- push transitivity down through matching top-level constructors. -opt_trans_rule in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) +opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $ - TyConAppCo tc1 (opt_transList cos1 cos2) + TyConAppCo tc1 (opt_transList is cos1 cos2) -- push transitivity through matching destructors -opt_trans_rule in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) +opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) | d1 == d2 , co1 `compatible_co` co2 = fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo d1 (opt_trans co1 co2) + mkNthCo d1 (opt_trans is co1 co2) -- Push transitivity inside instantiation -opt_trans_rule in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) | ty1 `eqType` ty2 , co1 `compatible_co` co2 = fireTransRule "TrPushInst" in_co1 in_co2 $ - mkInstCo (opt_trans co1 co2) ty1 + mkInstCo (opt_trans is co1 co2) ty1 -- Push transitivity inside apply -opt_trans_rule in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) = fireTransRule "TrPushApp" in_co1 in_co2 $ - mkAppCo (opt_trans co1a co2a) (opt_trans co1b co2b) + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) -opt_trans_rule co1@(TyConAppCo tc cos1) co2 +opt_trans_rule is co1@(TyConAppCo tc cos1) co2 | Just cos2 <- etaTyConAppCo_maybe tc co2 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompL" co1 co2 $ - TyConAppCo tc (zipWith opt_trans cos1 cos2) + TyConAppCo tc (opt_transList is cos1 cos2) -opt_trans_rule co1 co2@(TyConAppCo tc cos2) +opt_trans_rule is co1 co2@(TyConAppCo tc cos2) | Just cos1 <- etaTyConAppCo_maybe tc co1 = ASSERT( length cos1 == length cos2 ) fireTransRule "EtaCompR" co1 co2 $ - TyConAppCo tc (zipWith opt_trans cos1 cos2) + TyConAppCo tc (opt_transList is cos1 cos2) -- Push transitivity inside forall -opt_trans_rule co1 co2 +opt_trans_rule is co1 co2 | Just (tv1,r1) <- splitForAllCo_maybe co1 , Just (tv2,r2) <- etaForAllCo_maybe co2 - , let r2' = substCoWithTy tv2 (mkTyVarTy tv1) r2 + , let r2' = substCoWithTy is' tv2 (mkTyVarTy tv1) r2 + is' = is `extendInScopeSet` tv1 = fireTransRule "EtaAllL" co1 co2 $ - mkForAllCo tv1 (opt_trans2 r1 r2') + mkForAllCo tv1 (opt_trans2 is' r1 r2') | Just (tv2,r2) <- splitForAllCo_maybe co2 , Just (tv1,r1) <- etaForAllCo_maybe co1 - , let r1' = substCoWithTy tv1 (mkTyVarTy tv2) r1 + , let r1' = substCoWithTy is' tv1 (mkTyVarTy tv2) r1 + is' = is `extendInScopeSet` tv2 = fireTransRule "EtaAllR" co1 co2 $ - mkForAllCo tv1 (opt_trans2 r1' r2) + mkForAllCo tv1 (opt_trans2 is' r1' r2) -- Push transitivity inside axioms -opt_trans_rule co1 co2 +opt_trans_rule is co1 co2 -- TrPushAxR/TrPushSymAxR | Just (sym, con, cos1) <- co1_is_axiom_maybe , Just cos2 <- matchAxiom sym con co2 = fireTransRule "TrPushAxR" co1 co2 $ if sym - then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1) - else AxiomInstCo con (opt_transList cos1 cos2) + then SymCo $ AxiomInstCo con (opt_transList is (map mkSymCo cos2) cos1) + else AxiomInstCo con (opt_transList is cos1 cos2) -- TrPushAxL/TrPushSymAxL | Just (sym, con, cos2) <- co2_is_axiom_maybe , Just cos1 <- matchAxiom (not sym) con co1 = fireTransRule "TrPushAxL" co1 co2 $ if sym - then SymCo $ AxiomInstCo con (opt_transList cos2 (map mkSymCo cos1)) - else AxiomInstCo con (opt_transList cos1 cos2) + then SymCo $ AxiomInstCo con (opt_transList is cos2 (map mkSymCo cos1)) + else AxiomInstCo con (opt_transList is cos1 cos2) -- TrPushAxSym/TrPushSymAx | Just (sym1, con1, cos1) <- co1_is_axiom_maybe @@ -278,20 +282,20 @@ opt_trans_rule co1 co2 , all (`elemVarSet` pivot_tvs) qtvs = fireTransRule "TrPushAxSym" co1 co2 $ if sym2 - then liftCoSubstWith qtvs (opt_transList cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym - else liftCoSubstWith qtvs (opt_transList (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + then liftCoSubstWith qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym + else liftCoSubstWith qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx where co1_is_axiom_maybe = isAxiom_maybe co1 co2_is_axiom_maybe = isAxiom_maybe co2 -opt_trans_rule co1 co2 -- Identity rule +opt_trans_rule _ co1 co2 -- Identity rule | Pair ty1 _ <- coercionKind co1 , Pair _ ty2 <- coercionKind co2 , ty1 `eqType` ty2 = fireTransRule "RedTypeDirRefl" co1 co2 $ Refl ty2 -opt_trans_rule _ _ = Nothing +opt_trans_rule _ _ _ = Nothing fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion fireTransRule _rule _co1 _co2 res diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 915207621f..895dd3a7f3 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -96,6 +96,7 @@ import FastString import Constants import Util import qualified Data.Data as Data +import Data.Typeable hiding (TyCon) \end{code} ----------------------------------------------- @@ -416,6 +417,7 @@ data TyCon tyConUnique :: Unique, tyConName :: Name } + deriving Typeable -- | Names of the fields in an algebraic record type type FieldLabel = Name @@ -685,6 +687,7 @@ data CoAxiom , co_ax_lhs :: Type -- left-hand side of the equality , co_ax_rhs :: Type -- right-hand side of the equality } + deriving Typeable coAxiomArity :: CoAxiom -> Arity coAxiomArity ax = length (co_ax_tvs ax) @@ -1380,9 +1383,6 @@ instance Outputable TyCon where instance NamedThing TyCon where getName = tyConName -instance Data.Typeable TyCon where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "TyCon") [] - instance Data.Data TyCon where -- don't traverse? toConstr _ = abstractConstr "TyCon" @@ -1410,9 +1410,6 @@ instance Outputable CoAxiom where instance NamedThing CoAxiom where getName = co_ax_name -instance Data.Typeable CoAxiom where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") [] - instance Data.Data CoAxiom where -- don't traverse? toConstr _ = abstractConstr "CoAxiom" diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 995d7a9c1d..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(..), @@ -118,7 +118,7 @@ module Type ( -- ** Performing substitution on types substTy, substTys, substTyWith, substTysWith, substTheta, substPred, substTyVar, substTyVars, substTyVarBndr, - deShadowTy, lookupTyVar, + cloneTyVarBndr, deShadowTy, lookupTyVar, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, @@ -145,8 +145,10 @@ import TyCon import TysPrim -- others +import Unique ( Unique ) import BasicTypes ( IPName ) import Name ( Name ) +import NameSet import StaticFlags import Util import Outputable @@ -566,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 @@ -1265,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 @@ -1468,7 +1492,7 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) - -- Check that we are not capturing something in the substitution + -- Assertion check that we are not capturing something in the substitution no_change = new_var == old_var -- no_change means that the new_var is identical in @@ -1483,6 +1507,14 @@ substTyVarBndr subst@(TvSubst in_scope tenv) old_var new_var = uniqAway in_scope old_var -- The uniqAway part makes sure the new variable is not already in scope + +cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar) +cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq + = (TvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')), tv') + where + tv' = setVarUnique tv uniq -- Simply set the unique; the kind + -- has no type variables to worry about \end{code} ---------------------------------------------------- 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/Binary.hs b/compiler/utils/Binary.hs index c5a2c8f4fd..b61b2838ee 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -30,7 +30,9 @@ module Binary writeBinMem, readBinMem, + fingerprintBinMem, + computeFingerprint, isEOFBin, @@ -74,6 +76,9 @@ import Data.Array import Data.IORef import Data.Char ( ord, chr ) import Data.Typeable +#if __GLASGOW_HASKELL__ >= 701 +import Data.Typeable.Internal +#endif import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -237,6 +242,18 @@ fingerprintBinMem (BinMem _ ix_r _ arr_r) = do ix <- readFastMutInt ix_r withForeignPtr arr $ \p -> fingerprintData p ix +computeFingerprint :: Binary a + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint + +computeFingerprint put_name a = do + bh <- openBinMem (3*1024) -- just less than a block + ud <- newWriteState put_name putFS + bh <- return $ setUserData bh ud + put_ bh a + fingerprintBinMem bh + -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ _ sz_r arr_r) off = do @@ -562,6 +579,14 @@ instance Binary (Bin a) where -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff +#if __GLASGOW_HASKELL__ >= 701 +instance Binary TyCon where + put_ bh (TyCon _ p m n) = do + put_ bh (p,m,n) + get bh = do + (p,m,n) <- get bh + return (mkTyCon3 p m n) +#else instance Binary TyCon where put_ bh ty_con = do let s = tyConString ty_con @@ -569,6 +594,7 @@ instance Binary TyCon where get bh = do s <- get bh return (mkTyCon s) +#endif instance Binary TypeRep where put_ bh type_rep = do diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs index a341bdecbc..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] @@ -164,6 +233,9 @@ flattenSCC (CyclicSCC vs) = vs instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +instance PlatformOutputable a => PlatformOutputable (SCC a) where + pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) + pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ @@ -191,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 @@ -200,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 20b3ee9da4..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" @@ -19,11 +20,20 @@ module Fingerprint ( import Outputable -import Foreign -import Foreign.C import Text.Printf import Numeric ( readHex ) +##if __GLASGOW_HASKELL__ >= 701 +-- The MD5 implementation is now in base, to support Typeable +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. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 @@ -33,19 +43,6 @@ data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 fingerprint0 :: Fingerprint fingerprint0 = Fingerprint 0 0 -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) - where i1 = fromIntegral w1 :: Integer - i2 = fromIntegral w2 :: Integer - -- printf in GHC 6.4.2 didn't have Word64 instances - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - peekFingerprint :: Ptr Word8 -> IO Fingerprint peekFingerprint p = do let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64 @@ -69,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" @@ -77,3 +87,18 @@ foreign import ccall unsafe "MD5Update" c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO () foreign import ccall unsafe "MD5Final" c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO () +##endif + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) + where i1 = fromIntegral w1 :: Integer + i2 = fromIntegral w2 :: Integer + -- printf in GHC 6.4.2 didn't have Word64 instances + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + 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 fc4d919473..be6a9cf84d 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -13,6 +13,7 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), + PlatformOutputable(..), -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, @@ -74,6 +75,7 @@ import {-# SOURCE #-} OccName( OccName ) import StaticFlags import FastString import FastTypes +import Platform import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -596,6 +598,20 @@ keyword = bold -- | Class designating that some type has an 'SDoc' representation 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 + +class PlatformOutputable a where + pprPlatform :: Platform -> a -> SDoc + pprPlatformPrec :: Platform -> Rational -> a -> SDoc + + pprPlatform platform = pprPlatformPrec platform 0 + pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -617,12 +633,19 @@ instance Outputable Word where instance Outputable () where ppr _ = text "()" +instance PlatformOutputable () where + pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) +instance (PlatformOutputable a) => PlatformOutputable [a] where + pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) +instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where + pprPlatform platform (x,y) + = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") @@ -656,12 +679,35 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) ppr d <> comma, ppr e]) +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) +instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where + pprPlatform platform m = pprPlatform platform (M.toList m) instance (Outputable elt) => Outputable (IM.IntMap elt) where ppr m = ppr (IM.toList m) \end{code} diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index d430df695e..1fd815604c 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -78,7 +78,7 @@ data GhcException -- | An error in the user's code, probably. | ProgramError String - deriving Eq + deriving (Typeable, Eq) instance Exception GhcException @@ -87,9 +87,6 @@ instance Show GhcException where showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e showsPrec _ e = showString progName . showString ": " . showGhcException e -instance Typeable GhcException where - typeOf _ = mkTyConApp ghcExceptionTc [] - -- | The name of this GHC. progName :: String @@ -154,11 +151,6 @@ handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a handleGhcException = ghandle -ghcExceptionTc :: TyCon -ghcExceptionTc = mkTyCon "GhcException" -{-# NOINLINE ghcExceptionTc #-} - - -- | Panics and asserts. panic, sorry, pgmError :: String -> a panic x = throwGhcException (Panic x) diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs index f3749ca09c..40e4a015df 100644 --- a/compiler/utils/Platform.hs +++ b/compiler/utils/Platform.hs @@ -39,6 +39,7 @@ data Arch | ArchPPC | ArchPPC_64 | ArchSPARC + | ArchARM deriving (Show, Eq) @@ -63,6 +64,7 @@ target32Bit p = case platformArch p of ArchPPC -> True ArchPPC_64 -> False ArchSPARC -> True + ArchARM -> True -- | This predicates tells us whether the OS supports ELF-like shared libraries. @@ -95,6 +97,8 @@ defaultTargetArch = ArchPPC defaultTargetArch = ArchPPC_64 #elif sparc_TARGET_ARCH defaultTargetArch = ArchSPARC +#elif arm_TARGET_ARCH +defaultTargetArch = ArchARM #else defaultTargetArch = ArchUnknown #endif diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs index 7302b0295e..7cbc3dbcfb 100644 --- a/compiler/utils/UniqFM.lhs +++ b/compiler/utils/UniqFM.lhs @@ -64,7 +64,11 @@ import Outputable import Compiler.Hoopl hiding (Unique) +import Data.Function (on) import qualified Data.IntMap as M +import qualified Data.Foldable as Foldable +import Data.Typeable +import Data.Data \end{code} %************************************************************************ @@ -161,7 +165,14 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] %************************************************************************ \begin{code} -newtype UniqFM ele = UFM (M.IntMap ele) +newtype UniqFM ele = UFM { unUFM :: M.IntMap ele } + deriving (Typeable,Data) + +instance Eq ele => Eq (UniqFM ele) where + (==) = (==) `on` unUFM + +instance Foldable.Foldable UniqFM where + foldMap f = Foldable.foldMap f . unUFM emptyUFM = UFM M.empty isNullUFM (UFM m) = M.null m diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index dc4f32ec5e..ea46b28334 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, @@ -543,6 +543,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 diff --git a/compiler/utils/md5.c b/compiler/utils/md5.c index 0570cbbdf1..06c2d37738 100644 --- a/compiler/utils/md5.c +++ b/compiler/utils/md5.c @@ -15,6 +15,8 @@ * will fill a supplied 16-byte array with the digest. */ +#if __GLASGOW_HASKELL__ < 701 + #include "HsFFI.h" #include "md5.h" #include <string.h> @@ -236,3 +238,4 @@ MD5Transform(word32 buf[4], word32 const in[16]) buf[3] += d; } +#endif diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 35ddd9d9a8..f5795424da 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -21,7 +21,7 @@ import Type import Id import OccName import DynFlags -import BasicTypes ( isLoopBreaker ) +import BasicTypes ( isStrongLoopBreaker ) import Outputable import Util ( zipLazy ) import MonadUtils @@ -273,7 +273,7 @@ vectTopRhs recFs var expr rhs False Nothing -- Case (3) = do { let fvs = freeVars expr ; (inline, isScalar, vexpr) <- inBind var $ - vectPolyExpr (isLoopBreaker $ idOccInfo var) recFs fvs + vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs fvs ; return (inline, isScalar, vectorised vexpr) } diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 98271900f0..6d6a473b44 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -30,7 +30,7 @@ import Var import VarEnv import VarSet import Id -import BasicTypes( isLoopBreaker ) +import BasicTypes( isStrongLoopBreaker ) import Literal import TysWiredIn import TysPrim @@ -153,7 +153,7 @@ vectExpr (_, AnnLet (AnnRec bs) body) vect_rhs bndr rhs = localV . inBind bndr . liftM (\(_,_,z)->z) - $ vectPolyExpr (isLoopBreaker $ idOccInfo bndr) [] rhs + $ vectPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) [] rhs vectExpr e@(_, AnnLam bndr _) | isId bndr = liftM (\(_,_,z) ->z) $ vectFnExpr True False [] e diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs index 3fc2d0aea3..ba2b3950a8 100644 --- a/compiler/vectorise/Vectorise/Type/PADict.hs +++ b/compiler/vectorise/Vectorise/Type/PADict.hs @@ -73,7 +73,7 @@ buildPADict vect_tc prepr_tc arr_tc repr -- Set the unfolding for the inliner. raw_dfun <- newExportedVar dfun_name dfun_ty let dfun_unf = mkDFunUnfolding dfun_ty $ - map (DFunPolyArg . Var) method_ids + map Var method_ids dfun = raw_dfun `setIdUnfolding` dfun_unf `setInlinePragma` dfunInlinePragma diff --git a/configure.ac b/configure.ac index b634bbfb26..74c190b97d 100644 --- a/configure.ac +++ b/configure.ac @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.1], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.3], [glasgow-haskell-bugs@haskell.org], [ghc]) # Set this to YES for a released version, otherwise NO : ${RELEASE=NO} @@ -207,26 +207,6 @@ AC_CANONICAL_TARGET FPTOOLS_SET_PLATFORM_VARS -exeext='' -soext='.so' -case $host in -*-unknown-cygwin32) - AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) - AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) - exit 1 - ;; -*-unknown-mingw32) - exeext='.exe' - soext='.dll' - ;; -i386-apple-darwin|powerpc-apple-darwin) - soext='.dylib' - ;; -x86_64-apple-darwin) - soext='.dylib' - ;; -esac - # Testing if we shall enable shared libs support on Solaris. # Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. @@ -423,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 @@ -477,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], @@ -570,6 +558,8 @@ AC_SUBST(CONF_CPP_OPTS_STAGE0) AC_SUBST(CONF_CPP_OPTS_STAGE1) AC_SUBST(CONF_CPP_OPTS_STAGE2) +FP_SETTINGS + dnl ** figure out how to do context diffs FP_PROG_CONTEXT_DIFF diff --git a/distrib/MacOS/mkinstaller b/distrib/MacOS/mkinstaller index feb3db080b..c4f132be02 100644..100755 --- a/distrib/MacOS/mkinstaller +++ b/distrib/MacOS/mkinstaller @@ -14,7 +14,7 @@ fi if [ "$#" -ne 1 ] then - die "Must be given on argument (the bindist)" + die "Must be given one argument (the bindist)" fi BINDIST="$1" diff --git a/distrib/configure.ac.in b/distrib/configure.ac.in index 7df0f3b52b..facba914c2 100644 --- a/distrib/configure.ac.in +++ b/distrib/configure.ac.in @@ -82,6 +82,8 @@ AC_SUBST(CONF_CPP_OPTS_STAGE0) AC_SUBST(CONF_CPP_OPTS_STAGE1) AC_SUBST(CONF_CPP_OPTS_STAGE2) +FP_SETTINGS + # dnl ** how to invoke `ar' and `ranlib' # diff --git a/docs/users_guide/6.10.1-notes.xml b/docs/users_guide/6.10.1-notes.xml deleted file mode 100644 index bd3656c684..0000000000 --- a/docs/users_guide/6.10.1-notes.xml +++ /dev/null @@ -1,1255 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-6-10-1"> - <title>Release notes for version 6.10.1</title> - - <para> - The significant changes to the various parts of the compiler are - listed in the following sections. - </para> - - <sect2> - <title>User-visible compiler changes</title> - <itemizedlist> - <listitem> - <para> - The new QuasiQuotes language extension adds - general quasi-quotation, as described in - "Nice to be Quoted: Quasiquoting for Haskell" - (Geoffrey Mainland, Haskell Workshop 2007). - See <xref linkend="th-quasiquotation" /> for more information. - </para> - </listitem> - <listitem> - <para> - The new ViewPatterns language extension allows - "view patterns". The syntax for view patterns - is <literal>expression -> pattern</literal> in a pattern. - For more information, see <xref linkend="view-patterns" />. - </para> - </listitem> - <listitem> - <para> - GHC already supported (e op) postfix operators, but this - support was enabled by default. Now you need to use the - PostfixOperators language extension if you want it. - See <xref linkend="postfix-operators" /> for more information - on postfix operators. - </para> - </listitem> - <listitem> - <para> - The new TransformListComp language extension enables - implements generalised list comprehensions, as described in - the paper "Comprehensive comprehensions" (Peyton Jones & - Wadler, Haskell Workshop 2007). - For more information see - <xref linkend="generalised-list-comprehensions" />. - </para> - </listitem> - <listitem> - <para> - If you want to use impredicative types then you now need to - enable the ImpredicativeTypes language extension. - See <xref linkend="impredicative-polymorphism" /> for more - information. - </para> - </listitem> - <listitem> - <para> - FFI change: header files are now <emphasis>not - used</emphasis> when compiling via C. - The <option>-#include</option> flag, - the <literal>includes</literal> field - in <literal>.cabal</literal> files, and header files - specified in a <literal>foreign import</literal> - declaration all have no effect when compiling Haskell - source code.</para> - - <para>This change has important ramifications if you are - calling FFI functions that are defined by macros (or renamed - by macros). If you need to call one of these functions, - then write a C wrapper for the function and call the wrapper - using the FFI instead. In this way, your code will work - with GHC 6.10.1, and will also work - with <option>-fasm</option> in older GHCs.</para> - - <para>This change was made for several reasons. - Firstly, <option>-fvia-C</option> now behaves consistently - with <option>-fasm</option>, which is important because we - intend to stop compiling via C in the future. Also, we - don't need to worry about the interactions between header - files, or CPP options necessary to expose certain functions - from the system header files (this was becoming quite a - headache). We don't need to worry about needing header - files when inlining FFI calls across module or package - boundaries; calls can now be inlined freely. One downside - is that you don't get a warning from the C compiler when you - call a function via the FFI at the wrong type. - </para> - - <para>Another consequence of this change is that - calling <emphasis>varargs</emphasis> functions (such - as <literal>printf</literal>) via the FFI no longer works. - It has never been officially supported (the FFI spec outlaws - it), but in GHC 6.10.1 it may now really cause a crash on - certain platforms. Again, to call one of these functions - use appropriate fixed-argument C wrappers.</para> - </listitem> - <listitem> - <para> - There is a new languages extension PackageImports which allows - imports to be qualified with the package they should come - from, e.g. - </para> -<programlisting> -import "network" Network.Socket -</programlisting> - <para> - Note that this feature is not intended for general use, it - was added for constructing backwards-compatibility packages - such as the <literal>base-3.0.3.0</literal> package. See - <xref linkend="package-imports" /> for more details. - </para> - </listitem> - <listitem> - <para> - In earlier versions of GHC, the recompilation checker didn't - notice changes in other packages meant that recompilation is - needed. This is now handled properly, using MD5 checksums of - the interface ABIs. - </para> - </listitem> - <listitem> - <para> - GHC now treats the Unicode "Letter, Other" class as lowercase - letters. This is an arbitrary choice, but better than not - allowing them in identifiers at all. This may be revisited - by Haskell'. - </para> - </listitem> - <listitem> - <para> - In addition to the <literal>DEPRECATED</literal> pragma, you - can now attach arbitrary warnings to declarations with the new - <literal>WARNING</literal> pragma. See - <xref linkend="warning-deprecated-pragma" /> for more details. - </para> - </listitem> - <listitem> - <para> - If GHC is failing due to <literal>-Werror</literal>, then it - now emits a message telling you so. - </para> - </listitem> - <listitem> - <para> - GHC now warns about unrecognised pragmas, as they are often - caused by a typo. The - <literal>-fwarn-unrecognised-pragmas</literal> controls - whether this warning is emitted. - The warning is enabled by default. - </para> - </listitem> - <listitem> - <para> - There is a new flag - <literal>-fwarn-dodgy-foreign-imports</literal> which controls - a new warning about FFI delcarations of the form - </para> -<programlisting> -foreign import "f" f :: FunPtr t -</programlisting> - <para> - on the grounds that it is probably meant to be - </para> -<programlisting> -foreign import "&f" f :: FunPtr t -</programlisting> - <para> - The warning is enabled by default. - </para> - </listitem> - <listitem> - <para> - External core (output only) is working again. - </para> - </listitem> - <listitem> - <para> - There is a new flag <literal>-dsuppress-uniques</literal> that - makes GHC's intermediate core easier to read. This flag cannot - be used when actually generating code. - </para> - </listitem> - <listitem> - <para> - There is a new flag <literal>-dno-debug-output</literal> that - suppresses all of the debug information when running a - compiler built with the <literal>DEBUG</literal> option. - </para> - </listitem> - <listitem> - <para> - A bug in earlier versions of GHC meant that sections didn't - always need to be parenthesised, e.g. - <literal>(+ 1, 2)</literal> was accepted. This has now been - fixed. - </para> - </listitem> - <listitem> - <para> - The <literal>-fspec-threshold</literal> flag has been replaced - by <literal>-fspec-constr-threshold</literal> and - <literal>-fliberate-case-threshold</literal> flags. - The thresholds can be disabled by - <literal>-fno-spec-constr-threshold</literal> and - <literal>-fno-liberate-case-threshold</literal>. - </para> - </listitem> - <listitem> - <para> - The new flag <literal>-fsimplifier-phases</literal> - controls the number of simplifier phases run during - optimisation. These are numbered from n to 1 (by default, n=2). - Phase 0 is always run regardless of this flag. - </para> - </listitem> - <listitem> - <para> - Simplifier phases can have an arbitrary number of tags - assigned to them, and multiple phases can share the same tags. - The tags can be used as arguments to the new flag - <literal>-ddump-simpl-phases</literal> - to specify which phases are to be dumped. - </para> - - <para> - For example, - <literal>-ddump-simpl-phases=main</literal> will dump the - output of phases 2, 1 and 0 of the initial simplifier run - (they all share the "main" tag) while - <literal>-ddump-simpl-phases=main:0</literal> - will dump only the output of phase 0 of that run. - </para> - - <para> - At the moment, the supported tags are - main (the main, staged simplifier run (before strictness)), - post-worker-wrapper (after the w/w split), - post-liberate-case (after LiberateCase), and - final (final clean-up run) - </para> - - <para> - The names are somewhat arbitrary and will change in the future. - </para> - </listitem> - <listitem> - <para> - The <literal>-fno-method-sharing</literal> flag is now - dynamic (it used to be static). - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Deprecated flags</title> - - <itemizedlist> - <listitem> - <para> - The new flag <literal>-fwarn-deprecated-flags</literal>, - controls whether we warn about deprecated flags and language - extensions. The warning is on by default. - </para> - </listitem> - <listitem> - <para> - The following language extensions are now marked as - deprecated; expect them to be removed in a future release: - </para> - <itemizedlist> - <listitem> - <para> - <literal>RecordPuns</literal> - (use <literal>NamedFieldPuns</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>PatternSignatures</literal> - (use <literal>ScopedTypeVariables</literal> instead) - </para> - </listitem> - </itemizedlist> - </listitem> - <listitem> - <para> - The following flags are now marked as deprecated; - expect them to be removed in a future release: - </para> - <itemizedlist> - <listitem> - <para> - <literal>-Onot</literal> - (use <literal>-O0</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-Wnot</literal> - (use <literal>-w</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-frewrite-rules</literal> - (use <literal>-fenable-rewrite-rules</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-no-link</literal> - (use <literal>-c</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-recomp</literal> - (use <literal>-fno-force-recomp</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-no-recomp</literal> - (use <literal>-fforce-recomp</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-syslib</literal> - (use <literal>-package</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fth</literal> - (use the <literal>TemplateHaskell</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-ffi</literal>, <literal>-fffi</literal> - (use the <literal>ForeignFunctionInterface</literal> - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-farrows</literal> - (use the <literal>Arrows</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fgenerics</literal> - (use the <literal>Generics</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fno-implicit-prelude</literal> - (use the <literal>NoImplicitPrelude</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fbang-patterns</literal> - (use the <literal>BangPatterns</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fno-monomorphism-restriction</literal> - (use the <literal>NoMonomorphismRestriction</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fmono-pat-binds</literal> - (use the <literal>MonoPatBinds</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fextended-default-rules</literal> - (use the <literal>ExtendedDefaultRules</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fimplicit-params</literal> - (use the <literal>ImplicitParams</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fscoped-type-variables</literal> - (use the <literal>ScopedTypeVariables</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fparr</literal> - (use the <literal>PArr</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fallow-overlapping-instances</literal> - (use the <literal>OverlappingInstances</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fallow-undecidable-instances</literal> - (use the <literal>UndecidableInstances</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-fallow-incoherent-instances</literal> - (use the <literal>IncoherentInstances</literal> language - extension instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-s</literal> - (use <literal>-dep-suffix</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-f</literal> - (use <literal>-dep-makefile</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-w</literal> - (has no effect) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep--include-prelude</literal> - (use <literal>-include-pkg-deps</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep--include-pkg-deps</literal> - (use <literal>-include-pkg-deps</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep--exclude-module</literal> - (use <literal>-exclude-module</literal> instead) - </para> - </listitem> - <listitem> - <para> - <literal>-optdep-x</literal> - (use <literal>-exclude-module</literal> instead) - </para> - </listitem> - </itemizedlist> - </listitem> - <listitem> - <para> - The following flags have been removed: - </para> - <itemizedlist> - <listitem> - <para> - <literal>-no-link-chk</literal> - (has been a no-op since at least 6.0) - </para> - </listitem> - <listitem> - <para> - <literal>-fruntime-types</literal> - (has not been used for years) - </para> - </listitem> - <listitem> - <para> - <literal>-fhardwire-lib-paths</literal> - (use <literal>-dynload sysdep</literal>) - </para> - </listitem> - </itemizedlist> - </listitem> - <listitem> - <para> - The <literal>-unreg</literal> flag, which was used to build - unregisterised code with a registerised compiler, has been - removed. Now you need to build an unregisterised compiler - if you want to build unregisterised code. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHC API changes</title> - - <itemizedlist> - <listitem> - <para> - There is now a Ghc Monad used to carry around GHC's - Session data. This Monad also provides exception handling - functions. - </para> - </listitem> - <listitem> - <para> - It is now possible to get the raw characters corresponding to - each token the lexer outputs, and thus to reconstruct the - original file. - </para> - </listitem> - <listitem> - <para> - GHCi implicitly brings all exposed modules into scope with - qualified module names. There is a new flag - <literal>-fimplicit-import-qualified</literal> - that controls this behaviour, so other GHC API clients can - specify whether or not they want it. - </para> - </listitem> - <listitem> - <para> - There is now haddock documentation for much of the GHC API. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi changes</title> - - <itemizedlist> - <listitem> - <para> - You can now force GHCi to interpret a module, rather than - loading its compiled code, by prepending a * character to its - name, e.g. - </para> -<programlisting> -Prelude> :load *A -Compiling A ( A.hs, interpreted ) -*A> -</programlisting> - </listitem> - <listitem> - <para> - By default, GHCi will not print bind results, e.g. - </para> -<programlisting> -Prelude> c <- return 'c' -Prelude> -</programlisting> - <para> - does not print <literal>'c'</literal>. Use - <literal>-fprint-bind-result</literal> if you want the old - behaviour. - </para> - </listitem> - <listitem> - <para> - GHCi now uses editline, rather than readline, for input. - This shouldn't affect its behaviour. - </para> - </listitem> - <listitem> - <para> - The GHCi prompt history is now saved in - <literal>~/.ghc/ghci_history</literal>. - </para> - </listitem> - <listitem> - <para> - GHCi now uses libffi to make FFI calls, which means that the - FFI now works in GHCi on a much wider range of platforms - (all those platforms that libffi supports). - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Runtime system changes</title> - - <itemizedlist> - <listitem> - <para> - The garbage collector can now use multiple threads in parallel. - The new <literal>-g<replaceable>n</replaceable></literal> RTS - flag controls it, e.g. run your program with - <literal>+RTS -g2 -RTS</literal> to use 2 threads. - The <option>-g</option> option is implied by the - usual <option>-N</option> option, so normally there will be - no need to specify it separately, although occasionally it - is useful to turn it off with <option>-g1</option>.</para> - <para>Do let us know if you experience strange effects, - especially an increase in GC time when using the parallel GC - (use <option>+RTS -s -RTS</option> to measure GC time). - See <xref linkend="rts-options-gc" /> for more details.</para> - </listitem> - <listitem> - <para> - It is now possible to generate a heap profile without - recompiling your program for profiling. Run the program - with <option>+RTS -hT</option> to generate a basic heap - profile, and use <command>hp2ps</command> as usual to - convert the heap profile into a <literal>.ps</literal> file - for viewing. See <xref linkend="rts-profiling" /> for more - details. - </para> - </listitem> - <listitem> - <para> - If the user presses control-C while running a Haskell program - then the program gets an asynchronous UserInterrupt exception. - </para> - </listitem> - <listitem> - <para> - We now ignore SIGPIPE by default. - </para> - </listitem> - <listitem> - <para> - The <literal>-S</literal> and <literal>-s</literal> RTS flags - now send their output to stderr, rather than - <literal><replaceable>prog</replaceable>.stat</literal>, - by default. - </para> - </listitem> - <listitem> - <para> - The new <literal>-vg</literal> RTS flag provides some RTS trace - messages even in the non-debug RTS variants. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>runghc</title> - - <itemizedlist> - <listitem> - <para> - runghc now uses the compiler that it came with to run the - code, rather than the first compiler that it finds on the - PATH. - </para> - </listitem> - <listitem> - <para> - If the program to run does not have a <literal>.lhs</literal> - extension then runghc now treats it as a <literal>.hs</literal> - file. In particular, this means that programs without an - extension now work. - </para> - </listitem> - <listitem> - <para> - <literal>runghc foo</literal> will now work if - <literal>foo.hs</literal> or <literal>foo.lhs</literal> exists. - </para> - </listitem> - <listitem> - <para> - runghc can now take the code to run from stdin. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>ghc-pkg</title> - - <itemizedlist> - <listitem> - <para>ghc-pkg will refuse to unregister a package on which - other packages depend, unless - the <option>––force</option> option is also - supplied.</para> - </listitem> - <listitem> - <para> - ghc-pkg now has a <literal>-no-user-package-conf</literal> - flag which instructs it to ignore the user's personal - package.conf. - </para> - </listitem> - <listitem> - <para> - ghc-pkg no longer allows you to register two packages that - differ in case only. - </para> - </listitem> - <listitem> - <para> - ghc-pkg no longer allows you to register packages which have - unversioned dependencies. - </para> - </listitem> - <listitem> - <para> - There is a new command <literal>dump</literal> which is - similar to <literal>describe '*'</literal>, but in a format - that is designed to be parsable by other tools. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Haddock</title> - - <itemizedlist> - <listitem> - <para> - Haddock 2 now comes with GHC. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>DPH changes</title> - - <itemizedlist> - <listitem> - <para> - DPH is now an extralib. - </para> - </listitem> - <listitem> - <para> - There is a new flag <literal>-Odph</literal> that sets the - flags recommended when using DPH. Currently it is equivalent - to - <literal> - -O2 -fno-method-sharing -fdicts-cheap - -fmax-simplifier-iterations20 -fno-spec-constr-threshold - </literal> - </para> - </listitem> - <listitem> - <para> - There are now flags <literal>-fdph-seq</literal> and - <literal>-fdph-par</literal> for selecting which DPH backend - to use. - </para> - </listitem> - <listitem> - <para> - The <literal>-fflatten</literal> flag has been removed. It - never worked and has now been superceded by vectorisation. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Boot Libraries</title> - - <sect3> - <title>array</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was 0.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 4.0.0.0 (was 3.0.2.0) - </para> - </listitem> - <listitem> - <para> - We also ship a base version 3.0.3.0, so legacy code should - continue to work. - </para> - </listitem> - <listitem> - <para>The <literal>Show</literal> instance - for <literal>Ratio</literal> now puts spaces around - the <literal>%</literal>, as required by Haskell 98.</para> - </listitem> - <listitem> - <para> - There is a new module <literal>Control.Category</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>>>></literal> is no longer a method of the - <literal>Arrow</literal> class; instead - <literal>Category</literal> is a superclass of - <literal>Arrow</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>pure</literal> is no longer a method of the - <literal>Arrow</literal> class; use <literal>arr</literal> - instead. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Exception</literal> now uses extensible - exceptions. The old style of exceptions are still available - in <literal>Control.OldException</literal>, but we expect to - remove them in a future release. - </para> - </listitem> - <listitem> - <para> - There is a new function - <literal>System.Exit.exitSuccess :: IO a</literal> - analogous to the existing - <literal>System.Exit.exitFailure :: IO a</literal>. - </para> - </listitem> - <listitem> - <para> - There are new functions - <literal>Data.Either.lefts :: [Either a b] -> [a]</literal>, - <literal>Data.Either.rights :: [Either a b] -> [b]</literal> - and - <literal> - Data.Either.partitionEithers :: [Either a b] -> ([a], [b]) - </literal>. - </para> - </listitem> - <listitem> - <para> - The new function - <literal>Data.List.subsequences :: [a] -> [[a]]</literal> - gives all sublists of a list, e.g. - <literal> - subsequences "abc" == - ["","a","b","ab","c","ac","bc","abc"] - </literal>. - </para> - </listitem> - <listitem> - <para> - The new function - <literal>Data.List.permutations :: [a] -> [[a]]</literal> - gives all permutations of a list, e.g. - <literal> - permutations "abc" == - ["abc","bac","cba","bca","cab","acb"] - </literal>. - </para> - </listitem> - <listitem> - <para> - The new functions - <literal>Data.Traversable.mapAccumL</literal> and - <literal>Data.Traversable.mapAccumR</literal> generalise their - <literal>Data.List</literal> counterparts to work on any - <literal>Traversable</literal> type. - </para> - </listitem> - <listitem> - <para> - The new function - <literal>Control.Exception.blocked :: IO Bool</literal> - tells you whether or not exceptions are blocked (as controlled - by <literal>Control.Exception.(un)block</literal>). - </para> - </listitem> - <listitem> - <para> - There is a new function - <literal>traceShow :: Show a => a -> b -> b</literal> in - <literal>Debug.Trace</literal>. - </para> - </listitem> - <listitem> - <para> - The type of <literal>Control.Monad.forever</literal> has - been generalised from - <literal>Monad m => m a -> m ()</literal> to - <literal>Monad m => m a -> m b</literal>. - </para> - </listitem> - <listitem> - <para> - The new value <literal>GHC.Exts.maxTupleSize</literal> - tells you the largest tuple size that can be used. This is - mostly of use in Template Haskell programs. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> now exports - <literal>Down(..)</literal>, - <literal>groupWith</literal>, - <literal>sortWith</literal> and - <literal>the</literal> which are used in the desugaring of - generalised comprehensions. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> no longer exports the - <literal>Integer</literal> internals. If you want them then - you need to get them directly from the - new <literal>integer</literal> package. - </para> - </listitem> - <listitem> - <para> - The new function <literal>GHC.Conc.threadStatus</literal> - allows you to ask whether a thread is running, blocked on - an MVar, etc. - </para> - </listitem> - <listitem> - <para> - The <literal>Data.Generics</literal> hierarchy has been - moved to a new package <literal>syb</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>GHC.Prim</literal> and - <literal>GHC.PrimopWrappers</literal> modules have been - moved into a new <literal>ghc-prim</literal> package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bytestring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.9.0.1.2 (was 0.9.0.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.6.0.1 (was 1.2.4.0) - </para> - </listitem> - <listitem> - <para> - Many API changes. See the Cabal docs for more information. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>containers</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was 0.1.0.2) - </para> - </listitem> - <listitem> - <para> - Various result type now use <literal>Maybe</literal> rather - than allowing any Monad. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>directory</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.2 (was 1.0.0.1) - </para> - </listitem> - <listitem> - <para> - No longer defines the UNICODE CPP symbol for packages that - use it. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>editline</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.2.1.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>filepath</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.1 (was 1.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-prim</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (unchanged) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>hpc</title> - <itemizedlist> - <listitem> - <para> - Version number 0.5.0.2 (was 0.5.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-locale</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.1 (was 1.0.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.1 (was 1.0.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>packedstring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.0.1 (was 0.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>pretty</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (was 1.0.0.0) - </para> - </listitem> - <listitem> - <para> - There is a new combinator - <literal>zeroWidthText :: String -> Doc</literal> - for printing things like ANSI escape sequences. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>process</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (was 1.0.0.1) - </para> - </listitem> - <listitem> - <para> - The <literal>System.Process</literal> API has been overhauled. - The new API is a superset of the old API, however. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>random</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.1 (was 1.0.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>readline</title> - <itemizedlist> - <listitem> - <para> - This is no longer a bootlib; editline replaces it. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>syb</title> - <itemizedlist> - <listitem> - <para> - This is a new bootlib, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.3.0.0 (was 2.2.0.0) - </para> - </listitem> - <listitem> - <para> - The datatypes now have support for Word primitives. - </para> - </listitem> - <listitem> - <para> - <literal>currentModule :: Q String</literal> has been - replaced with - <literal>location :: Q Loc</literal>, where - <literal>Loc</literal> is a new datatype. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - Version number 2.3.1.0 (was 2.3.0.1) - </para> - </listitem> - <listitem> - <para> - The <literal>System.Posix.Terminal.BaudRate</literal> type - now includes <literal>B57600</literal> and - <literal>B115200</literal> constructors. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Win32</title> - <itemizedlist> - <listitem> - <para> - Version number 2.2.0.0 (was 2.1.1.1) - </para> - </listitem> - <listitem> - <para> - No longer defines the UNICODE CPP symbol for packages that - use it. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> -</sect1> - diff --git a/docs/users_guide/6.12.1-notes.xml b/docs/users_guide/6.12.1-notes.xml deleted file mode 100644 index 9e0ecbfbf8..0000000000 --- a/docs/users_guide/6.12.1-notes.xml +++ /dev/null @@ -1,1304 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-6-12-1"> - <title>Release notes for version 6.12.1</title> - - <para> - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 6.10 branch. - </para> - - <sect2> - <title>Language changes</title> - <itemizedlist> - <listitem> - <para> - The new <literal>TupleSections</literal> language extension - enables tuple sections, such as <literal>(, True)</literal>. - See <xref linkend="tuple-sections" /> for more information. - </para> - </listitem> - - <listitem> - <para> - The new <literal>MonoLocalBinds</literal> language extension - disables type variable generalisation for bindings in - <literal>let</literal> and <literal>where</literal> clauses. - </para> - </listitem> - - <listitem> - <para> - The new <literal>DeriveFunctor</literal>, - <literal>DeriveFoldable</literal> and - <literal>DeriveTraversable</literal> language extensions - enable deriving for the respective type classes. - See <xref linkend="deriving-typeable" /> for more information. - </para> - </listitem> - - <listitem> - <para> - The new <literal>NoNPlusKPatterns</literal> language extension - disables <literal>n+k</literal> patterns. - See <xref linkend="n-k-patterns" /> for more information. - </para> - </listitem> - - <listitem> - <para> - Some improvements have been made to record puns: - </para> - <itemizedlist> - <listitem> - <para> - <literal>C { A.a }</literal> now works, expanding to - <literal>C { A.a = a }</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>-fwarn-unused-matches</literal> no longer - warns about bindings introduced by - <literal>f (C {..}) = x</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>RecordWildCards</literal> language - extension implies - <literal>DisambiguateRecordFields</literal>. - </para> - </listitem> - </itemizedlist> - </listitem> - - <listitem> - <para> - Declarations such as - </para> -<programlisting> -data T a where - MkT :: forall a. Eq a => { x,y :: !a } -> T a -</programlisting> - <para> - are now only accepted if the extension - <literal>TypeOperators</literal> is on. - </para> - </listitem> - - <listitem> - <para> - It is now possible to define GADT records with class - constraints. The syntax is: - </para> -<programlisting> -data T a where - MkT :: forall a. Eq a => { x,y :: !a } -> T a -</programlisting> - </listitem> - - <listitem> - <para> - You can now list multiple GADT constructors with the same type, - e.g.: - </para> -<programlisting> -data T where - A, B :: T - C :: Int -> T -</programlisting> - </listitem> - - <listitem> - <para> - It is now possible to use GADT syntax for data families: - </para> -<programlisting> -data instance T [a] where - T1 :: a -> T [a] -</programlisting> - <para> - and make data instances be GADTs: - </para> -<programlisting> -data instance T [a] where - T1 :: Int -> T [Int] - T2 :: a -> b -> T [(a,b)] -</programlisting> - </listitem> - - <listitem> - <para> - Record updates can now be used with datatypes containing - existential type variables, provided the fields being altered - do not mention the existential types. - </para> - </listitem> - - <listitem> - <para> - The <literal>ImpredicativeTypes</literal> extension now imples - the <literal>RankNTypes</literal> extension. - </para> - </listitem> - - <listitem> - <para> - The <literal>ImpredicativeTypes</literal> extension is no - longer enabled by <literal>-fglasgow-exts</literal>. - </para> - </listitem> - - <listitem> - <para> - You can now give multi-line <literal>DEPRECATED</literal> and - <literal>WARNING</literal> pragmas: - </para> -<programlisting> -{-# DEPRECATED defaultUserHooks - ["Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2" - , "compatibility in which case you must stick with defaultUserHooks"] - #-} -</programlisting> - </listitem> - - <listitem> - <para> - The <literal>-#include</literal> flag and - <literal>INCLUDE</literal> pragma are now deprecated and - ignored. Since version 6.10.1, GHC has generated its own C - prototypes for foreign calls, rather than relying on - prototypes from C header files. - </para> - </listitem> - - <listitem> - <para> - The <literal>threadsafe</literal> foreign import safety level - is now deprecated; use <literal>safe</literal> instead. - </para> - </listitem> - - <listitem> - <para> - There is a new FFI calling convention called - <literal>prim</literal>, which allows calling C-- functions - (see <xref linkend="ffi-prim" />). - Most users are not expected to need this. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Warnings</title> - <itemizedlist> - <listitem> - <para> - A warning is now emitted if an unlifted type is bound in a - lazy pattern (in <literal>let</literal> or - <literal>where</literal> clause, or in an irrefutable pattern) - unless it is inside a bang pattern. - This warning is controlled by the - <literal>-fwarn-lazy-unlifted-bindings</literal> flag. - In a future version of GHC this will be an error. - </para> - </listitem> - - <listitem> - <para> - There are two new warnings if a monadic result of type other than - <literal>m ()</literal> is used in a <literal>do</literal> - block, but its result is not bound. - The flags <literal>-fwarn-unused-do-bind</literal> - and <literal>-fwarn-wrong-do-bind</literal> control - these warnings (see <xref linkend="options-sanity" />). - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-fwarn-dodgy-exports</literal> controls - whether an error is given for exporting a type synonym as - <literal>T(..)</literal>. - </para> - </listitem> - - <listitem> - <para> - Name shadowing warnings are no longer given for variable names - beginning with an underscore. - </para> - </listitem> - - <listitem> - <para> - When <literal>-Werror</literal> is given, we now pass - <literal>-Werror</literal> to <literal>cpp</literal>. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Runtime system</title> - - <para>The following options are all described in - <xref linkend="rts-options-gc" />.</para> - - <itemizedlist> - <listitem> - <para> - The flag <literal>+RTS -N</literal> now automatically - determines how many threads to use, based on the number - of CPUs in your machine. - </para> - </listitem> - - <listitem> - <para> - The parallel GC now uses the same threads as the mutator, - with the consequence that you can no longer select a - different number of threads to use for GC. - The <option>-g<replaceable>n</replaceable></option> RTS - option has been removed, except that <option>-g1</option> is - still accepted for backwards compatibility. - </para> - - <para> - The new flag - <literal>+RTS -qg<replaceable>gen</replaceable></literal> sets - the minimum generation for which parallel garbage collection - is used. Defaults to 1. The flag <literal>-qg</literal> on - its own disables parallel GC. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>+RTS -qb<replaceable>gen</replaceable></literal> - controls load balancing in the parallel GC. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>+RTS -qa</literal> - uses the OS to set thread affinity (experimental). - </para> - </listitem> - - <listitem> - <para> - If you link with the <literal>-eventlog</literal> flag, then - the new flag <literal>+RTS -l</literal> generates - <literal><replaceable>prog</replaceable>.eventlog</literal> - files, which tools such as ThreadScope can use to show the - behaviour of your program (see <xref linkend="rts-eventlog" />). The - <literal>+RTS -D><replaceable>x</replaceable></literal> output - is also sent to the eventlog file if this option is enabled. - The <literal>+RTS -v</literal> flag sends eventlog data to - stderr instead. - </para> - </listitem> - - <listitem> - <para> - There is a new statistic in the <literal>+RTS -s</literal> output: - </para> -<programlisting> -SPARKS: 1430 (2 converted, 1427 pruned) -</programlisting> - <para> - This tells you how many sparks (requests for parallel - execution, caused by calls to <literal>par</literal>) were - created, how many were actually evaluated in parallel - (converted), and how many were found to be already evaluated - and were thus discarded (pruned). Any unaccounted for sparks - are simply discarded at the end of evaluation. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Build system</title> - <itemizedlist> - <listitem> - <para> - We now require GHC >= 6.8 to build. - </para> - </listitem> - - <listitem> - <para> - We now require that gcc is >= 3.0. - </para> - </listitem> - - <listitem> - <para> - In order to generate the parsers, happy >= 1.16 is now - required. The parsers are pre-generated in the source tarball, - so most users will not need Happy. - </para> - </listitem> - - <listitem> - <para> - It is now possible to build GHC with a simple, BSD-licensed - Haskell implementation of Integer, instead of the - implementation on top of GMP. To do so, set - <literal>INTEGER_LIBRARY</literal> to - <literal>integer-simple</literal> in - <literal>mk/build.mk</literal>. - </para> - </listitem> - - <listitem> - <para> - The build system has been rewritten for the 6.12 series. - See <ulink url="http://hackage.haskell.org/trac/ghc/wiki/Building/Using">the building guide</ulink> - for more information. - </para> - </listitem> - - <listitem> - <para> - The build system now uses variables like - <literal>bindir</literal> compatibly with the GNU standard. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Compiler</title> - <itemizedlist> - <listitem> - <para> - The "Interface file version" field of the - <literal>ghc --info</literal> output has been removed, as it - is no longer used by GHC. - </para> - </listitem> - - <listitem> - <para> - There is a new "LibDir" field in the - <literal>ghc --info</literal> output. - </para> - </listitem> - - <listitem> - <para> - A field <replaceable>f</replaceable> in the - <literal>ghc --info</literal> can now be printed with - <literal>ghc --print-<replaceable>f</replaceable></literal>, with letters lower-cased - and spaces replaced by dashes. - </para> - </listitem> - - <listitem> - <para> - GHC now works (as a 32bit application) on OS X Snow Leopard. - </para> - </listitem> - - <listitem> - <para> - The native code generator now works on Sparc Solaris. - </para> - </listitem> - - <listitem> - <para> - Haddock interface files are now portable between different - architectures. - </para> - </listitem> - - <listitem> - <para> - The new linker flag <literal>-eventlog</literal> enables the - <literal>+RTS -l</literal> event logging features. The - <literal>-debug</literal> flag also enables them. - </para> - </listitem> - - <listitem> - <para> - There is a new flag <literal>-feager-blackholing</literal> - which typically gives better performing code when running - with multiple threads. - See <xref linkend="parallel-compile-options" /> for more - information. - </para> - </listitem> - - <listitem> - <para> - There is a new flag <literal>-fbuilding-cabal-package</literal> - which signals to GHC that it is being run by a build system, - rather than invoked directly. This currently means that GHC - gives different error messages in certain situations. - </para> - </listitem> - - <listitem> - <para> - The following flags were static, but are now dynamic: - <literal>-fext-core</literal>, - <literal>-fauto-sccs-on-all-toplevs</literal>, - <literal>-auto-all</literal>, - <literal>-no-auto-all</literal>, - <literal>-fauto-sccs-on-exported-toplevs</literal>, - <literal>-auto</literal>, - <literal>-no-auto</literal>, - <literal>-fauto-sccs-on-individual-cafs</literal>, - <literal>-caf-all</literal> and - <literal>-no-caf-all</literal>. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi</title> - <itemizedlist> - <listitem> - <para> - If the argument to <literal>:set prompt</literal> starts with - a double quote then it is read with Haskell String syntax, - e.g.: - </para> -<programlisting> -Prelude> :set prompt "Loaded: %s\n> " -Loaded: Prelude -> -</programlisting> - </listitem> - - <listitem> - <para> - The arguments to <literal>:set set</literal> - and <literal>:set show</literal> can now be tab completed. - </para> - </listitem> - - <listitem> - <para> - We inherit some benefits from an upgraded version of haskeline: - </para> - <itemizedlist> - <listitem> - <para> - A multitude of new emacs and vi commands. - </para> - </listitem> - - <listitem> - <para> - New preference 'historyDuplicates' to prevent storage - of duplicate lines. - </para> - </listitem> - - <listitem> - <para> - Support PageUp and PageDown keys. - </para> - </listitem> - </itemizedlist> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Template Haskell</title> - <itemizedlist> - <listitem> - <para> - You can now omit the splice notation for top-level declaration - splices, e.g.: - </para> -<programlisting> -data T = T1 | T2 -deriveMyStuff ''T -</programlisting> - </listitem> - - <listitem> - <para> - Splices are now nestable, e.g. you can say - <literal>f x = $(g $(h 'x))</literal>. - </para> - </listitem> - - <listitem> - <para> - It is now possible to splice in types. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Package Handling</title> - <itemizedlist> - <listitem> - <para> - Shared libraries are now supported on x86 and x86_64 Linux. - To use shared libraries, use the <literal>-dynamic</literal> - flag. - See <xref linkend="using-shared-libs" /> for more information. - </para> - </listitem> - - <listitem> - <para> - The new <literal>-fno-shared-implib</literal> flag can be used - to stop GHC generating the <literal>.lib</literal> import - library when making a dynamic library. This reduces the disk - space used when you do not need it. - </para> - </listitem> - - <listitem> - <para> - Packages can now be identified by a "package ID", which is - based on a hash of the ABIs. The new flag - <literal>-package-id</literal> allows packages to be - selected by this identifier (see <xref linkend="package-ids" - />). Package IDs enable GHC to detect potential - incompatibilities between packages and broken dependencies - much more accurately than before. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>--abi-hash</literal>, used thus: - </para> -<programlisting> -ghc --abi-hash M1 M2 ... -</programlisting> - <para> - prints the combined hash of all the modules listed. It is - used to make package IDs. - </para> - </listitem> - - <listitem> - <para> - You can now give <literal>ghc-pkg</literal> a - <literal>-v0</literal> flag to make it be silent, - <literal>-v1</literal> for normal verbosity (the default), - or <literal>-v2</literal> or <literal>-v</literal> for - verbose output. - </para> - </listitem> - - <listitem> - <para> - Rather than being a single <literal>package.conf</literal> file, - package databases now consist of a directory containing one - file per package, and a binary cache of the information. - GHC should be much faster to start up when the package - database grows large. - </para> - </listitem> - - <listitem> - <para> - There is a new command <literal>ghc-pkg init</literal> to - create a package database. - </para> - </listitem> - - <listitem> - <para> - There is a new command <literal>ghc-pkg dot</literal> to - generate a GraphViz graph of the dependencies between - installed packages. - </para> - </listitem> - - <listitem> - <para> - There is a new command <literal>ghc-pkg recache</literal> to - update the package database cache should it become out of - date, or for registering packages manually. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Libraries</title> - - <para> - GHC no longer comes with any extralibs; instead, the - <ulink url="http://hackage.haskell.org/platformi/">Haskell Platform</ulink> - will provide a consistent set of additional libraries. - </para> - - <sect3> - <title>array</title> - <itemizedlist> - <listitem> - <para> - Version number 0.3.0.0 (was 0.2.0.0) - </para> - </listitem> - - <listitem> - <para> - The <literal>Data.Array.Diff</literal> module has been moved - to its own package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 4.2.0.0 (was 4.1.0.0) - </para> - </listitem> - - <listitem> - <para> - We also ship a base version 3.0.3.2 (was 3.0.3.1), so legacy - code should continue to work. This package is now deprecated, - and will be removed in a future version of GHC. - </para> - </listitem> - - <listitem> - <para> - Handle IO now supports automatic character set encoding - and newline translation. For more information, see the - "Unicode encoding/decoding" and "Newline conversion" sections - in the <literal>System.IO</literal> haddock docs. - </para> - </listitem> - - <listitem> - <para> - Lazy I/O now throws an exception if an error is - encountered, in a divergence from the Haskell 98 spec which - requires that errors are discarded (see Section 21.2.2 of - the Haskell 98 report). The exception thrown is the usual - IO exception that would be thrown if the failing IO - operation was performed in the IO monad, and can be caught - by <literal>System.IO.Error.catch</literal> - or <literal>Control.Exception.catch</literal>. - </para> - </listitem> - - <listitem> - <para> - It is now possible to create your own handles. - For more information, see the - <literal>GHC.IO.Handle</literal> haddock docs. - </para> - </listitem> - - <listitem> - <para> - <literal>System.IO</literal> now exports two new functions, - <literal>openTempFileWithDefaultPermissions</literal> and - <literal>openBinaryTempFileWithDefaultPermissions</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Fixed</literal> now provides - <literal>Data</literal> and <literal>Typeable</literal> - instances for <literal>Fixed</literal>, and exports - a number of new types: - <literal>E0</literal>, <literal>Uni</literal>, - <literal>E1</literal>, <literal>Deci</literal>, - <literal>E2</literal>, <literal>Centi</literal>, - <literal>E3</literal>, <literal>Milli</literal>, - <literal>E9</literal> and <literal>Nano</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Control.Exception</literal>, - <literal>BlockedOnDeadMVar</literal> - has been renamed to - <literal>BlockedIndefinitelyOnMVar</literal> - and <literal>BlockedIndefinitely</literal> - has been renamed to - <literal>BlockedIndefinitelyOnSTM</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Control.OldException</literal> module has been - deprecated. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Posix.Internals.setNonBlockingFD</literal> - now takes an additional <literal>Bool</literal> argument, so - you can turn blocking back on again. - </para> - </listitem> - - <listitem> - <para> - A new function <literal>eof</literal> has been added to - <literal>Text.ParserCombinators.ReadP</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Foreign.C.Types.CLDouble</literal> type has - been removed. It was never correct, but just a duplicate of - <literal>Foreign.C.Types.CDouble</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, the - <literal>StringRep</literal> and - <literal>StringConstr</literal> constructors have been - removed. The <literal>CharRep</literal> and - <literal>CharConstr</literal> constructors should be used - instead. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, - <literal>mkIntConstr</literal> has been deprecated in favour - of the new <literal>mkIntegralConstr</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, - <literal>mkFloatConstr</literal> has been deprecated in - favour of the new <literal>mkRealConstr</literal>. - </para> - </listitem> - - <listitem> - <para> - In <literal>Data.Data</literal>, - <literal>mkNorepType</literal> has been deprecated in - favour of the new <literal>mkNoRepType</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bytestring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.9.1.5 (was 0.9.1.4) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.8.0.0 (was 1.6.0.3) - </para> - </listitem> - - <listitem> - <para> - Many API changes. See the Cabal docs for more information. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>containers</title> - <itemizedlist> - <listitem> - <para> - Version number 0.3.0.0 (was 0.2.0.1) - </para> - </listitem> - - <listitem> - <para> - <literal>mapAccumRWithKey</literal> has been added to - <literal>Data.IntMap</literal>. - </para> - </listitem> - - <listitem> - <para> - A <literal>Traversable</literal> instance has been added to - <literal>Data.IntMap.IntMap</literal>. - </para> - </listitem> - - <listitem> - <para> - The types of <literal>Data.IntMap.intersectionWith</literal> - and <literal>Data.IntMap.intersectionWithKey</literal> have - been changed from - </para> -<programlisting> -intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a -intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a -</programlisting> - <para> - to - </para> -<programlisting> -intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -</programlisting> - </listitem> - - <listitem> - <para> - The types of <literal>Data.IntMap.findMin</literal> - and <literal>Data.IntMap.findMax</literal> have - been changed from - </para> -<programlisting> -findMin :: IntMap a -> a -findMax :: IntMap a -> a -</programlisting> - <para> - to - </para> -<programlisting> -findMin :: IntMap a -> (Int,a) -findMax :: IntMap a -> (Int,a) -</programlisting> - </listitem> - - <listitem> - <para> - <literal>Data.Map</literal> now exports - <literal>mapAccumRWithKey</literal>, - <literal>foldrWithKey</literal>, - <literal>foldlWithKey</literal> and - <literal>toDescList</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Sequence</literal> now exports - <literal>replicate</literal>, - <literal>replicateA</literal>, - <literal>replicateM</literal>, - <literal>iterateN</literal>, - <literal>unfoldr</literal>, - <literal>unfoldl</literal>, - <literal>scanl</literal>, - <literal>scanl1</literal>, - <literal>scanr</literal>, - <literal>scanr1</literal>, - <literal>tails</literal>, - <literal>inits</literal>, - <literal>takeWhileL</literal>, - <literal>takeWhileR</literal>, - <literal>dropWhileL</literal>, - <literal>dropWhileR</literal>, - <literal>spanl</literal>, - <literal>spanr</literal>, - <literal>breakl</literal>, - <literal>breakr</literal>, - <literal>partition</literal>, - <literal>filter</literal>, - <literal>sort</literal>, - <literal>sortBy</literal>, - <literal>unstableSort</literal>, - <literal>unstableSortBy</literal>, - <literal>elemIndexL</literal>, - <literal>elemIndicesL</literal>, - <literal>elemIndexR</literal>, - <literal>elemIndicesR</literal>, - <literal>findIndexL</literal>, - <literal>findIndicesL</literal>, - <literal>findIndexR</literal>, - <literal>findIndicesR</literal>, - <literal>foldlWithIndex</literal>, - <literal>foldrWithIndex</literal>, - <literal>mapWithIndex</literal>, - <literal>zip</literal>, - <literal>zipWith</literal>, - <literal>zip3</literal>, - <literal>zipWith3</literal>, - <literal>zip4</literal> and - <literal>zipWith4</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>directory</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.0 (was 1.0.0.3) - </para> - </listitem> - - <listitem> - <para> - A new function <literal>copyPermissions</literal> has been - added to <literal>System.Directory</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title> - dph - (dph-base, dph-par, dph-prim-interface, dph-prim-par, - dph-prim-seq, dph-seq) - </title> - <itemizedlist> - <listitem> - <para> - All the dph packages are version 0.4.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>extensible-exceptions</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.1.1 (was 0.1.1.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>filepath</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.3 (was 1.1.0.2) - </para> - </listitem> - - <listitem> - <para> - The list of characters that are invalid in filenames on - Windows now includes <literal>\</literal> (backslash). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-binary</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-prim</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was 0.1.0.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.1 (was 1.0.1.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>hpc</title> - <itemizedlist> - <listitem> - <para> - Version number 0.5.0.4 (was 0.5.0.3) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer-gmp</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.0 (was called integer, version 0.1.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer-simple</title> - <itemizedlist> - <listitem> - <para> - This is a new boot package, version 0.1.0.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-locale</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.2 (was 1.0.0.1) - </para> - </listitem> - - <listitem> - <para> - Date and time in ISO8601 format are now separated by - <literal>T</literal> rather than a space. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.3 (was 1.0.0.2) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>packedstring</title> - <itemizedlist> - <listitem> - <para> - This is no longer a boot package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>pretty</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.1 (was 1.0.1.0) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>process</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.2 (was 1.0.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>random</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.2 (was 1.0.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>syb</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.0.2 (was 0.1.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.4.0.0 (was 2.3.0.1) - </para> - </listitem> - - <listitem> - <para> - Support for <literal>inline</literal> and - <literal>specialise</literal> pragmas has been added. - </para> - </listitem> - - <listitem> - <para> - Support for bang patterns has been added - </para> - </listitem> - - <listitem> - <para> - Support for kind annotations has been added - </para> - </listitem> - - <listitem> - <para> - Support for equality constraints has been added - </para> - </listitem> - - <listitem> - <para> - Support for type family declarations has been added - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>time</title> - <itemizedlist> - <listitem> - <para> - This is a new boot package, version 1.1.4. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - Version number 2.4.0.0 (was 2.3.2.0) - </para> - </listitem> - - <listitem> - <para> - <literal>System.Posix.IO</literal> now exports - <literal>fdReadBuf</literal> and - <literal>fdWriteBuf</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Posix.Process.executeFile</literal> now - returns <literal>IO a</literal> instead of - <literal>IO ()</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Win32</title> - <itemizedlist> - <listitem> - <para> - Version number 2.2.0.1 (was 2.2.0.0) - </para> - </listitem> - - <listitem> - <para> - <literal>System.Win32.File</literal> now exports - <literal>WIN32_FIND_DATA</literal>, - <literal>FindData</literal>, - <literal>getFindDataFileName</literal>, - <literal>findFirstFile</literal>, - <literal>findNextFile</literal> and - <literal>findClose</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Win32.Info</literal> now exports - <literal>getCurrentDirectory</literal>, - <literal>getTemporaryDirectory</literal>, - <literal>getFullPathName</literal> and - <literal>searchPath</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.Win32.Types</literal> now exports - <literal>HRESULT</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new module <literal>System.Win32.Shell</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> -</sect1> - diff --git a/docs/users_guide/6.6-notes.xml b/docs/users_guide/6.6-notes.xml deleted file mode 100644 index a04b99e4c0..0000000000 --- a/docs/users_guide/6.6-notes.xml +++ /dev/null @@ -1,1718 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-6-6"> - <title>Release notes for version 6.6</title> - - <sect2> - <title>User-visible compiler changes</title> - <itemizedlist> - <listitem> - <para> - GHC now supports SMP: - when you compile with <option>-threaded</option>, you now get - an RTS flag <option>-N</option> that allows you to specify the - number of OS threads that GHC should use. Defaults to 1. - See <xref linkend="using-smp" /> and <xref - linkend="lang-parallel" />. - </para> - </listitem> - <listitem> - <para> - GHC now handles impredicative polymorphism; see <xref linkend="impredicative-polymorphism" />. - </para> - </listitem> - <listitem> - <para> - There are significant changes to the way scoped type variables work, - and some programs that used to compile may no longer do so. - The new story is documented in <xref linkend="scoped-type-variables" />. - (<ulink url="http://www.haskell.org/pipermail/glasgow-haskell-users/2006-January/009565.html"> Simon's e-mail</ulink> - gives some background, but the user manual should be complete (tell - us if not), and - certainly takes precedence if there is any conflict.) - </para> - </listitem> - <listitem> - <para> - GHC now supports bang patterns to require a function is strict - in a given argument, e.g. - <programlisting> - f (!x, y) = [x,y]</programlisting> - is equivalent to - <programlisting> - f (x, y) | x `seq` False = undefined - | otherwise = [x,y]</programlisting> - See <xref linkend="bang-patterns" /> for more details. - </para> - </listitem> - <listitem> - <para> - The restriction that you cannot use two packages together if - they contain a module with the same name has been removed. - In implementation terms, the package name is now included in - every exported symbol name in the object file, so that - modules with the same name in different packages do not - clash. See <xref linkend="package-overlaps" />. - </para> - </listitem> - <listitem> - <para> - GHC now treats source files as UTF-8 (ASCII is a strict - subset of UTF-8, so ASCII source files will continue to - work as before). However, invalid UTF-8 sequences are - ignored in comments, so ASCII code with comments in, for - example, Latin-1 will also work. - </para> - - <para> - A way to have Latin-1 source files pre-processed by GHC is - described in <xref linkend="pre-processor" />. - </para> - </listitem> - <listitem> - <para> - GADTs can now use record syntax. Also, if the datatype could - have been declared with Haskell 98 syntax then deriving - clauses are permitted. For more info see <xref linkend="gadt" />. - </para> - </listitem> - <listitem> - <para> - There is a new pragma <literal>LANGUAGE</literal> which allows - extensions to be specified portably, i.e. without having to - resort to the <literal>OPTIONS_GHC</literal> pragma and giving - GHC-specific options. The arguments to the pragma are the same - extensions that Cabal knows about. More info in - <xref linkend="language-pragma" />. - </para> - </listitem> - <listitem> - <para> - When you use <command>ghc --make</command>, GHC will now take - the executable filename from the name of the file containing - the <literal>Main</literal> module rather than using - <filename>a.out</filename>. The <filename>.exe</filename> - extension is appended on Windows, and it can of course be - overridden with <option>-o</option>. - </para> - </listitem> - <listitem> - <para> - GHC's garbage collector now deals more intelligently with - mutable data, so you mostly no longer need to worry about GC - performance when a lot of memory is taken up by - <literal>STArray</literal>s, <literal>IOArray</literal>s, - <literal>STRef</literal>s or <literal>IORef</literal>s. - For more details see - <ulink url="http://hackage.haskell.org/trac/ghc/ticket/650">trac bug #650</ulink>. - </para> - </listitem> - <listitem> - <para> - GHC now allows more generalisation when typing mutually - recursive bindings, resulting in more programs being accepted. - See <xref linkend="typing-binds" /> for more details. - </para> - </listitem> - <listitem> - <para> - The rules for instance declarations have been further relaxed. - You are now permitted to have instances whose heads contain - only type variables, e.g. - <programlisting> - instance C a</programlisting> - and instances whose constraints are not only type variables, - e.g. - <programlisting> - instance C2 Int a => C3 [a] b</programlisting> - For more details, see <xref linkend="instance-rules" />. - </para> - </listitem> - <listitem> - <para> - The following flags (and, where appropriate, their inverses) - used to be static (can only be given on - the command line) but are now dynamic (can also be given in - an <literal>OPTIONS_GHC</literal> pragma or with - <literal>:set</literal> in GHCi): - <option>-c</option>, - <option>-hcsuf</option>, - <option>-hidir</option>, - <option>-hisuf</option>, - <option>-o</option>, - <option>-odir</option>, - <option>-ohi</option>, - <option>-osuf</option>, - <option>-keep-hc-file</option>, - <option>-keep-s-file</option>, - <option>-keep-raw-s-file</option>, - <option>-keep-tmp-files</option>, - <option>-tmpdir</option>, - <option>-i</option>, - <option>-package</option>, - <option>-hide-package</option>, - <option>-ignore-package</option>, - <option>-package-conf</option>, - <option>-no-user-package-conf</option>, - <option>-fcontext-stack</option>, - <option>-fexcess-precision</option>, - <option>-fignore-asserts</option>, - <option>-fignore-interface-pragmas</option>, - <option>-I</option>, - <option>-framework</option>, - <option>-framework-path</option>, - <option>-l</option>, - <option>-L</option>, - <option>-main-is</option>, - <option>-no-hs-main</option>, - <option>-split-objs</option>, - <option>-pgmL</option>, - <option>-pgmP</option>, - <option>-pgmc</option>, - <option>-pgma</option>, - <option>-pgml</option>, - <option>-pgmdll</option>, - <option>-pgmF</option>, - <option>-optl</option>, - <option>-optdll</option>, - <option>-optdep</option>, - <option>-fno-asm-mangling</option>. - See <xref linkend="static-dynamic-flags" /> for more on - the meaning of static and dynamic flags, and - <xref linkend="flag-reference" /> for more on the flags - themselves. - </para> - </listitem> - <listitem> - <para> - There is a new flag <option>-x</option> for overriding the - default behaviour for source files; see - <xref linkend="overriding-suffixes" /> details. - </para> - </listitem> - <listitem> - <para> - The - <option>-no-recomp</option><indexterm><primary><option>-no-recomp</option></primary></indexterm> - option is now called - <option>-fforce-recomp</option><indexterm><primary><option>-fforce-recomp</option></primary></indexterm>. - (the old name is still accepted for backwards compatibility, - but will be removed in the future). - </para> - </listitem> - <listitem> - <para> - The <option>-fglobalise-toplev-names</option> - flag has been removed. - </para> - </listitem> - <listitem> - <para> - The <option>-fallow-overlapping-instances</option> flag is - implied by the <option>-fallow-incoherent-instances</option> - flag. - </para> - </listitem> - <listitem> - <para> - The directory that the <filename>foo_stub.c</filename> and - <filename>foo_stub.h</filename> files are put in can now be - controlled with the <option>-stubdir</option> flag. - See <xref linkend="options-output" /> for more details. - </para> - </listitem> - <listitem> - <para> - When the <option>-fno-implicit-prelude</option> is given, - the equality test performed when pattern matching against an - overloaded numeric literal now uses the - <literal>(==)</literal> in scope, rather than the one from - <literal>Prelude</literal>. Likewise, the subtraction and - inequality test performed when pattern matching against - <literal>n+k</literal> patterns uses the - <literal>(-)</literal> and <literal>(>=)</literal> in scope. - </para> - </listitem> - <listitem> - <para> - Another change to <option>-fno-implicit-prelude</option>: - with the exception of the arrow syntax, the types of - functions used by sugar (such as do notation, numeric - literal patterns) need not match the types of the - <literal>Prelude</literal> functions normally used. - </para> - </listitem> - <listitem> - <para> - The <literal>InstalledPackageInfo</literal> syntax has - changed. Now - instead of <literal>extra-libs</literal> we have - <literal>extra-libraries</literal>, - instead of <literal>extra-hugs-opts</literal> we have - <literal>hugs-options</literal>, - instead of <literal>extra-cc-opts</literal> we have - <literal>cc-options</literal>, - instead of <literal>extra-ld-opts</literal> we have - <literal>ld-options</literal>, - and instead of <literal>extra-frameworks</literal> we have - <literal>frameworks</literal>. - See <xref linkend="installed-pkg-info" /> for details. - </para> - </listitem> - <listitem> - <para> - If you <literal>newtype</literal> the IO monad, e.g. - <programlisting> - newtype MyIO a = MyIO (IO a)</programlisting> - then GHC will now allow you to have FFI calls return - <literal>MyIO <replaceable>t</replaceable></literal> - rather than just - <literal>IO <replaceable>t</replaceable></literal>. - See <xref linkend="ffi-newtype-io"/> - </para> - </listitem> - <listitem> <para> GHC's mechansim for deriving user-defined classes - for newtypes has been further generalised, to multi-parameter type - classes and higher-kinded types. See <xref - linkend="newtype-deriving"/>. - </para></listitem> - <listitem> - <para> - By default, pattern bindings in GHC are now monomorphic. - This means that some valid Haskell 98 programs will get - rejected, but we believe they will be few in number. - To revert to the old behaviour use the - <option>-fno-mono-pat-binds</option> flag. - More details are in <xref linkend="options-language" />. - </para> - </listitem> - <listitem> - <para> - GHCi already does more defaulting than Haskell 98 so that, for - example, <literal>reverse []</literal> shows a result rather - than giving an ambiguous type variable error. There is now a - flag <option>-fextended-default-rules</option> to use these - defaulting rules with GHC too. - More details are in <xref linkend="extended-default-rules" />. - </para> - </listitem> - <listitem> - <para> - You can now give both class and instance declarations in - <filename>.hs-boot</filename> files. More details in - <xref linkend="mutual-recursion" />. - </para> - </listitem> - <listitem> - <para> - Linear implicit parameters have been scheduled for removal for some - time. In 6.6 we've removed them from the user manual, and they may - well disappear from the compiler itself in 6.6.1. - </para> - </listitem> - <listitem> - <para> - If the program is idle for a certain amount of time then GHC - will now take the opportunity to do a major garbage collection. - The amount of idle time that is required before that happens - is controlled by the new <literal>-I</literal> RTS flag. - There is more detail in <xref linkend="rts-options-gc" />. - </para> - </listitem> - <listitem> - <para> - It is now possible to control the frequency that the RTS clock - ticks at with the new <literal>-V</literal> RTS flag. This is - normally handled automatically by other flags, but this flag - is needed if you want to increase the resolution of the time - profiler. - For more details see <xref linkend="rts-options-misc" />. - </para> - </listitem> - <listitem> - <para> - The old syntax for FFI declarations (deprecated since 5.04) - is no longer accepted. - </para> - </listitem> - <listitem> - <para> - The <option>-split-objs</option> flag, which when used to compile - libraries means executables using the library will be smaller, - can now be used with <option>--make</option> and hence - can be used by cabal. - See <xref linkend="options-linker" /> for more information. - </para> - </listitem> - <listitem> - <para> - Template Haskell used to have limited support for type signatures in - patterns, but since that design is in flux for Haskell (let alone - Template Haskell), we've removed type signatures in patterns from - Template Haskell. - </para> - </listitem> - <listitem> - <para> - GHC now supports postfix operators, as a simple generalisation of - left sections (<xref linkend="postfix-operators"/>). - </para> - </listitem> - <listitem> - <para> - Parallel arrays, as enabled by <literal>-fparr</literal>, no - longer work. They'll be coming back shortly, in full glory. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi changes</title> - - <itemizedlist> - <listitem> - <para> - GHCi now allows tab completion of in-scope names and modules - on platforms that use readline (i.e. not Windows). - </para> - </listitem> - <listitem> - <para> - GHCi now has a <literal>:main</literal> command that allows - you to call the <literal>main</literal> function with - command-line arguments. - See <xref linkend="ghci-commands" /> for more information. - </para> - </listitem> - <listitem> - <para> - GHCi now has <literal>:ctags</literal> and - <literal>:etags</literal> commands to generate tags files for - vi-style and emacs-style editors respectively. - See <xref linkend="ghci-commands" /> for more information. - </para> - </listitem> - <listitem> - <para> - GHCi now has an <literal>:edit</literal> command which pops - up an editor on the most recently loaded file, or a - specified file. See <xref linkend="ghci-commands" /> for - more information. - </para> - </listitem> - <listitem> - <para> - GHCi now invokes <literal>print</literal> by default on the - result of IO actions and bindings at the prompt. This is - occasionally not what you want, so it can be disabled (at - least for bindings) with - <literal>:set -fno-print-bind-result</literal>. See <xref - linkend="ghci-stmts" />.</para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Libraries</title> - <para> - Libraries are now divided into core libraries (those that are - necessary to build GHC) and extra libraries. Decoupling the extra - libraries means that they can release independently of GHC - releases, and makes development builds of GHC quicker as they no - longer need to build unnecessary libraries. - </para> - - <para> - The hslibs libraries have finally been removed. - </para> - </sect2> - - <sect2> - <title>Core Libraries</title> - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 1.0). - </para> - </listitem> - <listitem> - <para> - We now have <literal>Read</literal> and - <literal>Show</literal> instances for up to 15-tuples (used - to be up to 5-tuples). - </para> - </listitem> - <listitem> - <para> - New module <literal>Control.Applicative</literal> that - describes a structure intermediate between a functor and - a monad: it provides pure expressions and sequencing, but - no binding. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Exception</literal> now exports - <literal>bracketOnError</literal>, which behaves like - <literal>bracket</literal> but only runs the final - action if the main action raised an error. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>Control.Monad.Instances</literal> which - provides <literal>Monad</literal> and - <literal>Functor</literal> instances for - <literal>((->) r)</literal> (were in - <literal>mtl</literal>'s - <literal>Control.Monad.Reader</literal>), - a <literal>Functor</literal> instance for - <literal>(Either a)</literal> (was in <literal>mtl</literal>'s - <literal>Control.Monad.Error</literal>) and a - <literal>Functor</literal> instance for - <literal>((,) a)</literal> (new). - </para> - </listitem> - <listitem> - <para> - The <literal>MonadFix</literal> instance for - <literal>((->) r)</literal> is now in - <literal>Control.Monad.Fix</literal> (was in - <literal>mtl</literal>'s - <literal>Control.Monad.Reader</literal>). - </para> - </listitem> - <listitem> - <para> - <literal>Control.Monad.ST</literal> now exports - <literal>unsafeSTToIO</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>HasBounds</literal> class has been removed from - <literal>Data.Array.Base</literal>, and its - <literal>bounds</literal> method is now in the - <literal>IArray</literal> class. The - <literal>MArray</literal> class - has also gained a method <literal>getBounds</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Array.Base</literal> now provides an - <literal>MArray (STArray s) e (Lazy.ST s)</literal> - instance. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Array.Storable</literal> now exports a - function <literal>unsafeForeignPtrToStorableArray</literal>. - </para> - </listitem> - <listitem> - <para> - The new <literal>Data.ByteString</literal> hierarchy - provides time and space-efficient byte vectors. - The old <literal>Data.PackedString</literal> module is now - deprecated as a result, although there is not yet a - replacement if you need full unicode support. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> now provides a function - <literal>inline</literal> which, provided the RHS is visible - to the compiler, forcibly inlines its argument. - Otherwise, it acts like <literal>id</literal>. - For more details, see <xref linkend="special-ids" />. - </para> - </listitem> - <listitem> - <para> - <literal>GHC.Exts</literal> now provides a function - <literal>lazy</literal>, where <literal>lazy f</literal> - behaves like <literal>f</literal>, except GHC is forced - to believe that it is lazy in its first argument. - For more details, see <xref linkend="special-ids" />. - </para> - </listitem> - <listitem> - <para> - <literal>Data.FiniteMap</literal> has been removed - (deprecated since 6.4). Use <literal>Data.Map</literal> - instead. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Char</literal> now exports - <literal>isLetter</literal>, - <literal>isMark</literal>, - <literal>isNumber</literal>, - <literal>isPunctuation</literal>, - <literal>isSymbol</literal>, - <literal>isSeparator</literal>, - <literal>isAsciiUpper</literal>, - <literal>isAsciiLower</literal> and - <literal>toTitle</literal>. - It also exports a function - <literal>generalCategory</literal> that tells you the - category of a character in terms of a datatype - <literal>GeneralCategory</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Dynamic</literal> now exports a function - <literal>dynTypeRep</literal>. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Eq</literal> which - just exports the <literal>Eq</literal> class. - Likewise, a new module <literal>Data.Ord</literal> - exports the <literal>Ord</literal> class, as well as the - handy <literal>comparing</literal> function. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Fixed</literal> - providing fixed-precision arithmetic. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Foldable</literal> - providing a class for foldable datatypes. It gives instances - for <literal>Maybe</literal>, <literal>[]</literal> and - <literal>Array i</literal>. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Traversable</literal> - providing a class for data structures that can be traversed - from left to right. It gives instances - for <literal>Maybe</literal>, <literal>[]</literal> and - <literal>Array i</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.FunctorM</literal> has been deprecated; - use <literal>Data.Foldable</literal> and - <literal>Data.Traversable</literal> instead. - </para> - </listitem> - <listitem> - <para> - The <literal>toConstr</literal> definitions for tuples in - <literal>Data.Generics.Instances</literal> now actually - evaluate their arguments to tuples before returning - anything. - </para> - </listitem> - <listitem> - <para> - <literal>Data.IntMap</literal> now exports - <literal>notMember</literal>, - <literal>alter</literal>, - <literal>mapMaybe</literal>, - <literal>mapMaybeWithKey</literal>, - <literal>mapEither</literal> and - <literal>mapEitherWithKey</literal>. - It also has <literal>Monoid</literal>, - <literal>Foldable</literal> and <literal>Read</literal> - instances. - </para> - </listitem> - <listitem> - <para> - <literal>Data.IntSet</literal> now exports - <literal>notMember</literal>. It also has - <literal>Monoid</literal> and <literal>Read</literal> - instances. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Map</literal> now exports - <literal>notMember</literal>, - <literal>alter</literal>, - <literal>mapMaybe</literal>, - <literal>mapMaybeWithKey</literal>, - <literal>mapEither</literal>, - <literal>mapEitherWithKey</literal>, - <literal>minView</literal> and - <literal>maxView</literal>. - It also has <literal>Monoid</literal>, - <literal>Traversable</literal>, <literal>Foldable</literal> - and <literal>Read</literal> instances. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Set</literal> now exports - <literal>notMember</literal>, - <literal>minView</literal> and - <literal>maxView</literal>. - It also has <literal>Monoid</literal>, - <literal>Foldable</literal> - and <literal>Read</literal> instances. - </para> - - <para> - The old, deprecated (since 6.4) interface consisting of - <literal>emptySet</literal>, - <literal>mkSet</literal>, - <literal>setToList</literal>, - <literal>unitSet</literal>, - <literal>elementOf</literal>, - <literal>isEmptySet</literal>, - <literal>cardinality</literal>, - <literal>unionManySets</literal>, - <literal>minusSet</literal>, - <literal>mapSet</literal>, - <literal>intersect</literal>, - <literal>addToSet</literal> and - <literal>delFromSet</literal> has been removed. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Monoid</literal> no longer contains the - <literal>Monoid</literal> - instances for <literal>Map</literal>, - <literal>IntMap</literal>, <literal>Set</literal> and - <literal>IntSet</literal>. They have been moved to their own - modules, as above. The <literal>(a -> a)</literal> instance - has been replaced with a - <literal>Monoid b => Monoid (a -> b)</literal> instance. - The module also now exports - <literal>Dual</literal>, - <literal>Endo</literal>, - <literal>All</literal>, - <literal>Any</literal>, - <literal>Sum</literal> and - <literal>Product</literal> types, and - <literal>Monoid</literal> instances for them. - </para> - </listitem> - <listitem> - <para> - There is a new module <literal>Data.Sequence</literal> - for finite sequences. The <literal>Data.Queue</literal> - module is now deprecated in favour of this faster, more - featureful replacement. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Tree</literal> now has - <literal>Data</literal>, <literal>Typeable</literal>, - <literal>Traversable</literal> and - <literal>Foldable</literal> - instances for the - <literal>Tree</literal> datatype. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Typeable</literal> now uses - <option>-fallow-overlapping-instances</option>, so the - generic instances can be overriden for your own datatypes. - </para> - </listitem> - <listitem> - <para> - <literal>Debug.Trace</literal> now exports - <literal>traceShow</literal>, which is the same as - <literal>trace</literal> except its first argument can be - any showable thing rather than being required to be a - string. - </para> - </listitem> - <listitem> - <para> - <literal>Foreign.C.Types</literal> now also defines - <literal>CIntPtr</literal>, - <literal>CUIntPtr</literal>, - <literal>CIntMax</literal> and - <literal>CUIntMax</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Foreign.ForeignPtr</literal> now exports - <literal>FinalizerEnvPtr</literal>, - <literal>newForeignPtrEnv</literal> and - <literal>addForeignPtrFinalizerEnv</literal>. - Together, these allow the use of finalizers which are passed - an additional environment parameter. - </para> - </listitem> - <listitem> - <para> - <literal>Foreign.Marshal.Utils</literal> no longer exports - the <literal>withObject</literal> function, deprecated since - 5.04; use <literal>with</literal> instead. - </para> - </listitem> - <listitem> - <para> - Foreign.Ptr now also defines - <literal>IntPtr</literal>, - <literal>ptrToIntPtr</literal>, - <literal>intPtrToPtr</literal>, - <literal>WordPtr</literal>, - <literal>ptrToWordPtr</literal> and - <literal>wordPtrToPtr</literal>. - </para> - </listitem> - <listitem> - <para> - There are now <literal>Bounded</literal> instances for up to - 15-tuples (used to be up to 4-tuples). - </para> - </listitem> - <listitem> - <para> - The <literal>Text.Html</literal> and - <literal>Text.Html.BlockTable</literal> modules have now - been removed, with the new <literal>html</literal> and - <literal>xhtml</literal> packages providing replacements. - </para> - </listitem> - <listitem> - <para> - <literal>Text.Read</literal> now exports a function - <literal>parens</literal> which parses a value in an - arbitrary number of parentheses. - </para> - </listitem> - <listitem> - <para> - The <literal>ForeignPtr</literal> datatype has been altered - to make it more efficient. There are also new functions - <literal>mallocPlainForeignPtr</literal> and - <literal>mallocPlainForeignPtrBytes</literal> which - do not allow you to attach a finalizer to the - <literal>ForeignPtr</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>Text.Regex</literal> and - <literal>Text.Regex.Posix</literal> modules have been removed. - Instead, use the new <literal>regex-compat</literal> package - for a drop-in <literal>Text.Regex</literal> replacement, or - the new library in the new <literal>regex-posix</literal> - package. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.6 (was 1.1.4). - </para> - </listitem> - <listitem> - <para> - Support for JHC, symmetric to the support for the other - implementations, has been added throughout. - </para> - </listitem> - <listitem> - <para> - Support for object splitting and building in-place - has been added throughout. - </para> - </listitem> - <listitem> - <para> - Added a <filename>debianTemplate</filename> directory with - templates for building Debian packages from Cabal packages. - </para> - </listitem> - <listitem> - <para> - There are now modules - <literal>Distribution.Simple.<replaceable>compiler</replaceable></literal> - for each of <literal>GHC</literal>, <literal>NHC</literal>, - <literal>Hugs</literal> and <literal>JHC</literal>. - The <literal>Distribution.Simple.Build</literal> and - <literal>Distribution.Simple.Install</literal> modules have - shrunk correspondingly. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.GetOpt</literal> is no longer a - visible module. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple</literal> exports a function - <literal>defaultMainArgs</literal>, which is identical to - <literal>defaultMain</literal> except that the arguments are - given as a list of strings rather than being retrieved with - <literal>getArgs</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple.Configure</literal> - no longer exports - <literal>LocalBuildInfo</literal>, - but does now export - <literal>configDependency</literal> and - <literal>configCompilerAux</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple.LocalBuildInfo</literal> now - exports <literal>mkHaddockDir</literal>, - <literal>distPref</literal>, - <literal>srcPref</literal>, - <literal>autogenModulesDir</literal> and - <literal>mkIncludeDir</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.PackageDescription</literal> now - exports <literal>haddockName</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Distribution.Simple.Utils</literal> now exports - <literal>copyDirectoryRecursiveVerbose</literal>, - <literal>dirOf</literal>, - <literal>distPref</literal>, - <literal>haddockPref</literal> and - <literal>srcPref</literal>. - It no longer exports <literal>mkGHCiLibName</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>parsec</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - No other change. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>readline</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>regex-base</title> - <itemizedlist> - <listitem> - <para> - Version 0.71. - </para> - </listitem> - <listitem> - <para> - New library that provides common functions for different - regex backends. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>regex-compat</title> - <itemizedlist> - <listitem> - <para> - Version 0.71. - </para> - </listitem> - <listitem> - <para> - New package providing a replacement - <literal>Text.Regex</literal> module. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>regex-posix</title> - <itemizedlist> - <listitem> - <para> - Version 0.71. - </para> - </listitem> - <listitem> - <para> - A new package providing POSIX regexes. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>stm</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 1.0). - </para> - </listitem> - <listitem> - <para> - A new module <literal>Control.Monad.STM</literal> - contains the - <literal>MonadPlus</literal> instance for - <literal>STM</literal> and the function - <literal>check</literal> (both used to be in - <literal>Control.Concurrent.STM</literal>). - It also re-exports - <literal>STM</literal>, - <literal>atomically</literal>, - <literal>retry</literal>, - <literal>orElse</literal> and - <literal>catchSTM</literal>. - </para> - </listitem> - <listitem> - <para> - A new module - <literal>Control.Concurrent.STM.TArray</literal> defines - <literal>TArray</literal>, a transactional array, and makes - it an instance of <literal>MArray</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Concurrent.STM.TChan</literal> now provides - a function <literal>newTChanIO</literal>, which allows - <literal>TChan</literal>s to be created in the IO monad. - Similarly, <literal>Control.Concurrent.STM.TMVar</literal> - provides <literal>newTMVarIO</literal> and - <literal>newEmptyTMVarIO</literal>, and - <literal>Control.Concurrent.STM.TVar</literal> exports - <literal>newTVarIO</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Control.Concurrent.STM.TVar</literal> exports - <literal>registerDelay</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>Control.Concurrent.STM</literal> module has been - updated to re-export all the new modules. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - A <literal>Show</literal> instance is now derived for - <literal>Info</literal>, <literal>Fixity</literal> and - <literal>FixityDirection</literal> in - <literal>Language.Haskell.TH.Syntax</literal>. - </para> - </listitem> - <listitem> - <para> - In <literal>Language.Haskell.TH.Syntax</literal>, there is - a type <literal>PkgName</literal> and functions - <literal>mkPkgName</literal> and - <literal>pkgString</literal> - for dealing with package names. - </para> - </listitem> - <listitem> - <para> - The <literal>patGE</literal> function in - <literal>Language.Haskell.TH.Lib</literal> now takes the - final expression separately to the list of statements - rather than splitting it off itself. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Win32</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 1.0). - </para> - </listitem> - <listitem> - <para> - Now maintained by Esa Ilari Vuokko. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.Console</literal> - providing an interface to the Windows Console API. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.DebugApi</literal> - providing an interface to the Windows DebugApi. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.FileMapping</literal> - for working with memory-mapped files. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.SimpleMAPI</literal> - for using the Windows mail API. - </para> - </listitem> - <listitem> - <para> - There is a new module - <literal>System.Win32.Time</literal> - for using the Windows time API. - </para> - </listitem> - <listitem> - <para> - <literal>iNVALID_HANDLE_VALUE</literal> has moved from - <literal>Graphics.Win32.Misc</literal> to - <literal>System.Win32.Types</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.File</literal> has a new - function <literal>getFileInformationByHandle</literal> - and associated data types. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.Info</literal> has a new - function <literal>getSystemInfo</literal> and associated - data types. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.Process</literal> now has many more - exports. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32.Types</literal> has new types - <literal>LARGE_INTEGER</literal>, <literal>DDWORD</literal> - and <literal>SIZE_T</literal>. It also has new helper - functions <literal>ddwordToDwords</literal> and - <literal>dwordsToDdword</literal> to split and combine - ddwords into high and low components. - </para> - </listitem> - <listitem> - <para> - <literal>System.Win32</literal> re-exports - <literal>System.Win32.FileMapping</literal>, - <literal>System.Win32.Time</literal> - and <literal>System.Win32.Console</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> - - <sect2> - <title>Extra Libraries</title> - <sect3> - <title>ALUT</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - <literal>Sound.ALUT.BuiltInSounds</literal> has been removed. - Its <literal>Phase</literal> and <literal>Duration</literal> - exports are now exported by - <literal>Sound.ALUT.Loaders</literal> and its - <literal>helloWorld</literal>, - <literal>sine</literal>, - <literal>square</literal>, - <literal>sawtooth</literal>, - <literal>impulse</literal> and - <literal>whiteNoise</literal> - exports are now constructors of the - <literal>Sound.ALUT.Loaders.SoundDataSource</literal> - datatype. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>arrows</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2 (was 0.1). - </para> - </listitem> - <listitem> - <para> - <literal>Control.Sequence</literal> has been removed in - favour of the new <literal>Control.Applicative</literal> - module in <literal>base</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>cgi</title> - <itemizedlist> - <listitem> - <para> - Version 2006.8.14. - </para> - </listitem> - <listitem> - <para> - <literal>cgi</literal> is a new package, developing on - what used to be <literal>Network.CGI</literal> in the - <literal>network</literal> package. - </para> - </listitem> - <listitem> - <para> - The <literal>Network.CGI.Compat</literal> module provides - a similar interface to the old <literal>Network.CGI</literal> - module, but it uses <literal>Text.XHtml</literal> rather than - <literal>Text.Html</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>fgl</title> - <itemizedlist> - <listitem> - <para> - Version number 5.3 (was 5.2). - </para> - </listitem> - <listitem> - <para> - <literal>Data.Graph.Inductive.Graph</literal> no longer - exports <literal>UContext</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Data.Graph.Inductive.Graph</literal> now exports - <literal>delLEdge</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>GLUT</title> - <itemizedlist> - <listitem> - <para> - Version number remains 2.0. - </para> - </listitem> - <listitem> - <para> - In <literal>Graphics.UI.GLUT.Initialization</literal>, - <literal>DisplayMode</literal> has a new constructor - <literal>WithAuxBuffers</literal> and - <literal>DisplayCapability</literal> has a new constructor - <literal>DisplayAux</literal>. These represent freeglut-only - features. - </para> - </listitem> - <listitem> - <para> - There are new examples in - <filename>BOGLGP/Chapter03/OnYourOwn1.hs</filename>, - <filename>RedBook/AAIndex.hs</filename>, - <filename>RedBook/AARGB.hs</filename>, - <filename>RedBook/AccAnti.hs</filename>, - <filename>RedBook/AccPersp.hs</filename>, - <filename>RedBook/Alpha3D.hs</filename>, - <filename>RedBook/DOF.hs</filename>, - <filename>RedBook/FogIndex.hs</filename>, - <filename>RedBook/Multisamp.hs</filename>, - <filename>RedBook/PointP.hs</filename>, - <filename>RedBook/PolyOff.hs</filename>, - <filename>RedBook/Stencil.hs</filename>, - <filename>RedBook/Stroke.hs</filename> and - <filename>RedBook/Torus.hs</filename>, - and the examples in - <filename>RedBook/Font.hs</filename> and - <filename>RedBook/Histogram.hs</filename> have been - improved. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell-src</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>HGL</title> - <itemizedlist> - <listitem> - <para> - No change (version 3.1). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>html</title> - <itemizedlist> - <listitem> - <para> - Version 1.0. - </para> - </listitem> - <listitem> - <para> - <literal>html</literal> is a new package, developing on - what used to be <literal>Text.Html</literal> and - <literal>Text.Html.BlockTable</literal> in the - <literal>base</literal> package. - </para> - </listitem> - <listitem> - <para> - <literal>Text.Html.BlockTable</literal> exports a new - function <literal>empty</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>HUnit</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.1). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>mtl</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>network</title> - <itemizedlist> - <listitem> - <para> - Version number 2.0 (was 1.0). - </para> - </listitem> - <listitem> - <para> - <literal>Network.CGI</literal> has been removed; use the - <literal>cgi</literal> package instead. - </para> - </listitem> - <listitem> - <para> - <literal>Network.BSD</literal> no longer exports - <literal>symlink</literal> or <literal>readlink</literal>; - use - <literal>System.Posix.Files.createSymbolicLink</literal> and - <literal>System.Posix.Files.readSymbolicLink</literal> - instead. - </para> - </listitem> - <listitem> - <para> - <literal>Network.BSD</literal> now exports - <literal>defaultProtocol</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Network.Socket.SocketStatus</literal> now has a - constructor <literal>ConvertedToHandle</literal> for sockets - that have been converted to handles. - </para> - </listitem> - <listitem> - <para> - <literal>Network.Socket.Family</literal> now has the - following additional constructors: - <literal>AF_NETROM</literal>, - <literal>AF_BRIDGE</literal>, - <literal>AF_ATMPVC</literal>, - <literal>AF_ROSE</literal>, - <literal>AF_NETBEUI</literal>, - <literal>AF_SECURITY</literal>, - <literal>AF_PACKET</literal>, - <literal>AF_ASH</literal>, - <literal>AF_ECONET</literal>, - <literal>AF_ATMSVC</literal>, - <literal>AF_IRDA</literal>, - <literal>AF_PPPOX</literal>, - <literal>AF_WANPIPE</literal> and - <literal>AF_BLUETOOTH</literal>. - </para> - </listitem> - <listitem> - <para> - In <literal>Network.URI</literal>, - <literal>parseabsoluteURI</literal> has been deprecated with - a new function <literal>parseAbsoluteURI</literal> taking - its place. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ObjectIO</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>OpenAL</title> - <itemizedlist> - <listitem> - <para> - Version number 1.3 (was 1.2). - </para> - </listitem> - <listitem> - <para> - No other change. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>OpenGL</title> - <itemizedlist> - <listitem> - <para> - Version number 2.1 (was 2.0). - </para> - </listitem> - <listitem> - <para> - No other change. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>QuickCheck</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0). - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>time</title> - <itemizedlist> - <listitem> - <para> - Version 1.0. - </para> - </listitem> - <listitem> - <para> - <literal>time</literal> is a new package, for dealing with - dates, times and time intervals. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>X11</title> - <itemizedlist> - <listitem> - <para> - Version number 1.2 (was 1.1). - </para> - </listitem> - <listitem> - <para> - In <literal>Graphics.X11.Xlib.Types</literal>, - <literal>XGCValues</literal> has been renamed - <literal>GCValues</literal> and - <literal>XSetWindowAttributes</literal> has been renamed - <literal>SetWindowAttributes</literal>. - </para> - </listitem> - <listitem> - <para> - In <literal>Graphics.X11.Xlib.Misc</literal>, - <literal>allocaXSetWindowAttributes</literal> has been - renamed <literal>allocaSetWindowAttributes</literal>. - </para> - </listitem> - <listitem> - <para> - The <literal>FontStruct</literal> type has moved from - <literal>Graphics.X11.Xlib.Types</literal> to - <literal>Graphics.X11.Xlib.Font</literal>. - </para> - </listitem> - <listitem> - <para> - The - <literal>Point</literal>, - <literal>Rectangle</literal>, - <literal>Arc</literal>, - <literal>Segment</literal> and - <literal>Color</literal> types in - <literal>Graphics.X11.Xlib.Types</literal> - are now proper datatypes rather than synonyms for tuples. - They all have a <literal>Storable</literal> instance. - </para> - </listitem> - <listitem> - <para> - The <literal>Byte</literal> and <literal>Short</literal> - types from <literal>Graphics.X11.Xlib.Types</literal> have - been removed. - The following type synonyms, which had already been marked - "Backwards compatibility", have also been removed: - <literal>ListPoint</literal>, - <literal>ListRectangle</literal>, - <literal>ListArc</literal>, - <literal>ListSegment</literal> and - <literal>ListColor</literal>. - </para> - </listitem> - <listitem> - <para> - <literal>Eq</literal>, - <literal>Ord</literal>, - <literal>Show</literal>, - <literal>Typeable</literal> and - <literal>Data</literal> are now derived for: - <literal>XEvent</literal>, - <literal>FdSet</literal> and - <literal>TimeZone</literal> in - <literal>Graphics.X11.Xlib.Event</literal>, - <literal>FontStruct</literal> in - <literal>Graphics.X11.Xlib.Font</literal>, - <literal>XErrorEvent</literal>, - <literal>XComposeStatus</literal> and - <literal>XTextProperty</literal> in - <literal>Graphics.X11.Xlib.Misc</literal>, - <literal>Region</literal> in - <literal>Graphics.X11.Xlib.Region</literal>, - <literal>Display</literal>, - <literal>Screen</literal>, - <literal>Visual</literal>, - <literal>GC</literal>, - <literal>GCValues</literal>, - <literal>SetWindowAttributes</literal>, - <literal>Point</literal>, - <literal>Rectangle</literal>, - <literal>Arc</literal>, - <literal>Segment</literal> and - <literal>Color</literal> in - <literal>Graphics.X11.Xlib.Types</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>xhtml</title> - <itemizedlist> - <listitem> - <para> - Version 2006.8.14. - </para> - </listitem> - <listitem> - <para> - <literal>xhtml</literal> is a new package, developing on - what used to be <literal>Text.Html</literal> and - <literal>Text.Html.BlockTable</literal> in the - <literal>base</literal> package. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> - - <sect2> - <title>GHC As A Library</title> - <para> - Version number 6.6. - </para> - <para> - The internal modules of GHC are now available as a library, package - name <literal>ghc</literal>. - The interface has not been designed with use by other programs - in mind, so expect the API to vary radically in future - releases. - </para> - <para> - An introduction to using the library can be found - <ulink url="http://www.haskell.org/haskellwiki/GHC/As_a_library">on the wiki</ulink>. - </para> - </sect2> - - <sect2> - <title>Internal changes</title> - <itemizedlist> - <listitem> - <para> - GHC development now has its own integrated - <ulink url="http://hackage.haskell.org/trac/ghc">wiki and bug - tracker</ulink>. - </para> - </listitem> - <listitem> - <para> - GHC has now moved to darcs. See - <ulink - url="http://hackage.haskell.org/trac/ghc/wiki/GhcDarcs">the - wiki</ulink> for more details. The sources have moved around a - bit within the tree as a result, most notably the GHC sources - are no longer kept within a <filename>ghc/</filename> - subdirectory. - </para> - </listitem> - <listitem> - <para> - The native code generator is now capable of compiling loops, - which gets us a big step closer to being able to compile - entirely without gcc on well-supported arches. - </para> - </listitem> - </itemizedlist> - </sect2> -</sect1> - diff --git a/docs/users_guide/7.0.1-notes.xml b/docs/users_guide/7.0.1-notes.xml deleted file mode 100644 index 4d3e2994e6..0000000000 --- a/docs/users_guide/7.0.1-notes.xml +++ /dev/null @@ -1,1226 +0,0 @@ -<?xml version="1.0" encoding="iso-8859-1"?> -<sect1 id="release-7-0-1"> - <title>Release notes for version 7.0.1</title> - - <para> - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 6.12 branch. - </para> - - <sect2> - <title>Highlights</title> - <itemizedlist> - <listitem> - <para> - GHC now defaults to the Haskell 2010 language standard. - </para> - - <para> - Libraries are not quite so straightforward. By default, GHC - provides access to the <literal>base</literal> package, - which includes the Haskell 2010 libraries, albeit with a few - minor differences. For those who want to write strictly - standards-conforming code we also provide - the <literal>haskell2010</literal> package which provides - the precise APIs specified by Haskell 2010, but because the - module names in this package overlap with those in - the <literal>base</literal> package it is not possible to - use both <literal>haskell2010</literal> - and <literal>base</literal> at the same time (this also - applies to the <literal>array</literal> package). Hence to use - the Haskell 2010 libraries you should hide - the <literal>base</literal> and <literal>array</literal> - packages, for example with GHCi: -<screen> -$ ghci -package haskell2010 -hide-package base -hide-package array -</screen> - If you are using Cabal it isn't necessary to - hide <literal>base</literal> and <literal>array</literal> - explicitly, just don't include them in your <literal>build-depends</literal>. - </para> - </listitem> - - <listitem> - <para> - On POSIX platforms, there is a new I/O manager based on - epoll/kqueue/poll, which allows multithreaded I/O code to - scale to a much larger number (100k+) of threads. - </para> - </listitem> - - <listitem> - <para> - GHC now includes an LLVM code generator. For certain code, - particularly arithmetic heavy code, using the LLVM code - generator can bring some nice performance improvements. - </para> - </listitem> - - <listitem> - <para> - The type checker has been overhauled, which means it is now - able to correctly handle interactions between the type system - extensions. - </para> - </listitem> - - <listitem> - <para> - The inliner has been overhauled, which should in general - give better performance while reducing unnecessary code-size - explosion. - </para> - </listitem> - - <listitem> - <para> - Large parts of the runtime system have been overhauled, in - particular the machinery related to blocking and wakeup of - threads and exception throwing (<literal>throwTo</literal>). - Several instances of pathological performance have been - fixed, especially where large numbers of threads are - involved. - </para> - </listitem> - - <listitem> - <para> - Due to changes in the runtime system, if you are - using <literal>Control.Parallel.Strategies</literal> from - the <literal>parallel</literal> package, please upgrade to - at least version 2 (preferably version 3). The - implementation of Strategies - in <literal>parallel-1.x</literal> will lose parallelism - with GHC 7.0.1. - </para> - </listitem> - - <listitem> - <para> - The full Haskell <literal>import</literal> syntax can now been - used to bring modules into scope in GHCi, e.g. - </para> -<programlisting> -Prelude> import Data.List as L -Prelude Data.List> L.length "foo" -3 -</programlisting> - </listitem> - - <listitem> - <para> - GHC now comes with a more recent mingw bundled on Windows, - which includes a fix for windres on Windows 7. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Language changes</title> - <itemizedlist> - <listitem> - <para> - GHC now understands the <literal>Haskell98</literal> and - <literal>Haskell2010</literal> languages. - </para> - - <para> - These get processed before the language extension pragmas, - and define the default sets of extensions that are enabled. - If neither is specified, then the default is - <literal>Haskell2010</literal> plus the - <literal>MonoPatBinds</literal> extension. - </para> - </listitem> - - <listitem> - <para> - GHC now supports the <literal>DoAndIfThenElse</literal> - extension, which is part of the Haskell 2010 standard. - </para> - </listitem> - - <listitem> - <para> - Datatype contexts, such as the <literal>Eq a</literal> in - </para> -<programlisting> -data Eq a => Set a = NilSet | ConsSet a (Set a) -</programlisting> - <para> - are now treated as an extension - <literal>DatatypeContexts</literal> (on by default) by GHC. - </para> - </listitem> - - <listitem> - <para> - GHC's support for unicode source has been improved, including - removing support for U+22EF for the <literal>..</literal> - symbol. See <xref linkend="unicode-syntax" /> for more details. - </para> - </listitem> - - <listitem> - <para> - Pragmas are now reread after preprocessing. In particular, - this means that if a pragma is used to turn CPP on, then other - pragmas can be put in CPP conditionals. - </para> - </listitem> - - <listitem> - <para> - The <literal>TypeOperators</literal> extension now allows - instance heads to use infix syntax. - </para> - </listitem> - - <listitem> - <para> - The <literal>PackageImports</literal> extension now understands - <literal>this</literal> to mean the current package. - </para> - </listitem> - - <listitem> - <para> - The <literal>INLINE</literal> and <literal>NOINLINE</literal> - pragmas can now take a <literal>CONLIKE</literal> modifier, - which indicates that the right hand side is cheap to compute, - and can thus be duplicated more freely. - See <xref linkend="conlike" /> for more details. - </para> - </listitem> - - <listitem> - <para> - A <literal>ForceSpecConstr</literal> annotation on a type, e.g. - </para> -<programlisting> -import SpecConstr -{-# ANN type SPEC ForceSpecConstr #-} -</programlisting> - <para> - can be used to force GHC to fully specialise argument of that - type. - </para> - </listitem> - - <listitem> - <para> - A <literal>NoSpecConstr</literal> annotation on a type, e.g. - </para> -<programlisting> -import SpecConstr -{-# ANN type T NoSpecConstr #-} -</programlisting> - <para> - can be used to prevent SpecConstr from specialising on - arguments of that type. - </para> - </listitem> - - <listitem> - <para> - There is are two experimental new extensions - <literal>AlternativeLayoutRule</literal> and - <literal>AlternativeLayoutRuleTransitional</literal>, - which are for exploring alternative layout rules in Haskell'. - The details are subject to change, so we advise against using - them in real code for now. - </para> - </listitem> - - <listitem> - <para> - The <literal>NewQualifiedOperators</literal> extension has - been deprecated, as it was rejected by the Haskell' committee. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Warnings</title> - <itemizedlist> - <listitem> - <para> - There is now a warning for missing import lists, controlled - by the new <literal>-fwarn-missing-import-lists</literal> flag. - </para> - </listitem> - - <listitem> - <para> - GHC will now warn about <literal>SPECIALISE</literal> and - <literal>UNPACK</literal> pragmas that have no effect. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>DLLs</title> - <itemizedlist> - <listitem> - <para> - Shared libraries are once again supported on Windows. - </para> - </listitem> - - <listitem> - <para> - Shared libraries are now supported on OS X, both on x86 and on - PowerPC. The new <literal>-dylib-install-name</literal> GHC - flag is used to set the location of the dynamic library. - See <xref linkend="finding-shared-libs" /> for more details. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Runtime system</title> - - <itemizedlist> - <listitem> - <para> - For security reasons, by default, the only RTS flag that - programs accept is <literal>+RTS --info</literal>. If you want - the full range of RTS flags then you need to link with the new - <literal>-rtsopts</literal> flag. See - <xref linkend="options-linker" /> for more details. - </para> - </listitem> - - <listitem> - <para> - The RTS now exports a function <literal>setKeepCAFs</literal> - which is important when loading Haskell DLLs dynamically, as - a DLL may refer to CAFs that have already been GCed. - </para> - </listitem> - - <listitem> - <para> - The garbage collector no longer allows you to specify a number - of steps; there are now always 2. The <literal>-T</literal> - RTS flag has thus been removed. - </para> - </listitem> - - <listitem> - <para> - A new RTS flag <literal>-H</literal> causes the RTS to use a - larger nursery, but without exceeding the amount of memory - that the application is already using. It makes some programs - go slower, but others go faster. - </para> - </listitem> - - <listitem> - <para> - GHC now returns memory to the OS, if memory usage peaks and - then drops again. This is mainly useful for long running - processes which normally use very little memory, but - occasionally need a lot of memory for a short period of time. - </para> - </listitem> - - <listitem> - <para> - On OS X, eventLog events are now available as DTrace probes. - </para> - </listitem> - - <listitem> - <para> - The PAPI support has been improved. The new RTS flag - <literal>-a#0x40000000</literal> can be used to tell the RTS - to collect the native PAPI event <literal>0x40000000</literal>. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Compiler</title> - <itemizedlist> - <listitem> - <para> - GHC now defaults to <literal>--make</literal> mode, i.e. GHC - will chase dependencies for you automatically by default. - </para> - </listitem> - - <listitem> - <para> - GHC now includes an LLVM code generator. - </para> - <para> - This includes a number of new flags: - a flag to tell GHC to use LLVM, <literal>-fllvm</literal>; - a flag to dump the LLVM input ,<literal>-ddump-llvm</literal>; - flags to keep the LLVM intermediate files, - <literal>-keep-llvm-file</literal> and - <literal>-keep-llvm-files</literal>; - flags to set the location and options for the LLVM optimiser - and compiler, - <literal>-pgmlo</literal>, - <literal>-pgmlc</literal>, - <literal>-optlo</literal> and - <literal>-optlc</literal>. - The LLVM code generator requires LLVM version 2.7 or later on - your path. - </para> - </listitem> - - <listitem> - <para> - It is now possible to use <literal>-fno-code</literal> with - <literal>--make</literal>. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-dsuppress-coercions</literal> controls - whether GHC prints coercions in core dumps. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-dsuppress-module-prefixes</literal> - controls whether GHC prints module qualification prefixes - in core dumps. - </para> - </listitem> - - <listitem> - <para> - The inliner has been overhauled. The most significant - user-visible change is that only saturated functions are - inlined, e.g. - </para> -<programlisting> -(.) f g x = f (g x) -</programlisting> - <para> - would only be inlined if <literal>(.)</literal> is applied to 3 - arguments, while - </para> -<programlisting> -(.) f g = \x -> f (g x) -</programlisting> - <para> - will be inlined if only applied to 2 arguments. - </para> - </listitem> - - <listitem> - <para> - The <literal>-finline-if-enough-args</literal> flag is no - longer supported. - </para> - </listitem> - - <listitem> - <para> - Column numbers in warnings and error messages now start at 1, - as is more standard, rather than 0. - </para> - </listitem> - - <listitem> - <para> - GHCi now understands most linker scripts. In particular, this - means that GHCi is able to load the C pthread library. - </para> - </listitem> - - <listitem> - <para> - The <literal>ghc --info</literal> output has been updated: - </para> - <para> - It now includes the - location of the global package database, in the - <literal>Global Package DB</literal> field. - </para> - <para> - It now includes the build, host and target platforms, in the - <literal>Build platform</literal>, - <literal>Host platform</literal> and - <literal>Target platform</literal> fields. - </para> - <para> - It now includes a <literal>Have llvm code generator</literal> - field. - </para> - <para> - The <literal>Win32 DLLs</literal> field has been removed. - </para> - </listitem> - - <listitem> - <para> - The registerised via-C backend, and the - <literal>-fvia-C</literal> flag, have been deprecated. The poor - floating-point performance in the x86 native code generator - has now been fixed, so we don't believe there is still any - reason to use the via-C backend. - </para> - </listitem> - - <listitem> - <para> - There is now a new flag <literal>--supported-extensions</literal>, - which currently behaves the same as - <literal>--supported-languages</literal>. - </para> - </listitem> - - <listitem> - <para> - GHC progress output such as - </para> -<programlisting> -[ 1 of 5] Compiling Foo ( Foo.hs, Foo.o ) -</programlisting> - <para> - is now sent to stdout rather than stderr. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-fexpose-all-unfoldings</literal> - makes GHC put unfoldings for <emphasis>everything</emphasis> - in the interface file. - </para> - </listitem> - - <listitem> - <para> - There are two new flags, <literal>-fno-specialise</literal> - and <literal>-fno-float-in</literal>, for disabling the - specialise and float-in passes. - </para> - </listitem> - - <listitem> - <para> - The new flag <literal>-fstrictness-before=<replaceable>n</replaceable></literal> tells - GHC to run an additional strictness analysis pass - before simplifier phase <replaceable>n</replaceable>. - </para> - </listitem> - - <listitem> - <para> - There is a new flag - <literal>-funfolding-dict-discount</literal> - for tweaking the optimiser's behaviour. - </para> - </listitem> - - <listitem> - <para> - The <literal>-fspec-inline-join-points</literal> flag has been - removed. - </para> - </listitem> - - <listitem> - <para> - The <literal>-dynload wrapper</literal> flag has been - removed. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHCi</title> - <itemizedlist> - <listitem> - <para> - GHCi now understands layout in multi-line commands, so - this now works: - </para> -<programlisting> -Prelude> :{ -Prelude| let x = 1 -Prelude| y = 2 in x + y -Prelude| :} -3 -</programlisting> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Template Haskell and Quasi-Quoters</title> - <itemizedlist> - <listitem> - <para> - It is now possible to quasi-quote patterns with - <literal>[p| ... |]</literal>. - </para> - </listitem> - - <listitem> - <para> - It is no longer to use a <literal>$</literal> before the - name of a quasi-quoter, e.g. one can now say - <literal>[expr| ... |]</literal> rather than - <literal>[$expr| ... |]</literal>. - </para> - </listitem> - - <listitem> - <para> - It is now possible to use a quasi-quoter for types, e.g. - <literal>f :: [$qq| ... |]</literal> - </para> - </listitem> - - <listitem> - <para> - It is now possible to quasi-quote existentials and GADTs. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>GHC API</title> - <itemizedlist> - <listitem> - <para> - There are now <literal>Data</literal> and - <literal>Typeable</literal> instances for the - HsSyn typed. - </para> - </listitem> - - <listitem> - <para> - As language extensions are not applied until after the base - language (Haskell98, Haskell2010 or the default) has been - selected, it is now necessary to tell the GHC API the point - at which the extension flags should be processed. Normally - this is done by calling - <literal>DynFlags.flattenExtensionFlags</literal> once all - the flags and pragmas have been read. - </para> - </listitem> - </itemizedlist> - </sect2> - - <sect2> - <title>Libraries</title> - - <sect3> - <title>array</title> - <itemizedlist> - <listitem> - <para> - Version number 0.3.0.2 (was 0.3.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base</title> - <itemizedlist> - <listitem> - <para> - Version number 4.3.0.0 (was 4.2.0.2) - </para> - </listitem> - - <listitem> - <para> - There is a new asynchronous exception control API - in <literal>Control.Exception</literal>, using the - new functions - <literal>mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b</literal> - and <literal>mask_ :: IO a -> IO a</literal> - rather than the old - <literal>block</literal> and <literal>unblock</literal>. - There are also functions - <literal>uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b</literal> - and - <literal>getMaskingState :: IO MaskingState</literal>, - and a type - <literal>MaskingState</literal>, as well as - <literal>forkIOUnmasked :: IO () -> IO ThreadId</literal> - in <literal>Control.Concurrent</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Control.Monad</literal> exports a new function - <literal>void :: Functor f => f a -> f ()</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Tuple</literal> exports a new function - <literal>swap :: (a,b) -> (b,a)</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>System.IO</literal> exports a new function - <literal>hGetBufSome :: Handle -> Ptr a -> Int -> IO Int</literal> - which is like <literal>hGetBuf</literal> but can - return short reads. - </para> - </listitem> - - <listitem> - <para> - There is a new function - <literal>mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a</literal> - in - <literal>Control.Monad</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Foreign.Marshal</literal> module now - exports - <literal>unsafeLocalState :: IO a -> a</literal> - as specified by Haskell 2010. - </para> - </listitem> - - <listitem> - <para> - The <literal></literal> - module now exports four new functions specified by - Haskell 2010: - <literal>castCUCharToChar :: CUChar -> Char</literal>, - <literal>castCharToCUChar :: Char -> CUChar</literal>, - <literal>castCSCharToChar :: CSChar -> Char</literal> and - <literal>castCharToCSChar :: Char -> CSChar</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>Foreign.Marshal.Alloc</literal> - module now exports - <literal>allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b</literal> - for allocating memory with a particular alignment. - </para> - </listitem> - - <listitem> - <para> - There is a new function - <literal>numSparks :: IO Int</literal> - in <literal>GHC.Conc</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Data.Either.partitionEithers</literal> - in now lazier. - </para> - </listitem> - - <listitem> - <para> - There is now a <literal>Typeable</literal> instance for - <literal>Data.Unique.Unique</literal>. - </para> - </listitem> - - <listitem> - <para> - <literal>Control.Concurrent.SampleVar.SampleVar</literal> - is now an abstract type. - </para> - </listitem> - - <listitem> - <para> - There are now - <literal>Applicative</literal>, - <literal>Alternative</literal> and - <literal>MonadPlus</literal> - instances for <literal>STM</literal>. - </para> - </listitem> - - <listitem> - <para> - There are now <literal>Applicative</literal>, - <literal>Monad</literal> and - <literal>MonadFix</literal> - instances for <literal>Either</literal>. - </para> - </listitem> - - <listitem> - <para> - There are now - <literal>Ord</literal>, - <literal>Read</literal> and - <literal>Show</literal> instances for - <literal>Newline</literal> and - <literal>NewlineMode</literal>. - </para> - </listitem> - - <listitem> - <para> - There is now a <literal>Show</literal> instance for - <literal>TextEncoding</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>unGetChan</literal> and - <literal>isEmptyChan</literal> functions in - <literal>Control.Concurrent.Chan</literal> are now - deprecated. - <literal>Control.Concurrent.STM.TChan</literal> - should be used instead if you need that - functionality. - </para> - </listitem> - - <listitem> - <para> - The <literal>Read Integer</literal> instance now - matches the standard definition. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>base 3 compat</title> - <itemizedlist> - <listitem> - <para> - We no longer ship a base 3 compat package - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bin-package-db</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>bytestring</title> - <itemizedlist> - <listitem> - <para> - Version number 0.9.1.8 (was 0.9.1.7) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>Cabal</title> - <itemizedlist> - <listitem> - <para> - Version number 1.10.0.0 (was 1.8.0.6) - </para> - </listitem> - - <listitem> - <para> - Many API changes. See the Cabal docs for more information. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>containers</title> - <itemizedlist> - <listitem> - <para> - Version number 0.4.0.0 (was 0.3.0.0) - </para> - </listitem> - - <listitem> - <para> - Strictness is now more consistent, with containers - being strict in their elements even in singleton - cases. - </para> - </listitem> - - <listitem> - <para> - There is a new function - <literal>insertLookupWithKey'</literal> in - <literal>Data.Map</literal>. - </para> - </listitem> - - <listitem> - <para> - The <literal>foldWithKey</literal> function in - <literal>Data.Map</literal> has been deprecated in - favour of <literal>foldrWithKey</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>directory</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.0 (was 1.0.1.1) - </para> - </listitem> - - <listitem> - <para> - The <literal>System.Directory</literal> module - now exports the <literal>Permissions</literal> type - abstractly. There are also new functions - <literal>setOwnerReadable</literal>, - <literal>setOwnerWritable</literal>, - <literal>setOwnerExecutable</literal> and - <literal>setOwnerSearchable</literal>, and - a new value <literal>emptyPermissions</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title> - dph - (dph-base, dph-par, dph-prim-interface, dph-prim-par, - dph-prim-seq, dph-seq) - </title> - <itemizedlist> - <listitem> - <para> - All the dph packages are version 0.4.0. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>extensible-exceptions</title> - <itemizedlist> - <listitem> - <para> - Version number 0.1.1.2 (was 0.1.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>filepath</title> - <itemizedlist> - <listitem> - <para> - Version number 1.2.0.0 (was 1.1.0.4) - </para> - </listitem> - - <listitem> - <para> - The current directory is now <literal>"."</literal> - rather than <literal>""</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-binary</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>ghc-prim</title> - <itemizedlist> - <listitem> - <para> - This is an internal package, and should not be used. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell98</title> - <itemizedlist> - <listitem> - <para> - Version number 1.1.0.0 (was 1.0.1.1) - </para> - </listitem> - - <listitem> - <para> - In the <literal>Directory</literal> module, the - <literal>Permissions</literal> type and the - <literal>getPermissions</literal> and - <literal>setPermissions</literal> functions are now - different to their equivalents in - <literal>base:System.Directory</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>haskell2010</title> - <itemizedlist> - <listitem> - <para> - This is a new boot package, version 1.0.0.0. - It is not exposed by default. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>hpc</title> - <itemizedlist> - <listitem> - <para> - Version number 0.5.0.6 (was 0.5.0.5) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>integer-gmp</title> - <itemizedlist> - <listitem> - <para> - Version number 0.2.0.2 (was 0.2.0.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-locale</title> - <itemizedlist> - <listitem> - <para> - No change (version 1.0.0.2) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>old-time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.6 (was 1.0.0.5) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>pretty</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.2 (was 1.0.1.1) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>process</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.1.4 (was 1.0.1.3) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>random</title> - <itemizedlist> - <listitem> - <para> - Version number 1.0.0.3 (was 1.0.0.2) - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>syb</title> - <itemizedlist> - <listitem> - <para> - The syb package is no longer included with GHC. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>template-haskell</title> - <itemizedlist> - <listitem> - <para> - Version number 2.5.0.0 (was 2.4.0.1) - </para> - </listitem> - - <listitem> - <para> - There is a new type synonym <literal>DecsQ</literal> - in <literal>Language.Haskell.TH.Lib</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new <literal>StringPrimL</literal> - constructor in - <literal>Language.Haskell.TH.Syntax.Lit</literal>, - and a new helper function - <literal>stringPrimL</literal> for it in - <literal>Language.Haskell.TH.Lib</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new function <literal>quoteFile</literal> - in <literal>Language.Haskell.TH.Quote</literal>. - </para> - </listitem> - - <listitem> - <para> - The - <literal>Language.Haskell.TH.Quote.QuasiQuoter</literal> - type has two new fields: - <literal>quoteType</literal> and - <literal>quoteDec</literal>. - </para> - </listitem> - - <listitem> - <para> - There is a new <literal>ClassInstance</literal> - type in <literal>Language.Haskell.TH.Syntax</literal>. - The - <literal>Language.Haskell.TH.Syntax.Info.ClassI</literal> - constructor now includes a value of this type, which - allows instance information to be queried via the - new <literal>isClassInstance</literal> - and <literal>classInstances</literal> functions. - There is also a new method - <literal>qClassInstances</literal> in the - <literal>Quasi</literal> class. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>time</title> - <itemizedlist> - <listitem> - <para> - Version number 1.2.0.3 (was 1.1.4) - </para> - </listitem> - - <listitem> - <para> - The types provided by the time package now include - <literal>Data</literal> instances. - </para> - </listitem> - </itemizedlist> - </sect3> - - <sect3> - <title>unix</title> - <itemizedlist> - <listitem> - <para> - Version number 2.4.1.0 (was 2.4.0.2) - </para> - </listitem> - - <listitem> - <para> - There are three new helper function in - <literal>System.Posix.Error</literal>: - <literal>throwErrnoPathIfRetry</literal>, - <literal>throwErrnoPathIfNullRetry</literal> and - <literal>throwErrnoPathIfMinus1Retry</literal>. - </para> - </listitem> - - <listitem> - <para> - There are three new functions in - <literal>System.Posix.User</literal>: - <literal>setEffectiveUserID</literal>, - <literal>setEffectiveGroupID</literal> and - <literal>setGroups</literal>. - </para> - </listitem> - </itemizedlist> - </sect3> - </sect2> -</sect1> - diff --git a/docs/users_guide/extending_ghc.xml b/docs/users_guide/extending_ghc.xml new file mode 100644 index 0000000000..11cd75d898 --- /dev/null +++ b/docs/users_guide/extending_ghc.xml @@ -0,0 +1,284 @@ +<?xml version="1.0" encoding="iso-8859-1"?> +<chapter id="extending-ghc"> + <title>Extending and using GHC as a Library</title> + + <para>GHC exposes its internal APIs to users through the built-in ghc package. It allows you to write programs that leverage GHC's entire compilation driver, in order to analyze or compile Haskell code programmatically. Furthermore, GHC gives users the ability to load compiler plugins during compilation - modules which are allowed to view and change GHC's internal intermediate representation, Core. Plugins are suitable for things like experimental optimizations or analysis, and offer a lower barrier of entry to compiler development for many common cases.</para> + + <para>Furthermore, GHC offers a lightweight annotation mechanism that you can use to annotate your source code with metadata, which you can later inspect with either the compiler API or a compiler plugin.</para> + + <sect1 id="annotation-pragmas"> + <title>Source annotations</title> + + <para>Annotations are small pragmas that allow you to attach data to identifiers in source code, which are persisted when compiled. These pieces of data can then inspected and utilized when using GHC as a library or writing a compiler plugin.</para> + + <sect2 id="ann-pragma"> + <title>Annotating values</title> + + <indexterm><primary>ANN</primary></indexterm> + + <para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value + binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal> + to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>). + By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal> + you would do this:</para> + +<programlisting> +{-# ANN foo (Just "Hello") #-} +foo = ... +</programlisting> + + <para> + A number of restrictions apply to use of annotations: + <itemizedlist> + <listitem><para>The binder being annotated must be at the top level (i.e. no nested binders)</para></listitem> + <listitem><para>The binder being annotated must be declared in the current module</para></listitem> + <listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem> + <listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the + expression being annotated with, so for example you cannot run a function from the module being compiled.</para> + + <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be + (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem> + </itemizedlist> + + If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC"> + please give the GHC team a shout</ulink>. + </para> + + <para>However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! + Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para> + +<programlisting> +{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} +f = ... +</programlisting> + </sect2> + + <sect2 id="typeann-pragma"> + <title>Annotating types</title> + + <indexterm><primary>ANN type</primary></indexterm> + <indexterm><primary>ANN</primary></indexterm> + + <para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para> + +<programlisting> +{-# ANN type Foo (Just "A `Maybe String' annotation") #-} +data Foo = ... +</programlisting> + </sect2> + + <sect2 id="modann-pragma"> + <title>Annotating modules</title> + + <indexterm><primary>ANN module</primary></indexterm> + <indexterm><primary>ANN</primary></indexterm> + + <para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para> + +<programlisting> +{-# ANN module (Just "A `Maybe String' annotation") #-} +</programlisting> + </sect2> + + </sect1> + + <sect1 id="ghc-as-a-library"> + <title>Using GHC as a Library</title> + + <para>The <literal>ghc</literal> package exposes most of GHC's frontend to users, and thus allows you to write programs that leverage it. This library is actually the same library used by GHC's internal, frontend compilation driver, and thus allows you to write tools that programmatically compile source code and inspect it. Such functionality is useful in order to write things like IDE or refactoring tools. As a simple example, here's a program which compiles a module, much like ghc itself does by default when invoked:</para> + +<programlisting> +import GHC +import GHC.Paths ( libdir ) +import DynFlags ( defaultDynFlags ) + +main = + defaultErrorHandler defaultDynFlags $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + target <- guessTarget "test_main.hs" Nothing + setTargets [target] + load LoadAllTargets +</programlisting> + + <para>The argument to <literal>runGhc</literal> is a bit tricky. GHC needs this to find its libraries, so the argument must refer to the directory that is printed by <literal>ghc --print-libdir</literal> for the same version of GHC that the program is being compiled with. Above we therefore use the <literal>ghc-paths</literal> package which provides this for us. </para> + + <para>Compiling it results in:</para> + +<programlisting> +$ cat test_main.hs +main = putStrLn "hi" +$ ghc -package ghc simple_ghc_api.hs +[1 of 1] Compiling Main ( simple_ghc_api.hs, simple_ghc_api.o ) +Linking simple_ghc_api ... +$ ./simple_ghc_api +$ ./test_main +hi +$ +</programlisting> + + <para>For more information on using the API, as well as more samples and references, please see <ulink url="http://haskell.org/haskellwiki/GHC/As_a_library">this Haskell.org wiki page</ulink>.</para> + </sect1> + + <sect1 id="compiler-plugins"> + <title>Compiler Plugins</title> + + <para>GHC has the ability to load compiler plugins at compile time. The feature is similar to the one provided by <ulink url="http://gcc.gnu.org/wiki/plugins">GCC</ulink>, and allows users to write plugins that can inspect and modify the compilation pipeline, as well as transform and inspect GHC's intermediate language, Core. Plugins are suitable for experimental analysis or optimization, and require no changes to GHC's source code to use.</para> + + <para>Plugins cannot optimize/inspect C--, nor can they implement things like parser/front-end modifications like GCC. If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC"> please give the GHC team a shout</ulink>.</para> + + <sect2 id="using-compiler-plugins"> + <title>Using compiler plugins</title> + + <para>Plugins can be specified on the command line with the option <literal>-fplugin=<replaceable>module</replaceable></literal> where <replaceable>module</replaceable> is a module in a registered package that exports a plugin. Arguments can be given to plugins with the command line option <literal>-fplugin-opt=<replaceable>module</replaceable>:<replaceable>args</replaceable></literal>, where <replaceable>args</replaceable> are arguments interpreted by the plugin provided by <replaceable>module</replaceable>.</para> + + <para>As an example, in order to load the plugin exported by <literal>Foo.Plugin</literal> in the package <literal>foo-ghc-plugin</literal>, and give it the parameter "baz", we would invoke GHC like this:</para> + +<programlisting> +$ ghc -fplugin Foo.Plugin -fplugin-opt Foo.Plugin:baz Test.hs +[1 of 1] Compiling Main ( Test.hs, Test.o ) +Loading package ghc-prim ... linking ... done. +Loading package integer-gmp ... linking ... done. +Loading package base ... linking ... done. +Loading package ffi-1.0 ... linking ... done. +Loading package foo-ghc-plugin-0.1 ... linking ... done. +... +Linking Test ... +$ +</programlisting> + + <para>Since plugins are exported by registered packages, it's safe to put dependencies on them in cabal for example, and specify plugin arguments to GHC through the <literal>ghc-options</literal> field.</para> + </sect2> + + <sect2 id="writing-compiler-plugins"> + <title>Writing compiler plugins</title> + + <para>Plugins are modules that export at least a single identifier, <literal>plugin</literal>, of type <literal>GhcPlugins.Plugin</literal>. All plugins should <literal>import GhcPlugins</literal> as it defines the interface to the compilation pipeline.</para> + + <para>A <literal>Plugin</literal> effectively holds a function which installs a compilation pass into the compiler pipeline. By default there is the empty plugin which does nothing, <literal>GhcPlugins.defaultPlugin</literal>, which you should override with record syntax to specify your installation function. Since the exact fields of the <literal>Plugin</literal> type are open to change, this is the best way to ensure your plugins will continue to work in the future with minimal interface impact.</para> + + <para><literal>Plugin</literal> exports a field, <literal>installCoreToDos</literal> which is a function of type <literal>[CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]</literal>. A <literal>CommandLineOption</literal> is effectively just <literal>String</literal>, and a <literal>CoreToDo</literal> is basically a function of type <literal>Core -> Core</literal>. A <literal>CoreToDo</literal> gives your pass a name and runs it over every compiled module when you invoke GHC.</para> + + <para>As a quick example, here is a simple plugin that just does nothing and just returns the original compilation pipeline, unmodified, and says 'Hello':</para> + +<programlisting> +module DoNothing.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + putMsgS "Hello!" + return todo +</programlisting> + + <para>Provided you compiled this plugin and registered it in a package (with cabal for instance,) you can then use it by just specifying <literal>-fplugin=DoNothing.Plugin</literal> on the command line, and during the compilation you should see GHC say 'Hello'.</para> + + <sect3 id="coretodo-in-more-detail"> + <title><literal>CoreToDo</literal> in more detail</title> + + <para><literal>CoreToDo</literal> is effectively a data type that describes all the kinds of optimization passes GHC does on Core. There are passes for simplification, CSE, vectorisation, etc. There is a specific case for plugins, <literal>CoreDoPluginPass :: String -> PluginPass -> CoreToDo</literal> which should be what you always use when inserting your own pass into the pipeline. The first parameter is the name of the plugin, and the second is the pass you wish to insert.</para> + + <para><literal>CoreM</literal> is a monad that all of the Core optimizations live and operate inside of.</para> + + <para>A plugin's installation function (<literal>install</literal> in the above example) takes a list of <literal>CoreToDo</literal>s and returns a list of <literal>CoreToDo</literal>. Before GHC begins compiling modules, it enumerates all the needed plugins you tell it to load, and runs all of their installation functions, initially on a list of passes that GHC specifies itself. After doing this for every plugin, the final list of passes is given to the optimizer, and are run by simply going over the list in order.</para> + + <para>You should be careful with your installation function, because the list of passes you give back isn't questioned or double checked by GHC at the time of this writing. An installation function like the following:</para> + +<programlisting> +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ _ = return [] +</programlisting> + + <para>is certainly valid, but also certainly not what anyone really wants.</para> + </sect3> + + <sect3 id="manipulating-bindings"> + <title>Manipulating bindings</title> + + <para>In the last section we saw that besides a name, a <literal>CoreDoPluginPass</literal> takes a pass of type <literal>PluginPass</literal>. A <literal>PluginPass</literal> is a synonym for <literal>(ModGuts -> CoreM ModGuts)</literal>. <literal>ModGuts</literal> is a type that represents the one module being compiled by GHC at any given time.</para> + + <para>A <literal>ModGuts</literal> holds all of the module's top level bindings which we can examine. These bindings are of type <literal>CoreBind</literal> and effectively represent the binding of a name to body of code. Top-level module bindings are part of a <literal>ModGuts</literal> in the field <literal>mg_binds</literal>. Implementing a pass that manipulates the top level bindings merely needs to iterate over this field, and return a new <literal>ModGuts</literal> with an updated <literal>mg_binds</literal> field. Because this is such a common case, there is a function provided named <literal>bindsOnlyPass</literal> which lifts a function of type <literal>([CoreBind] -> CoreM [CoreBind])</literal> to type <literal>(ModGuts -> CoreM ModGuts)</literal>. </para> + + <para>Continuing with our example from the last section, we can write a simple plugin that just prints out the name of all the non-recursive bindings in a module it compiles:</para> + +<programlisting> +module SayNames.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass = bindsOnlyPass (mapM printBind) + where printBind :: CoreBind -> CoreM CoreBind + printBind bndr@(NonRec b _) = do + putMsgS $ "Non-recursive binding named " ++ showSDoc (ppr b) + return bndr + printBind bndr = return bndr +</programlisting> + </sect3> + + <sect3 id="getting-annotations"> + <title>Using Annotations</title> + + <para>Previously we discussed annotation pragmas (<xref linkend="annotation-pragmas"/>), which we mentioned could be used to give compiler plugins extra guidance or information. Annotations for a module can be retrieved by a plugin, but you must go through the modules <literal>ModGuts</literal> in order to get it. Because annotations can be arbitrary instances of <literal>Data</literal> and <literal>Typeable</literal>, you need to give a type annotation specifying the proper type of data to retrieve from the interface file, and you need to make sure the annotation type used by your users is the same one your plugin uses. For this reason, we advise distributing annotations as part of the package which also provides compiler plugins if possible.</para> + + <para>To get the annotations of a single binder, you can use `getAnnotations` and specify the proper type. Here's an example that will print out the name of any top-level non-recursive binding with the <literal>SomeAnn</literal> annotation:</para> + +<programlisting> +{-# LANGUAGE DeriveDataTypeable #-} +module SayAnnNames.Plugin (plugin, SomeAnn) where +import GhcPlugins +import Control.Monad (when) +import Data.Data +import Data.Typeable + +data SomeAnn = SomeAnn deriving (Data, Typeable) + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass g = mapM_ (printAnn g) (mg_binds g) >> return g + where printAnn :: ModGuts -> CoreBind -> CoreM CoreBind + printAnn guts bndr@(NonRec b _) = do + anns <- annotationsOn guts b :: CoreM [SomeAnn] + when (not $ null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc (ppr b) + return bndr + printAnn _ bndr = return bndr + +annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] +annotationsOn guts bndr = do + anns <- getAnnotations deserializeWithData guts + return $ lookupWithDefaultUFM anns [] (varUnique bndr) +</programlisting> + + <para>Please see the GHC API documentation for more about how to use internal APIs, etc.</para> + </sect3> + </sect2> + + </sect1> + +</chapter> + +<!-- Emacs stuff: + ;;; Local Variables: *** + ;;; sgml-parent-document: ("users_guide.xml" "book" "chapter" "sect1") *** + ;;; End: *** + --> diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml index 2fef13515d..c037623a49 100644 --- a/docs/users_guide/ffi-chap.xml +++ b/docs/users_guide/ffi-chap.xml @@ -101,7 +101,9 @@ OK: The problem is that it is not possible in general to interrupt a foreign call safely. However, GHC does provide a way to interrupt blocking system calls which works for - most system calls on both Unix and Windows. A foreign call + most system calls on both Unix and Windows. When the + <literal>InterruptibleFFI</literal> extension is enabled, + a foreign call can be annotated with <literal>interruptible</literal> instead of <literal>safe</literal> or <literal>unsafe</literal>: diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 43c713e119..ddec7d79d9 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -487,6 +487,12 @@ <entry>-</entry> </row> <row> + <entry><option>-ghci-script</option></entry> + <entry>Load the given additional <filename>.ghci</filename> file</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> <entry><option>-read-dot-ghci</option></entry> <entry>Enable reading of <filename>.ghci</filename> files</entry> <entry>static</entry> @@ -927,6 +933,12 @@ <entry><option>-XNoUnliftedFFITypes</option></entry> </row> <row> + <entry><option>-XInterruptibleFFI</option></entry> + <entry>Enable interruptible FFI.</entry> + <entry>dynamic</entry> + <entry><option>-XNoInterruptibleFFI</option></entry> + </row> + <row> <entry><option>-XLiberalTypeSynonyms</option></entry> <entry>Enable <link linkend="type-synonyms">liberalised type synonyms</link>.</entry> <entry>dynamic</entry> @@ -1391,13 +1403,6 @@ </row> <row> - <entry><option>-fmethod-sharing</option></entry> - <entry>Share specialisations of overloaded functions (default)</entry> - <entry>dynamic</entry> - <entry><option>-fno-method-sharing</option></entry> - </row> - - <row> <entry><option>-fdo-eta-reduction</option></entry> <entry>Enable eta-reduction. Implied by <option>-O</option>.</entry> <entry>dynamic</entry> @@ -2010,6 +2015,40 @@ phase <replaceable>n</replaceable></entry> </sect2> <sect2> + <title>Plugin options</title> + + <para><xref linkend="compiler-plugins"/></para> + + <informaltable> + <tgroup cols="4" align="left" colsep="1" rowsep="1"> + <thead> + <row> + <entry>Flag</entry> + <entry>Description</entry> + <entry>Static/Dynamic</entry> + <entry>Reverse</entry> + </row> + </thead> + <tbody> + <row> + <entry><option>-fplugin</option>=<replaceable>module</replaceable></entry> + <entry>Load a plugin exported by a given module</entry> + <entry>static</entry> + <entry>-</entry> + </row> + <row> + <entry><option>-fplugin-opt</option>=<replaceable>module:args</replaceable></entry> + <entry>Give arguments to a plugin module; module must be specified with <option>-fplugin</option></entry> + <entry>static</entry> + <entry>-</entry> + </row> + </tbody> + </tgroup> + </informaltable> + </sect2> + + + <sect2> <title>Replacing phases</title> <para><xref linkend="replacing-phases"/></para> diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml index 72481eb24f..62522e855b 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -2872,6 +2872,10 @@ Prelude> :set -fno-glasgow-exts </varlistentry> </variablelist> + <para>Additional <filename>.ghci</filename> files can be added + through the <option>-ghci-script</option> option. These are + loaded after the normal <filename>.ghci</filename> files.</para> + </sect1> <sect1 id="ghci-obj"> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 09a9062ffc..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 ] @@ -1812,18 +1814,35 @@ the same as the omitted field names. <listitem><para> The "<literal>..</literal>" expands to the missing -<emphasis>in-scope</emphasis> record fields, where "in scope" -includes both unqualified and qualified-only. -Any fields that are not in scope are not filled in. For example +<emphasis>in-scope</emphasis> record fields. +Specifically the expansion of "<literal>C {..}</literal>" includes +<literal>f</literal> if and only if: +<itemizedlist> +<listitem><para> +<literal>f</literal> is a record field of constructor <literal>C</literal>. +</para></listitem> +<listitem><para> +The record field <literal>f</literal> is in scope somehow (either qualified or unqualified). +</para></listitem> +<listitem><para> +In the case of expressions (but not patterns), +the variable <literal>f</literal> is in scope unqualified, +apart from the binding of the record selector itself. +</para></listitem> +</itemizedlist> +For example <programlisting> module M where data R = R { a,b,c :: Int } module X where - import qualified M( R(a,b) ) - f a b = R { .. } -</programlisting> -The <literal>{..}</literal> expands to <literal>{M.a=a,M.b=b}</literal>, -omitting <literal>c</literal> since it is not in scope at all. + import M( R(a,c) ) + f b = R { .. } +</programlisting> +The <literal>R{..}</literal> expands to <literal>R{M.a=a}</literal>, +omitting <literal>b</literal> since the record field is not in scope, +and omitting <literal>c</literal> since the variable <literal>c</literal> +is not in scope (apart from the binding of the +record selector <literal>c</literal>, of course). </para></listitem> </itemizedlist> </para> @@ -4343,7 +4362,8 @@ literals enabled (with <literal>-XOverloadedStrings</literal>) a string literal has type <literal>(IsString a) => a</literal>. </para> <para> -This means that the usual string syntax can be used, e.g., for packed strings + This means that the usual string syntax can be used, e.g., + for <literal>ByteString</literal>, <literal>Text</literal>, and other variations of string like types. String literals behave very much like integer literals, i.e., they can be used in both expressions and patterns. If used in a pattern the literal with be replaced by an equality test, in the same @@ -5034,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 ~ @@ -5074,13 +5094,9 @@ class (F a ~ b) => C a b where with the class head. Method signatures are not affected by that process. </para> - <para> - NB: Equalities in superclass contexts are not fully implemented in - GHC 6.10. - </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 @@ -7944,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, @@ -8099,82 +8115,6 @@ happen. </sect3> </sect2> - <sect2 id="annotation-pragmas"> - <title>ANN pragmas</title> - - <para>GHC offers the ability to annotate various code constructs with additional - data by using three pragmas. This data can then be inspected at a later date by - using GHC-as-a-library.</para> - - <sect3 id="ann-pragma"> - <title>Annotating values</title> - - <indexterm><primary>ANN</primary></indexterm> - - <para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value - binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal> - to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>). - By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal> - you would do this:</para> - -<programlisting> -{-# ANN foo (Just "Hello") #-} -foo = ... -</programlisting> - - <para> - A number of restrictions apply to use of annotations: - <itemizedlist> - <listitem><para>The binder being annotated must be at the top level (i.e. no nested binders)</para></listitem> - <listitem><para>The binder being annotated must be declared in the current module</para></listitem> - <listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem> - <listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the - expression being annotated with, so for example you cannot run a function from the module being compiled.</para> - - <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be - (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem> - </itemizedlist> - - If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC"> - please give the GHC team a shout</ulink>. - </para> - - <para>However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! - Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para> - -<programlisting> -{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} -f = ... -</programlisting> - </sect3> - - <sect3 id="typeann-pragma"> - <title>Annotating types</title> - - <indexterm><primary>ANN type</primary></indexterm> - <indexterm><primary>ANN</primary></indexterm> - - <para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para> - -<programlisting> -{-# ANN type Foo (Just "A `Maybe String' annotation") #-} -data Foo = ... -</programlisting> - </sect3> - - <sect3 id="modann-pragma"> - <title>Annotating modules</title> - - <indexterm><primary>ANN module</primary></indexterm> - <indexterm><primary>ANN</primary></indexterm> - - <para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para> - -<programlisting> -{-# ANN module (Just "A `Maybe String' annotation") #-} -</programlisting> - </sect3> - </sect2> <sect2 id="line-pragma"> <title>LINE pragma</title> @@ -8415,7 +8355,11 @@ data T = T {-# UNPACK #-} !Float compiler).</para> <para>Unpacking constructor fields should only be used in - conjunction with <option>-O</option>, in order to expose + conjunction with <option>-O</option><footnote>in fact, UNPACK + has no effect without <option>-O</option>, for technical + reasons + (see <ulink url="http://hackage.haskell.org/trac/ghc/ticket/5252">tick + 5252</ulink>)</footnote>, in order to expose unfoldings to the compiler so the reboxing can be removed as often as possible. For example:</para> @@ -9223,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> @@ -9254,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 @@ -9274,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: @@ -9316,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> @@ -9335,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 @@ -9344,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> @@ -9381,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> diff --git a/docs/users_guide/intro.xml b/docs/users_guide/intro.xml index e219f9020c..e0ed2f373e 100644 --- a/docs/users_guide/intro.xml +++ b/docs/users_guide/intro.xml @@ -346,7 +346,7 @@ </sect1> -&relnotes1; +<!-- &relnotes1; --> </chapter> diff --git a/docs/users_guide/runtime_control.xml b/docs/users_guide/runtime_control.xml index defae22823..48ea0a875b 100644 --- a/docs/users_guide/runtime_control.xml +++ b/docs/users_guide/runtime_control.xml @@ -1114,11 +1114,60 @@ char *ghc_rts_opts = "-H128m -K1m"; <listitem> <para> Log events in binary format to the - file <filename><replaceable>program</replaceable>.eventlog</filename>, - where <replaceable>flags</replaceable> is a sequence of - zero or more characters indicating which kinds of events - to log. Currently there is only one type - supported: <literal>-ls</literal>, for scheduler events. + file <filename><replaceable>program</replaceable>.eventlog</filename>. + Without any <replaceable>flags</replaceable> specified, this logs a + default set of events, suitable for use with tools like ThreadScope. + </para> + + <para> + For some special use cases you may want more control over which + events are included. The <replaceable>flags</replaceable> is a + sequence of zero or more characters indicating which classes of + events to log. Currently there are four classes of events that can + be enabled/disabled: + <simplelist> + <member> + <option>s</option> — scheduler events, including Haskell + thread creation and start/stop events + </member> + <member> + <option>g</option> — GC events, including GC start/stop + </member> + <member> + <option>p</option> — parallel sparks (sampled) + </member> + <member> + <option>f</option> — parallel sparks (fully accurate) + </member> + </simplelist> + </para> + + <para> + For spark events there are two modes: sampled and fully accurate. + There are various events in the life cycle of each spark, usually + just creating and running, but there are some more exceptional + possibilities. In the sampled mode the number of occurrences of each + kind of spark event is sampled at frequent intervals. In the fully + accurate mode every spark event is logged individually. The latter + has a higher runtime overhead and is not enabled by default. + </para> + + <para> + The initial enabled event classes are 's', 'g' and 'p'. In addition + you can disable specific classes, or enable/disable all classes at + once: + <simplelist> + <member> + <option>a</option> — enable all event classes listed above + </member> + <member> + <option>-<replaceable>x</replaceable></option> — disable the + given class of events, for any event class listed above or + <option>-a</option> for all classes + </member> + </simplelist> + For example, <option>-l-ag</option> would disable all event classes + (<option>-a</option>) except for GC events (<option>g</option>). </para> <para> @@ -1128,7 +1177,7 @@ char *ghc_rts_opts = "-H128m -K1m"; the <ulink url="http://hackage.haskell.org/package/ghc-events">ghc-events</ulink> library. To dump the contents of a <literal>.eventlog</literal> file as text, use the - tool <literal>show-ghc-events</literal> that comes with + tool <literal>ghc-events-show</literal> that comes with the <ulink url="http://hackage.haskell.org/package/ghc-events">ghc-events</ulink> package. </para> diff --git a/docs/users_guide/safe_haskell.xml b/docs/users_guide/safe_haskell.xml index c2f42c000c..abca32a71f 100644 --- a/docs/users_guide/safe_haskell.xml +++ b/docs/users_guide/safe_haskell.xml @@ -1,72 +1,305 @@ <?xml version="1.0" encoding="iso-8859-1"?> <sect1 id="safe-haskell"> <title>Safe Haskell</title> - - Safe Haskell is an extension to the Haskell language supported by GHC, that - provides certain safety guarantees about Haskell code compiled using this - extension. It allows people to build more advance security mechanisms on top - of Haskell and for the safe execution of untrusted Haskell code. Its purpose - isn't to provide a complete secure execution environment for Haskell code but - to give users enough guarantees about the Haskell language to be able to - build such systems. Its design is similar to the safe and unsafe module - system supported by the Modula-3 language. - + + <para> + Safe Haskell is an extension to the Haskell language that is implemented in + GHC as of version 7.2. It allows for unsafe code to be securely included in a + trusted code base by restricting the features of GHC Haskell the code is + allowed to use. Put simply, it makes the types of programs trustable. Safe + Haskell itself is aimed to be as minimal as possible while still providing + strong enough guarantees about compiled Haskell code for more advance secure + systems to be built on top of it. These include techniques such as + information flow control security or encrypted computations. + </para> + The design of Safe Haskell covers the following aspects: + <itemizedlist> - <listitem>A <link linkend="safe-language-overview">safe language</link> - dialect of Haskell that provides guarantees about the code. Mainly it - allows the types and module boundaries to be trusted. + <listitem>A <link linkend="safe-language">safe language</link> dialect of + Haskell that provides guarantees about the code. It allows types and + module boundaries to be trusted. </listitem> <listitem>A new <emphasis>safe import</emphasis> extension that specifies - the module being imported must be trusted. + that the module being imported must be trusted. </listitem> <listitem>A definition of <emphasis>trust</emphasis> (or safety) and how it operates, along with ways of defining and changing the trust of modules and packages. </listitem> </itemizedlist> - - <sect2 id="safe-language-overview"> - <title>Safe Language Overview</title> - The Safe Haskell <emphasis>Safe language</emphasis> guarantees the + <sect2 id="safe-use-cases"> + <title>Uses of Safe Haskell</title> + + Safe Haskell has been designed with two use cases in mind: + + <itemizedlist> + <listitem>Enforcing strict type safety at compile time</listitem> + <listitem>Compiling and executing untrusted code</listitem> + </itemizedlist> + + <sect3> + <title>Strict type-safety (good style)</title> + + Haskell offers a powerful type system and separation of pure and + effectual functions through the <literal>IO</literal> monad. There are + several loop holes in the type system though, the most obvious offender + being the <literal>unsafePerformIO :: IO a -> a</literal> function. The + safe language dialect of Safe Haskell disallows the use of such + functions. This can be useful for a variety of purposes as it makes + Haskell code easier to analyze and reason about. It also codifies an + existing culture in the Haskell community of trying to avoid using such + unsafe functions unless absolutely necessary. As such using the safe + language (through the <option>-XSafe</option> flag) can be though of as a + way of enforcing good style, similar to the function of + <option>-Wall</option>. + </sect3> + + <sect3> + <title>Building secure systems (restricted IO Monads)</title> + + <para> + Safe Haskell is designed to give users enough guarantees about the safety + properties of compiled code so that secure systems can be built using + Haskell. A lot of work has been done with Haskell, building such systems + as information flow control security, capability based security, DSLs for + working with encrypted data... etc. These systems all rely on properties + of the Haskell language that aren't true in the general case where uses + of functions like <literal>unsafePerformIO</literal> are allowed. + </para> + + <para> + As an example lets define an interface for a plugin system where the + plugin authors are untrusted, possibly malicious third-parties. We do + this by restricting the plugin interface to pure functions or to a + restricted <literal>IO</literal> monad that we have defined that only + allows a safe subset of <literal>IO</literal> actions to be executed. We + define the plugin interface here so that it requires the plugin module, + <literal>Danger</literal>, to export a single computation, + <literal>Danger.runMe</literal>, of type <literal>RIO ()</literal>, where + <literal>RIO</literal> is a new monad defined as follows: + </para> + + <programlisting> + -- Either of the following Safe Haskell pragmas would do + {-# LANGUAGE Trustworthy #-} + {-# LANGUAGE Safe #-} + + module RIO (RIO(), runRIO, rioReadFile, rioWriteFile) where + + -- Notice that symbol UnsafeRIO is not exported from this module! + newtype RIO a = UnsafeRIO { runRIO :: IO a } + + instance Monad RIO where + return = UnsafeRIO . return + (UnsafeRIO m) >>= k = UnsafeRIO $ m >>= runRIO . k + + -- Returns True iff access is allowed to file name + pathOK :: FilePath -> IO Bool + pathOK file = {- Implement some policy based on file name -} + + rioReadFile :: FilePath -> RIO String + rioReadFile file = UnsafeRIO $ do + ok <- pathOK file + if ok then readFile file else return "" + + rioWriteFile :: FilePath -> String -> RIO () + rioWriteFile file contents = UnsafeRIO $ do + ok <- pathOK file + if ok then writeFile file contents else return () + </programlisting> + + We compile Danger using the new Safe Haskell <option>-XSafe</option> flag: + + <programlisting> + {-# LANGUAGE Safe #-} + module Danger ( runMe ) where + + runMe :: RIO () + runMe = ... + </programlisting> + + Before going into the Safe Haskell details, lets point out some of + the reasons this design would fail without Safe Haskell: + + <itemizedlist> + <listitem>The design attempts to restrict the operations that Danger + can perform by using types, specifically the <literal>RIO</literal> + type wrapper around <literal>IO</literal>. The author of Danger can + subvert this though by simply writing arbitrary + <literal>IO</literal> actions and using <literal>unsafePerformIO :: + IO a -> a</literal> to execute them as pure functions. + </listitem> + <listitem>The design also relies on the Danger module not being able + to access the <literal>UnsafeRIO</literal> constructor. + Unfortunately Template Haskell can be used to subvert module + boundaries and so could be used gain access to this constructor. + </listitem> + <listitem>There is no way to place restrictions on the modules that + the untrusted Danger module can import. This gives the author of + Danger a very large attack surface, essentially any package + currently installed on the system. Should any of these packages + have a vulnerability then the Danger module can exploit this. The + only way to stop this would be to patch or remove packages with + known vulnerabilities even if they should only be used by + trusted code such as the RIO module. + </listitem> + </itemizedlist> + + <para> + To stop these attacks Safe Haskell can be used. This is done by compiling + the RIO module with the <option>-XTrustworthy</option> flag and compiling + the Danger module with the <option>-XSafe</option> flag. + </para> + + <para> + The use of the <option>-XSafe</option> flag to compile the Danger module + restricts the features of Haskell that can be used to a + <link linkend="safe-language">safe subset</link>. This includes + disallowing <literal>unsafePerfromIO</literal>, Template Haskell, pure + FFI functions, Generalized Newtype Deriving, RULES and restricting the + operation of Overlapping Instances. The <option>-XSafe</option> flag also + restricts the modules can be imported by Danger to only those that are + considered trusted. Trusted modules are those compiled with + <option>-XSafe</option>, where GHC provides a mechanical guarantee that + the code is safe. Or those modules compiled with + <option>-XTrustworthy</option>, where the module author claims that the + module is Safe. + </para> + + <para> + This is why the RIO module is compiled with + <option>-XTrustworthy</option>, to allow the Danger module to import it. + The <option>-XTrustworthy</option> flag doesn't place any restrictions on + the module like <option>-XSafe</option> does. Instead the module author + claims that while code may use unsafe features internally, it only + exposes an API that can used in a safe manner. There is an issue here as + <option>-XTrustworthy</option> may be used by an arbitrary module and + module author. Because of this for trustworthy modules to be considered + trusted, and so allowed to be used in <option>-XSafe</option> compiled + code, the client C compiling the code must tell GHC that they trust the + package the trustworthy module resides in. This is essentially a way of + for C to say, while this package contains trustworthy modules that can be + used by untrusted modules compiled with <option>-XSafe </option>, I trust + the author(s) of this package and trust the modules only expose a safe + API. The trust of a package can be changed at any time, so if a + vulnerability found in a package, C can declare that package untrusted so + that any future compilation against that package would fail. For a more + detailed overview of this mechanism see <xref linkend="safe-trust"/>. + </para> + + <para> + So Danger can import module RIO because RIO is marked trustworthy. Thus, + Danger can make use of the rioReadFile and rioWriteFile functions to + access permitted file names. The main application then imports both RIO + and Danger. To run the plugin, it calls RIO.runRIO Danger.runMe within + the IO monad. The application is safe in the knowledge that the only IO + to ensue will be to files whose paths were approved by the pathOK test. + </para> + </sect3> + </sect2> + + <sect2 id="safe-language"> + <title>Safe Language</title> + + The Safe Haskell <emphasis>safe language</emphasis> guarantees the following properties: + <itemizedlist> - <listitem><emphasis>Referential transparency.</emphasis> Functions - in the Safe language are deterministic, evaluating them will not - cause any side effects. Functions in the <emphasis>IO</emphasis> - monad are still allowed and behave as usual but any pure function - as according to the functions type is guaranteed to indeed be - pure. This property allows a user of the Safe language to trust - the types of functions. + <listitem><emphasis>Referential transparency</emphasis> — Functions + in the safe language are deterministic, evaluating them will not + cause any side effects. Functions in the <literal>IO</literal> monad + are still allowed and behave as usual. Any pure function though, as + according to its type, is guaranteed to indeed be pure. This property + allows a user of the safe language to trust the types. This means, + for example, that the <literal>unsafePerformIO :: IO a -> a</literal> + function is disallowed in the safe language. </listitem> - <listitem><emphasis>Module boundary control.</emphasis> Haskell code - compiled using the Safe language is guaranteed to only access - symbols that are publicly available to it through other modules - export lists. An import part of this is that safe compiled code - is not able to examine or create data values using data constructors - that the module cannot import. If a module M establishes some - invariants through careful use of its export list then code - compiled using the Safe language that imports M is guaranteed to - respect those invariants. + <listitem><emphasis>Module boundary control</emphasis> — Haskell + code compiled using the safe language is guaranteed to only access + symbols that are publicly available to it through other modules export + lists. An important part of this is that safe compiled code is not + able to examine or create data values using data constructors + that it cannot import. If a module M establishes some invariants + through careful use of its export list then code compiled using the + safe language that imports M is guaranteed to respect those invariants. + Because of this, <emphasis><link linkend="template-haskell">Template + Haskell</link></emphasis> and <emphasis> + <link linkend="newtype-deriving">GeneralizedNewtypeDeriving</link> + </emphasis> are both disabled in the safe language as they can be used + to violate this property. </listitem> - <listitem><emphasis>Semantic consistency.</emphasis> The Safe language - is strictly a subset of Haskell as implemented by GHC. Any expression - that compiles in the safe language has the same meaning as it does - when compiled in normal Haskell. In addition, in any module that imports - a Safe language module, expressions that compile both with and without - the safe import have the same meaning in both cases. That is, importing - a module using the Safe language cannot change the meaning of existing - code that isn't dependent on that module. + <listitem><emphasis>Semantic consistency</emphasis> — The safe + language is strictly a subset of Haskell as implemented by GHC. Any + expression that compiles in the safe language has the same meaning as + it does when compiled in normal Haskell. In addition, in any module + that imports a safe language module, expressions that compile both + with and without the safe import have the same meaning in both cases. + That is, importing a module using the safe language cannot change the + meaning of existing code that isn't dependent on that module. So for + example, there are some restrictions placed on the <emphasis> + <link linkend="instance-overlap">Overlapping Instances</link> + </emphasis> extension as it can violate this property. </listitem> </itemizedlist> - - Put simply, these three properties guarantee that you can trust the types - in the Safe language, can trust that module export lists are respected - in the Safe language and can trust that code which successfully compiles - in the Safe language has the same meaning as it normally would. Please see - <xref linkend="safe-language"/> for a more detailed view of the safe - language. + + <para> + These three properties guarantee that you can trust the types in the safe + language, can trust that module export lists are respected in the safe + language and can trust that code that successfully compiles using the safe + language has the same meaning as it normally would. + </para> + + Lets now look at the details of the safe language. In the safe language + dialect (enabled by <option>-XSafe</option>) we disable completely the + following features: + + <itemizedlist> + <listitem><emphasis>GeneralizedNewtypeDeriving</emphasis> — It can + be used to violate constructor access control, by allowing untrusted + code to manipulate protected data types in ways the data type author + did not intend. For example can be used to break invariants of data + structures.</listitem> + <listitem><emphasis>TemplateHaskell</emphasis> — Is particularly + dangerous, as it can cause side effects even at compilation time and + can be used to access abstract data types. It is very easy to break + module boundaries with TH.</listitem> + </itemizedlist> + + In the safe language dialect we restrict the following features: + <itemizedlist> + <listitem><emphasis>ForeignFunctionInterface</emphasis> — This is + mostly safe, but foreign import declarations that import a function + with a non-IO type are disallowed. All FFI imports must reside in the + IO Monad.</listitem> + <listitem><emphasis>RULES</emphasis> — As they can change the + behaviour of trusted code in unanticipated ways, violating semantic + consistency they are restricted in function. Specifically any RULES + defined in a module M compiled with <option>-XSafe</option> are + dropped. RULES defined in trustworthy modules that M imports are still + valid and will fire as usual.</listitem> + <listitem><emphasis>OverlappingInstances</emphasis> — This + extension can be used to violate semantic consistency, because + malicious code could redefine a type instance (by containing a more + specific instance definition) in a way that changes the behaviour of + code importing the untrusted module. The extension is not disabled for + a module M compiled with <option>-XSafe</option> but restricted. While M + can define overlapping instance declarations, they can only overlap + other instance declaration defined in M. If in a module N that imports + M, at a call site that uses a type-class function there is a choice of + which instance to use (i.e. an overlap) and the most specific instances + is from M, then all the other choices must also be from M. If not, a + compilation error will occur. A simple way to think of this is a + <emphasis>same origin policy</emphasis> for overlapping instances + defined in Safe compiled modules.</listitem> + <listitem><emphasis>Data.Typeable</emphasis> — We restrict Typeable + instances to only derived ones (offered by GHC through the + <link linkend="deriving-typeable"><option>-XDeriveDataTypeable</option> + </link> extension). Hand crafted instances of the Typeable type class + are not allowed in Safe Haskell as this can easily be abused to + unsafely coerce between types.</listitem> + </itemizedlist> </sect2> <sect2 id="safe-imports"> @@ -74,61 +307,66 @@ Safe Haskell enables a small extension to the usual import syntax of Haskell, adding a <emphasis>safe</emphasis> keyword: - <programlisting> impdecl -> import [safe] [qualified] modid [as modid] [impspec] </programlisting> - When used, the module being imported with the safe keyword must be a trusted - module, otherwise a compilation error will occur. The safe import extension - is enabled by either of the <emphasis>-XSafe</emphasis>, - <emphasis>-XTrustworthy</emphasis>, <emphasis>-XSafeLanguage</emphasis> or - <emphasis>-XSafeImports</emphasis> flags and corresponding PRAGMA's. When - either the <emphasis>-XSafe</emphasis> or - <emphasis>-XSafeLanguage</emphasis> flag is used, the safe keyword is - allowed but meaningless -- all imports are safe regardless. + When used, the module being imported with the safe keyword must be a + trusted module, otherwise a compilation error will occur. The safe import + extension is enabled by either of the <option>-XSafe</option>, + <option>-XTrustworthy</option>, or <option>-XSafeImports</option> + flags and corresponding PRAGMA's. When the <option>-XSafe</option> flag + is used, the safe keyword is allowed but meaningless, every import + is required to be safe regardless. </sect2> <sect2 id="safe-trust"> <title>Trust</title> The Safe Haskell extension introduces the following two new language flags: + <itemizedlist> - <listitem><emphasis>-XSafe:</emphasis> Enables the Safe language dialect, - asking GHC to guarantee trust. The safe language dialect requires that - all imports be trusted or a compile error will occur.</listitem> - <listitem><emphasis>-XTrustworthy:</emphasis> Means that while this module - may invoke unsafe functions internally, the module's author claims that - it exports an API that can't be used in an unsafe way. This doesn't enable - the Safe language or place any restrictions on the allowed Haskell code. - The trust guarantee is provided by the module author, not GHC. An import - statement with the safe keyword results in a compilation error if the - imported module is not trussted. An import statement without the keyword - behaves as usual and can import any module whether trusted or - not.</listitem> + <listitem><emphasis>-XSafe</emphasis> — Enables the safe language + dialect, asking GHC to guarantee trust. The safe language dialect + requires that all imports be trusted or a compilation error will + occur.</listitem> + <listitem><emphasis>-XTrustworthy</emphasis> — Means that while + this module may invoke unsafe functions internally, the module's + author claims that it exports an API that can't be used in an unsafe + way. This doesn't enable the safe language or place any restrictions + on the allowed Haskell code. The trust guarantee is provided by the + module author, not GHC. An import statement with the safe keyword + results in a compilation error if the imported module is not trusted. + An import statement without the keyword behaves as usual and can + import any module whether trusted or not.</listitem> </itemizedlist> + <para> Whether or not a module is trusted depends on a notion of trust for - packages, which is determined by the client C invoking GHC (i.e., you). A + packages, which is determined by the client C invoking GHC (i.e. you). A package <emphasis>P</emphasis> is trusted when either C's package database records that <emphasis>P</emphasis> is trusted (and no command-line arguments override this), or C's command-line flags say to trust it regardless of what is recorded in the package database. In either case, C is the only authority on package trust. It is up to the client to decide - which packages they trust. + which <link linkend="safe-package-trust">packages they trust</link>. + </para> - Now a <emphasis>module M in a package P is trusted by a client C</emphasis> + So a <emphasis>module M in a package P is trusted by a client C</emphasis> if and only if: + <itemizedlist> <listitem>Both of these hold: <itemizedlist> - <listitem> The module was compiled with <emphasis>-XSafe</emphasis></listitem> + <listitem> The module was compiled with <option>-XSafe</option> + </listitem> <listitem> All of M's direct imports are trusted by C</listitem> </itemizedlist> </listitem> <listitem><emphasis>OR</emphasis> all of these hold: <itemizedlist> - <listitem>The module was compiled with <emphasis>-XTrustworthy</emphasis></listitem> + <listitem>The module was compiled with <option>-XTrustworthy</option> + </listitem> <listitem>All of M's direct safe imports are trusted by C</listitem> <listitem>Package P is trusted by C</listitem> </itemizedlist> @@ -136,319 +374,79 @@ </itemizedlist> For the first trust definition the trust guarantee is provided by GHC - through the restrictions imposed by the Safe language. For the second + through the restrictions imposed by the safe language. For the second definition of trust, the guarantee is provided initially by the module author. The client C then establishes that they trust the module author by indicating they trust the package the module resides in. This trust chain is required as GHC provides no guarantee for - <emphasis>-XTrustworthy</emphasis> compiled modules. + <literal>-XTrustworthy</literal> compiled modules. <sect3 id="safe-trust-example"> - <title>Example</title> - - <programlisting> - Package Wuggle: - {-# LANGUAGE Safe #-} - module Buggle where - import Prelude - f x = ...blah... - - Package P: - {-# LANGUAGE Trustworthy #-} - module M where - import System.IO.Unsafe - import safe Buggle - </programlisting> - - Suppose a client C decides to trust package P. Then does C trust module M? - To decide, GHC must check M's imports: M imports System.IO.Unsafe. M was - compiled with -XTrustworthy, so P's author takes responsibility for that - import. C trusts P's author, so C trusts M to only use its unsafe - imports (System.IO.Unsafe in this example)in a safe and consistent - manner with respect the API M exposes. M also has a safe import of - Buggle, so for this import P's author takes no responsibility for the - safety or otherwise. So GHC must check whether Buggle is trusted by C. - Is it? Well, it is compiled with -XSafe, so the code in Buggle itself is - machine-checked to be OK, but again under the assumption that all of - Buggle's imports are trusted by C. Prelude comes from base, which C - trusts, and is compiled with -XTrustworthy (While Prelude is typically - imported implicitly, it still obeys the same rules outlined here). So - Buggle is considered trusted. - - Notice that C didn't need to trust package Wuggle; the machine checking - is enough. C only needs to trust packages that have -XTrustworthy - modules in them. - </sect3> + <title>Example</title> - <sect3 id="safe-no-trust"> - <title>Safe Language & Imports without Trust</title> - - Safe Haskell also allows the new language extensions -- the Safe language - dialect and safe imports -- to be used independtly of any trust - assertions for the code. - - <itemizedlist> - <listitem><emphasis>-XSafeImports</emphasis>: enables the safe import - extension. The module using this feature is left untrusted - though.</listitem> - <listitem><emphasis>-XSafeLanguage</emphasis>: - enables the safe language extension. The module using this feature - is left untrusted though.</listitem> - </itemizedlist> - - These are extensions are useful for encouraging good programming style and - also for flexibility during development when using Safe Haskell. The Safe - language encourages users to avoid liberal use of unsafe Haskell language - features. There are also situations where a module may only use the Safe - language subset but exposes some internal API's that code using - <emphasis>-XSafe</emphasis> shouldn't be allowed to access for security - reasons. Please see <link linkend="safe-use-cases">Safe Haskell use - cases</link> for a more detailed explanation. - </sect3> + <programlisting> + Package Wuggle: + {-# LANGUAGE Safe #-} + module Buggle where + import Prelude + f x = ...blah... + + Package P: + {-# LANGUAGE Trustworthy #-} + module M where + import System.IO.Unsafe + import safe Buggle + </programlisting> - <sect3 id="safe-flag-summary"> - <title>Safe Haskell Flag Summary</title> - - In summary, Safe Haskell consists of the following language flags: - - <itemizedlist> - <listitem> - <emphasis>-XSafe</emphasis> - <itemizedlist> - <listitem>To be trusted, all of the module's direct imports must be - trusted, but the module itself need not reside in a trusted - package, because the compiler vouches for its trustworthiness. The - "safe" keyword is allowed but meaningless in import statements -- - conceptually every import is safe whether or not so - tagged.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> Yes</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe - Language</listitem> - <listitem><emphasis>Imported Modules:</emphasis> All forced to be - safe imports, all must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XSafeLanguage:</emphasis> - <itemizedlist> - <listitem>The module is never trusted, because the author does not - claim it is trustworthy. As long as the module compiles both ways, - the result is identical whether or not the -XSafeLanguage flag is - supplied. As with -XSafe, the "safe" import keyword is allowed but - meaningless -- all imports must be safe.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> No</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe - Language</listitem> - <listitem><emphasis>Imported Modules:</emphasis> All forced to be - safe imports, all must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XTrustworthy:</emphasis> - <itemizedlist> - <listitem>This establishes that the module is trusted, but the - guarantee is provided by the module's author. A client of this - module then specifies that they trust the module author by - specifying they trust the package containing the module. - '-XTrustworthy' has no effect on the accepted range of Haskell - programs or their semantics, except that they allow the safe - import keyword.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> Yes but only if - Package the module resides in is also trusted.</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Unrestricted - </listitem> - <listitem><emphasis>Imported Modules:</emphasis> Under control - of module author which ones must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XSafeLanguage -XTrustworthy:</emphasis> - <itemizedlist> - <listitem>For the trust property this has the same effect as - '-XTrustworthy' by itself. However unlike -XTrustworthy it also - restricts the range of acceptable Haskell programs to the Safe - language. The difference from this and using -XSafe is the - different trust type and that not all imports are forced to be - safe imports, they are instead optionally specified by the module - author.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> Yes but only if Package - the module resides in is also trusted.</listitem> - <listitem><emphasis>Haskell Language:</emphasis> Restricted to Safe - Language</listitem> - <listitem><emphasis>Imported Modules:</emphasis> Under control of - module author which ones must be trusted.</listitem> - </itemizedlist> - </listitem> - <listitem> - <emphasis>-XSafeImport:</emphasis> - <itemizedlist> - <listitem>Enable the Safe Import extension so that a module can - require a dependency to be trusted without asserting any trust - about itself.</listitem> - <listitem><emphasis>Module Trusted:</emphasis> No</listitem> - <listitem><emphasis>Haskell Language:</emphasis> - Unrestricted</listitem> - <listitem><emphasis>Imported Modules:</emphasis> Under control of - module author which ones must be trusted.</listitem> - </itemizedlist> - </listitem> - </itemizedlist> + <para> + Suppose a client C decides to trust package P. Then does C trust module + M? To decide, GHC must check M's imports — M imports + System.IO.Unsafe. M was compiled with <option>-XTrustworthy</option>, so + P's author takes responsibility for that import. C trusts P's author, so + C trusts M to only use its unsafe imports in a safe and consistent + manner with respect to the API M exposes. M also has a safe import of + Buggle, so for this import P's author takes no responsibility for the + safety, so GHC must check whether Buggle is trusted by C. Is it? Well, + it is compiled with <option>-XSafe</option>, so the code in Buggle + itself is machine-checked to be OK, but again under the assumption that + all of Buggle's imports are trusted by C. Prelude comes from base, which + C trusts, and is compiled with <option>-XTrustworthy</option> (While + Prelude is typically imported implicitly, it still obeys the same rules + outlined here). So Buggle is considered trusted. + </para> + + <para> + Notice that C didn't need to trust package Wuggle; the machine checking + is enough. C only needs to trust packages that contain + <option>-XTrustworthy</option> modules. + </para> </sect3> <sect3 id="safe-package-trust"> <title>Package Trust</title> - Safe Haskell gives packages a new boolean property, that of trust. Several new options are available - at the GHC command-line to specify the trust property of packages: + Safe Haskell gives packages a new Boolean property, that of trust. + Several new options are available at the GHC command-line to specify the + trust property of packages: <itemizedlist> - <listitem><emphasis>-trust P</emphasis>: Exposes package P if it was - hidden and considers it a trusted package regardless of the package - database.</listitem> - <listitem><emphasis>-distrust P</emphasis>: Exposes package P if it was - hidden and considers it an untrusted package regardless of the + <listitem><emphasis>-trust P</emphasis> — Exposes package P if it + was hidden and considers it a trusted package regardless of the + package database.</listitem> + <listitem><emphasis>-distrust P</emphasis> — Exposes package P if + it was hidden and considers it an untrusted package regardless of the package database.</listitem> - <listitem><emphasis>-distrust-all-packages</emphasis>: Considers all - packages distrusted unless they are explicitly set to be trusted by - subsequent command-line options.</listitem> + <listitem><emphasis>-distrust-all-packages</emphasis> — Considers + all packages distrusted unless they are explicitly set to be trusted + by subsequent command-line options.</listitem> </itemizedlist> - To set a package's trust property in the package database please refer to <xref linkend="packages"/>. - </sect3> - - </sect2> - - <sect2 id="safe-language"> - <title>Safe Language Details</title> - - In the Safe language dialect we disable completely the following Haskell language features: - <itemizedlist> - <listitem><emphasis>GeneralizedNewtypeDeriving:</emphasis> It can be used - to violate constructor access control, by allowing untrusted code to - manipulate protected data types in ways the data type author did not - intend. For example can be used to break invariants of data - structures.</listitem> - <listitem><emphasis>TemplateHaskell:</emphasis> Is particularly - dangerous, as it can cause side effects even at compilation time and - can be used to access abstract data types. It is very easy to break - module boundaries with TH.</listitem> - </itemizedlist> - - In the Safe language dialect we restrict the following Haskell language features: - <itemizedlist> - <listitem><emphasis>ForeignFunctionInterface:</emphasis> This is mostly - safe, but foreign import declarations that import a function with a - non-IO type are disallowed. All FFI imports must reside in the IO - Monad.</listitem> - <listitem><emphasis>RULES:</emphasis> As they can change the behaviour of - trusted code in unanticipated ways, violating semantic consistency they - are restricted in function. Specifically any RULES defined in a module - M compiled with -XSafe or -XSafeLanguage are dropped. RULES defined in - trustworthy modules that M imports are still valid and will fire as - usual.</listitem> - <listitem><emphasis>OverlappingInstances:</emphasis> This extension - can be used to violate semantic consistency, because malicious code - could redefine a type instance (by containing a more specific - instance definition) in a way that changes the behaviour of code - importing the untrusted module. The extension is not disabled for a - module M compiled with -XSafe or -XSafeLanguage but restricted. - While M can define overlapping instance declarations, they can - only overlap other instance declaration defined in M. If in a module N - that imports M, at a call site that uses type-class function there is - a choice of which instance to use (i.e. overlapping) and the most - specific instances is from M, then all the other choices must also be - from M. If not, a compilation error will occur. A simple way to think - of this is a <emphasis>same origin policy</emphasis> for overlapping - instances defined in Safe compiled modules.</listitem> - </itemizedlist> - </sect2> - - <sect2 id="safe-use-cases"> - <title>Use Cases</title> - - Safe Haskell has been designed with the following use cases in mind. - - <sect3> - <title>Enforcing Good Programming Style</title> - - Over-reliance on magic functions such as unsafePerformIO or magic symbols - such as realWorld# can lead to less elegant Haskell code. The Safe dialect - formalizes this notion of magic and prohibits its use. Thus, people may - encourage their collaborators to use the Safe dialect, except when truly - necessary, so as to promote better programming style. It can be thought - of as an addition to using <option>-Wall -Werror</option>. - </sect3> - - <sect3> - <title>Building Secure Systems (restricted IO Monads)</title> - - The original use case that Safe Haskell was designed for was to allow - secure systems to be built on top of the Haskell programming language. - Many researchers have done great work with Haskell, building such systems - as information flow control security systems, capability based security - system, languages for working with encrypted data... etc. These systems - all rely on properties of the Haskell language that aren't true in the - general case where uses of functions like - <emphasis>unsafePerformIO</emphasis> are allowed. Safe Haskell however - gives enough guarantees about the compiled Haskell code to be able to - successfully build secure systems on top of. - - As an example lets define an interface for a plugin system where the - plugin authors are untrusted, possibly malicious third-parties. We do - this by restricting the interface to pure functions or to a restricted IO - monad that we have defined that only allows a safe subset of IO actions - to be executed. We define the plugin interface here so that it requires - the plugin module, <emphasis>Danger</emphasis>, to export a single - computation, <emphasis>Danger.runMe</emphasis>, of type <emphasis>RIO - ()</emphasis>, where <emphasis>RIO</emphasis> is a new monad defined as - follows: - - <programlisting> - -- Either of the following pragmas would do - {-# LANGUAGE Trustworthy #-} - {-# LANGUAGE Safe #-} - - module RIO (RIO(), runRIO, rioReadFile, rioWriteFile) where - - -- Notice that symbol UnsafeRIO is not exported from this module! - - newtype RIO a = UnsafeRIO { runRIO :: IO a } - - instance Monad RIO where - return = UnsafeRIO . return - (UnsafeRIO m) >>= k = UnsafeRIO $ m >>= runRIO . k - - -- Returns True iff access is allowed to file name - pathOK :: FilePath -> IO Bool - pathOK file = {- Implement some policy based on file name -} - - rioReadFile :: FilePath -> RIO String - rioReadFile file = UnsafeRIO $ do - ok <- pathOK file - if ok then readFile file else return "" - - rioWriteFile :: FilePath -> String -> RIO () - rioWriteFile file contents = UnsafeRIO $ do - ok <- pathOK file - if ok then writeFile file contents else return () - </programlisting> - - We compile Danger using the -XSafe flag. Danger can import module RIO - because RIO is marked Trustworthy. Thus, Danger can make use of the - rioReadFile and rioWriteFile functions to access permitted file names. - - The main application then imports both RIO and Danger. To run the - plugin, it calls RIO.runRIO Danger.runMe within the IO monad. The - application is safe in the knowledge that the only IO to ensue will be - to files whose paths were approved by the pathOK test. We are relying on - the fact that the type system and constructor privacy prevent RIO - computations from executing IO actions directly. Only functions with - access to privileged symbol UnsafeRIO can lift IO computations into the - RIO monad. + To set a package's trust property in the package database please refer to + <xref linkend="packages"/>. </sect3> - <sect3> - <title>Uses of -XSafeImports</title> + <sect3 id="safe-no-trust"> + <title>Safe Imports without Trust</title> If you are writing a module and want to import a module from an untrusted author, then you would use the following syntax: @@ -460,28 +458,74 @@ As the safe import keyword is a feature of Safe Haskell and not Haskell98 this would fail though unless you enabled Safe imports through on the of the Safe Haskell language flags. Three flags enable safe imports, - <emphasis>-XSafe, -XTrustworthy</emphasis> and - <emphasis>-XSafeImports</emphasis>. However <emphasis>-XSafe and - -XTrustworthy</emphasis> do more then just enable the keyword which may - be undesirable. Using the <emphasis>-XSafeImports</emphasis> language flag - allows you to enable safe imports and nothing more. + <option>-XSafe, -XTrustworthy</option> and + <option>-XSafeImports</option>. However <option>-XSafe</option> and + <option>-XTrustworthy</option> do more then just enable the keyword which + may be undesirable. Using the <option>-XSafeImports</option> language + flag allows you to enable safe imports and nothing more. </sect3> + </sect2> + + <sect2 id="safe-flag-summary"> + <title>Safe Haskell Flag Summary</title> + + In summary, Safe Haskell consists of the following language flags: + + <variablelist> + <varlistentry> + <term>-XSafe</term> + <listitem>To be trusted, all of the module's direct imports must be + trusted, but the module itself need not reside in a trusted + package, because the compiler vouches for its trustworthiness. The + "safe" keyword is allowed but meaningless in import statements, + every import is required to be safe regardless. + <itemizedlist> + <listitem><emphasis>Module Trusted</emphasis> — Yes</listitem> + <listitem><emphasis>Haskell Language</emphasis> — Restricted to Safe + Language</listitem> + <listitem><emphasis>Imported Modules</emphasis> — All forced to be + safe imports, all must be trusted.</listitem> + </itemizedlist> + </listitem> + </varlistentry> + + <varlistentry> + <term>-XTrustworthy</term> + <listitem>This establishes that the module is trusted, but the + guarantee is provided by the module's author. A client of this + module then specifies that they trust the module author by + specifying they trust the package containing the module. + <option>-XTrustworthy</option> has no effect on the accepted range + of Haskell programs or their semantics, except that they allow the + safe import keyword. + <itemizedlist> + <listitem><emphasis>Module Trusted</emphasis> — Yes but only if the + package the module resides in is also trusted.</listitem> + <listitem><emphasis>Haskell Language</emphasis> — Unrestricted + </listitem> + <listitem><emphasis>Imported Modules</emphasis> — Under control of + module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + </varlistentry> + + <varlistentry> + <term>-XSafeImport</term> + <listitem>Enable the Safe Import extension so that a module can + require a dependency to be trusted without asserting any trust + about itself. + <itemizedlist> + <listitem><emphasis>Module Trusted</emphasis> — No</listitem> + <listitem><emphasis>Haskell Language</emphasis> — + Unrestricted</listitem> + <listitem><emphasis>Imported Modules</emphasis> — Under control of + module author which ones must be trusted.</listitem> + </itemizedlist> + </listitem> + </varlistentry> + + </variablelist> - <sect3> - <title>Uses of -XSafeLanguage</title> - - The <emphasis>-XSafeLanguage</emphasis> flag has two use cases. Firstly - as stated above it can be used to enforce good programming style. - Secondly, in the <emphasis>RIO</emphasis> restricted IO monad example - above there is no reason that it can't be implemented in the Safe - Language as its code isn't reliant on any unsafe features of Haskell. - However we may also wish to export the <emphasis>UnsafeRIO</emphasis> - action in the defining module or <emphasis>RIO</emphasis> and then define - a new module that only exports a safe subset of the original definition - of <emphasis>RIO</emphasis>. The defining module can use the - <emphasis>-XSafeLanguage</emphasis> flag and be assured that the - untrusted <emphasis>Danger</emphasis> module can't import it. - </sect3> </sect2> </sect1> diff --git a/docs/users_guide/ug-book.xml.in b/docs/users_guide/ug-book.xml.in index 8c1e1b162b..1ff487c2ed 100644 --- a/docs/users_guide/ug-book.xml.in +++ b/docs/users_guide/ug-book.xml.in @@ -16,6 +16,7 @@ &sooner; &lang-features; &ffi-chap; +&extending-ghc; &wrong; &utils; &win32-dll; diff --git a/docs/users_guide/ug-ent.xml.in b/docs/users_guide/ug-ent.xml.in index 2d19d97688..b550035952 100644 --- a/docs/users_guide/ug-ent.xml.in +++ b/docs/users_guide/ug-ent.xml.in @@ -3,7 +3,7 @@ <!ENTITY flags SYSTEM "flags.xml"> <!ENTITY license SYSTEM "license.xml"> <!ENTITY intro SYSTEM "intro.xml" > -<!ENTITY relnotes1 SYSTEM "7.0.1-notes.xml" > +<!-- <!ENTITY relnotes1 SYSTEM "7.0.1-notes.xml" > --> <!ENTITY using SYSTEM "using.xml" > <!ENTITY runtime SYSTEM "runtime_control.xml" > <!ENTITY prof SYSTEM "profiling.xml" > @@ -14,6 +14,7 @@ <!ENTITY packages SYSTEM "packages.xml" > <!ENTITY parallel SYSTEM "parallel.xml" > <!ENTITY safehaskell SYSTEM "safe_haskell.xml" > +<!ENTITY extending-ghc SYSTEM "extending_ghc.xml" > <!ENTITY phases SYSTEM "phases.xml" > <!ENTITY separate SYSTEM "separate_compilation.xml" > <!ENTITY bugs SYSTEM "bugs.xml" > @@ -297,12 +297,12 @@ INTREE_ONLY_PACKAGES := haskeline mtl terminfo utf8-string xhtml DPH_PACKAGES := dph/dph-base dph/dph-prim-interface dph/dph-prim-seq \ dph/dph-common dph/dph-prim-par dph/dph-par dph/dph-seq \ - vector primitive + vector primitive random # Packages that, if present, must be built by the stage2 compiler, # because they use TH and/or annotations, or depend on other stage2 # packages: -STAGE2_PACKAGES := $(DPH_PACKAGES) haskell98 haskell2010 random +STAGE2_PACKAGES := $(DPH_PACKAGES) haskell98 haskell2010 # Packages that we shouldn't build if we don't have TH (e.g. because # we're building a profiled compiler): TH_PACKAGES := $(DPH_PACKAGES) @@ -313,7 +313,7 @@ TH_PACKAGES := $(DPH_PACKAGES) # # We assume that the stage0 compiler has a suitable bytestring package, # so we don't have to include it below. -STAGE0_PACKAGES = Cabal hpc extensible-exceptions binary bin-package-db hoopl +PACKAGES_STAGE0 = Cabal/cabal hpc extensible-exceptions binary bin-package-db hoopl # These packages are installed, but are installed hidden # Why install them at all? Because the 'ghc' package depends on them @@ -330,8 +330,8 @@ HIDDEN_PACKAGES = binary # Packages to build # The lists of packages that we *actually* going to build in each stage: # -# $(STAGE0_PACKAGE) does double duty; it really is the list of packages -# we build the bootstrap compiler in stage 0 +# $(PACKAGES_STAGE0) does double duty; it really is the list of packages +# we build the bootstrap compiler in stage 0 # # $(PACKAGES) A list of directories relative to libraries/ containing # packages that will be built by stage1, in dependency @@ -386,14 +386,13 @@ $(eval $(call addPackage,old-time)) $(eval $(call addPackage,time)) $(eval $(call addPackage,directory)) $(eval $(call addPackage,process)) -$(eval $(call addPackage,random)) $(eval $(call addPackage,extensible-exceptions)) $(eval $(call addPackage,haskell98)) $(eval $(call addPackage,haskell2010)) $(eval $(call addPackage,hpc)) $(eval $(call addPackage,pretty)) $(eval $(call addPackage,template-haskell)) -$(eval $(call addPackage,Cabal)) +$(eval $(call addPackage,Cabal/cabal)) $(eval $(call addPackage,binary)) $(eval $(call addPackage,bin-package-db)) $(eval $(call addPackage,hoopl)) @@ -456,14 +455,17 @@ endif # -------------------------------- # Misc package-related settings -BOOT_PKG_CONSTRAINTS := $(foreach p,$(STAGE0_PACKAGES),--constraint "$p == $(shell grep -i "^Version:" libraries/$p/$p.cabal | sed "s/[^0-9.]//g")") +BOOT_PKG_CONSTRAINTS := \ + $(foreach d,$(PACKAGES_STAGE0),\ + $(foreach p,$(basename $(notdir $(wildcard libraries/$d/*.cabal))),\ + --constraint "$p == $(shell grep -i "^Version:" libraries/$d/$p.cabal | sed "s/[^0-9.]//g")")) # The actual .a and .so/.dll files: needed for dependencies. ALL_STAGE1_LIBS = $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_v_LIB)) ifeq "$(BuildSharedLibs)" "YES" ALL_STAGE1_LIBS += $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_dyn_LIB)) endif -BOOT_LIBS = $(foreach lib,$(STAGE0_PACKAGES),$(libraries/$(lib)_dist-boot_v_LIB)) +BOOT_LIBS = $(foreach lib,$(PACKAGES_STAGE0),$(libraries/$(lib)_dist-boot_v_LIB)) OTHER_LIBS = libffi/dist-install/build/libHSffi$(v_libsuf) libffi/dist-install/build/HSffi.o ifeq "$(BuildSharedLibs)" "YES" @@ -614,7 +616,10 @@ endif # ---------------------------------------------- # Actually include all the sub-ghc.mk's -include $(patsubst %, %/ghc.mk, $(BUILD_DIRS)) +# BUILD_DIRS_EXTRA needs to come after BUILD_DIRS, because stuff in +# libraries/dph/ghc.mk refers to stuff defined earlier, in particular +# things like $(libraries/dph/dph-base_dist-install_GHCI_LIB) +include $(patsubst %, %/ghc.mk, $(BUILD_DIRS) $(BUILD_DIRS_EXTRA)) # A useful pseudo-target (must be after the include above, because it needs # the value of things like $(libraries/base_dist-install_v_LIB). @@ -634,7 +639,7 @@ stage1_libs : $(ALL_STAGE1_LIBS) $(foreach pkg,$(PACKAGES) $(PACKAGES_STAGE2),$(eval libraries/$(pkg)_dist-install_HC_OPTS += $$(GhcLibHcOpts))) # Add $(GhcBootLibHcOpts) to all stage0 package builds -$(foreach pkg,$(STAGE0_PACKAGES),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$(GhcBootLibHcOpts))) +$(foreach pkg,$(PACKAGES_STAGE0),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$(GhcBootLibHcOpts))) # ----------------------------------------------- # Haddock-related bits @@ -642,7 +647,7 @@ $(foreach pkg,$(STAGE0_PACKAGES),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$ # Don't run Haddock for the package that will not be installed $(foreach p,$(INTREE_ONLY_PACKAGES),$(eval libraries/$p_dist-install_DO_HADDOCK = NO)) # We don't haddock the bootstrapping libraries -$(foreach p,$(STAGE0_PACKAGES),$(eval libraries/$p_dist-boot_DO_HADDOCK = NO)) +$(foreach p,$(PACKAGES_STAGE0),$(eval libraries/$p_dist-boot_DO_HADDOCK = NO)) # Build the Haddock contents and index ifeq "$(HADDOCK_DOCS)" "YES" @@ -672,24 +677,16 @@ endif $(eval $(call clean-target,$(BOOTSTRAPPING_CONF),,$(BOOTSTRAPPING_CONF))) -# These three libraries do not depend on each other, so we can build -# them straight off: - -$(eval $(call build-package,libraries/hpc,dist-boot,0)) -$(eval $(call build-package,libraries/extensible-exceptions,dist-boot,0)) -$(eval $(call build-package,libraries/Cabal,dist-boot,0)) -$(eval $(call build-package,libraries/binary,dist-boot,0)) -$(eval $(call build-package,libraries/bin-package-db,dist-boot,0)) -$(eval $(call build-package,libraries/hoopl,dist-boot,0)) - # register the boot packages in strict sequence, because running # multiple ghc-pkgs in parallel doesn't work (registrations may get # lost). fixed_pkg_prev= -$(foreach pkg,$(STAGE0_PACKAGES),$(eval $(call fixed_pkg_dep,$(pkg),dist-boot))) +$(foreach pkg,$(PACKAGES_STAGE0),$(eval $(call fixed_pkg_dep,$(pkg),dist-boot))) compiler/stage1/package-data.mk : $(fixed_pkg_prev) +endif +ifneq "$(BINDIST)" "YES" # Make sure we have all the GHCi libs by the time we've built # ghc-stage2. DPH includes a bit of Template Haskell which needs the # GHCI libs, and we don't have a better way to express that dependency. @@ -891,6 +888,12 @@ install_packages: libffi/package.conf.install rts/package.conf.install $(call make-command, \ "$(INSTALLED_GHC_PKG_REAL)" \ --global-conf "$(INSTALLED_PACKAGE_CONF)" hide $p)) +# when we install the packages above, ghc-pkg obeys umask when creating +# 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 @@ -1077,7 +1080,7 @@ sdist-prep : $(call sdist_file,compiler,stage2,parser,,Lexer,x) $(call sdist_file,compiler,stage2,parser,,Parser,y.pp) $(call sdist_file,compiler,stage2,parser,,ParserCore,y) - $(call sdist_file,utils/hpc,dist,,,HpcParser,y) + $(call sdist_file,utils/hpc,dist-install,,,HpcParser,y) $(call sdist_file,utils/genprimopcode,dist,,,Lexer,x) $(call sdist_file,utils/genprimopcode,dist,,,Parser,y) $(call sdist_file,utils/haddock,dist,src,Haddock,Lex,x) @@ -1136,7 +1139,7 @@ clean_files : .PHONY: clean_libraries clean_libraries: $(patsubst %,clean_libraries/%_dist-install,$(PACKAGES) $(PACKAGES_STAGE2)) -clean_libraries: $(patsubst %,clean_libraries/%_dist-boot,$(STAGE0_PACKAGES)) +clean_libraries: $(patsubst %,clean_libraries/%_dist-boot,$(PACKAGES_STAGE0)) clean_libraries: "$(RM)" $(RM_OPTS_REC) $(patsubst %, libraries/%/dist, $(PACKAGES) $(PACKAGES_STAGE2)) @@ -1145,6 +1148,8 @@ clean_libraries: # We have to define a clean target for each library manually, because the # libraries/*/ghc.mk files are not included when we're cleaning. ifeq "$(CLEANING)" "YES" +$(foreach lib,$(PACKAGES_STAGE0),\ + $(eval $(call clean-target,libraries/$(lib),dist-boot,libraries/$(lib)/dist-boot))) $(foreach lib,$(PACKAGES) $(PACKAGES_STAGE2),\ $(eval $(call clean-target,libraries/$(lib),dist-install,libraries/$(lib)/dist-install))) endif diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 1869040a80..50914945fa 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -426,7 +426,8 @@ runGHCi paths maybe_exprs = do getDirectory f = case takeDirectory f of "" -> "."; d -> d when (read_dot_files) $ do - mcfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] + ++ map (return . Just) opt_GhciScripts mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0) mapM_ sourceConfigFile $ nub $ catMaybes mcfgs -- nub, because we don't want to read .ghci twice if the @@ -896,6 +897,14 @@ noArgs :: GHCi () -> String -> GHCi () noArgs m "" = m noArgs _ _ = liftIO $ putStrLn "This command takes no arguments" +withSandboxOnly :: String -> GHCi () -> GHCi () +withSandboxOnly cmd this = do + dflags <- getDynFlags + if not (dopt Opt_GhciSandbox dflags) + then printForUser (text cmd <+> + ptext (sLit "is not supported with -fno-ghci-sandbox")) + else this + help :: String -> GHCi () help _ = liftIO (putStr helpText) @@ -1321,7 +1330,7 @@ runScript filename = do else return () ----------------------------------------------------------------------------- --- Displaying SafeHaskell properties of a module +-- Displaying Safe Haskell properties of a module isSafeCmd :: String -> InputT GHCi () isSafeCmd m = @@ -1600,16 +1609,28 @@ setCmd "" )) dflags <- getDynFlags liftIO $ putStrLn (showSDoc ( - vcat (text "GHCi-specific dynamic flag settings:" - :map (flagSetting dflags) ghciFlags) + text "GHCi-specific dynamic flag settings:" $$ + nest 2 (vcat (map (flagSetting dflags) ghciFlags)) + )) + liftIO $ putStrLn (showSDoc ( + text "other dynamic, non-language, flag settings:" $$ + nest 2 (vcat (map (flagSetting dflags) others)) )) liftIO $ putStrLn (showSDoc ( - vcat (text "other dynamic, non-language, flag settings:" - :map (flagSetting dflags) others) + text "warning settings:" $$ + nest 2 (vcat (map (warnSetting dflags) DynFlags.fWarningFlags)) )) + where flagSetting dflags (str, _, f, _) - | dopt f dflags = text " " <> text "-f" <> text str - | otherwise = text " " <> text "-fno-" <> text str + | dopt f dflags = fstr str + | otherwise = fnostr str + warnSetting dflags (str, _, f, _) + | wopt f dflags = fstr str + | otherwise = fnostr str + + fstr str = text "-f" <> text str + fnostr str = text "-fno-" <> text str + (ghciFlags,others) = partition (\(_, _, f, _) -> f `elem` flags) DynFlags.fFlags flags = [Opt_PrintExplicitForalls @@ -2085,32 +2106,37 @@ pprintCommand bind force str = do pprintClosureCommand bind force str stepCmd :: String -> GHCi () -stepCmd [] = doContinue (const True) GHC.SingleStep -stepCmd expression = runStmt expression GHC.SingleStep >> return () +stepCmd arg = withSandboxOnly ":step" $ step arg + where + step [] = doContinue (const True) GHC.SingleStep + step expression = runStmt expression GHC.SingleStep >> return () stepLocalCmd :: String -> GHCi () -stepLocalCmd [] = do - mb_span <- getCurrentBreakSpan - case mb_span of - Nothing -> stepCmd [] - Just loc -> do - Just mod <- getCurrentBreakModule - current_toplevel_decl <- enclosingTickSpan mod loc - doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep - -stepLocalCmd expression = stepCmd expression +stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg + where + step expr + | not (null expr) = stepCmd expr + | otherwise = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just loc -> do + Just mod <- getCurrentBreakModule + current_toplevel_decl <- enclosingTickSpan mod loc + doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep stepModuleCmd :: String -> GHCi () -stepModuleCmd [] = do - mb_span <- getCurrentBreakSpan - case mb_span of - Nothing -> stepCmd [] - Just _ -> do - Just span <- getCurrentBreakSpan - let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span - doContinue f GHC.SingleStep - -stepModuleCmd expression = stepCmd expression +stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg + where + step expr + | not (null expr) = stepCmd expr + | otherwise = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just span -> do + let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span + doContinue f GHC.SingleStep -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan @@ -2126,11 +2152,14 @@ enclosingTickSpan mod (RealSrcSpan src) = do return . head . sortBy leftmost_largest $ enclosing_spans traceCmd :: String -> GHCi () -traceCmd [] = doContinue (const True) GHC.RunAndLogSteps -traceCmd expression = runStmt expression GHC.RunAndLogSteps >> return () +traceCmd arg + = withSandboxOnly ":trace" $ trace arg + where + trace [] = doContinue (const True) GHC.RunAndLogSteps + trace expression = runStmt expression GHC.RunAndLogSteps >> return () continueCmd :: String -> GHCi () -continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion +continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () @@ -2140,12 +2169,12 @@ doContinue pred step = do return () abandonCmd :: String -> GHCi () -abandonCmd = noArgs $ do +abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do b <- GHC.abandon -- the prompt will change to indicate the new context when (not b) $ liftIO $ putStrLn "There is no computation running." deleteCmd :: String -> GHCi () -deleteCmd argLine = do +deleteCmd argLine = withSandboxOnly ":delete" $ do deleteSwitch $ words argLine where deleteSwitch :: [String] -> GHCi () @@ -2193,7 +2222,7 @@ bold c | do_bold = text start_bold <> c <> text end_bold | otherwise = c backCmd :: String -> GHCi () -backCmd = noArgs $ do +backCmd = noArgs $ withSandboxOnly ":back" $ do (names, _, span) <- GHC.back printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span printTypeOfNames names @@ -2202,7 +2231,7 @@ backCmd = noArgs $ do enqueueCommands [stop st] forwardCmd :: String -> GHCi () -forwardCmd = noArgs $ do +forwardCmd = noArgs $ withSandboxOnly ":forward" $ do (names, ix, span) <- GHC.forward printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") @@ -2214,8 +2243,7 @@ forwardCmd = noArgs $ do -- handle the "break" command breakCmd :: String -> GHCi () -breakCmd argLine = do - breakSwitch $ words argLine +breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine breakSwitch :: [String] -> GHCi () breakSwitch [] = do diff --git a/ghc/Main.hs b/ghc/Main.hs index 71a45f8a9a..8b7597cddf 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -78,8 +78,7 @@ import Data.Maybe main :: IO () main = do hSetBuffering stdout NoBuffering - let defaultErrorHandlerDynFlags = defaultDynFlags (panic "No settings") - GHC.defaultErrorHandler defaultErrorHandlerDynFlags $ do + GHC.defaultErrorHandler defaultLogAction $ do -- 1. extract the -B flag from the args argv0 <- getArgs @@ -763,6 +762,9 @@ abiHash strs = do ifaces <- initIfaceCheck hsc_env $ mapM get_iface mods bh <- openBinMem (3*1024) -- just less than a block + put_ bh opt_HiVersion + -- package hashes change when the compiler version changes (for now) + -- see #5328 mapM_ (put_ bh . mi_mod_hash) ifaces f <- fingerprintBinMem bh diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 61b7b340ac..ba17150e9a 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -29,7 +29,7 @@ Executable ghc array >= 0.1 && < 0.4, bytestring >= 0.9 && < 0.10, directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, filepath >= 1 && < 1.3, ghc if os(windows) diff --git a/ghc/ghc.mk b/ghc/ghc.mk index da9fd8a293..d270a7ad9d 100644 --- a/ghc/ghc.mk +++ b/ghc/ghc.mk @@ -94,6 +94,7 @@ $(eval $(call build-prog,ghc,stage3,2)) ifneq "$(BINDIST)" "YES" +ghc/stage1/build/tmp/$(ghc_stage1_PROG) : $(BOOT_LIBS) ifeq "$(GhcProfiled)" "YES" ghc/stage2/build/tmp/$(ghc_stage2_PROG) : $(compiler_stage2_p_LIB) ghc/stage2/build/tmp/$(ghc_stage2_PROG) : $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_p_LIB)) diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h index 1bbb2f0074..925aec4ed1 100644 --- a/includes/rts/EventLogFormat.h +++ b/includes/rts/EventLogFormat.h @@ -104,8 +104,7 @@ #define EVENT_STOP_THREAD 2 /* (thread, status, blockinfo) */ #define EVENT_THREAD_RUNNABLE 3 /* (thread) */ #define EVENT_MIGRATE_THREAD 4 /* (thread, new_cap) */ -#define EVENT_RUN_SPARK 5 /* (thread) */ -#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */ +/* 5, 6 deprecated */ #define EVENT_SHUTDOWN 7 /* () */ #define EVENT_THREAD_WAKEUP 8 /* (thread, other_cap) */ #define EVENT_GC_START 9 /* () */ @@ -133,22 +132,36 @@ #define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */ #define EVENT_OSPROCESS_PID 32 /* (capset, pid) */ #define EVENT_OSPROCESS_PPID 33 /* (capset, parent_pid) */ +#define EVENT_SPARK_COUNTERS 34 /* (crt,dud,ovf,cnv,fiz,gcd,rem) */ +#define EVENT_SPARK_CREATE 35 /* () */ +#define EVENT_SPARK_DUD 36 /* () */ +#define EVENT_SPARK_OVERFLOW 37 /* () */ +#define EVENT_SPARK_RUN 38 /* () */ +#define EVENT_SPARK_STEAL 39 /* (victim_cap) */ +#define EVENT_SPARK_FIZZLE 40 /* () */ +#define EVENT_SPARK_GC 41 /* () */ +#define EVENT_INTERN_STRING 42 /* (string, id) {not used by ghc} */ -/* Range 34 - 59 is available for new events */ +/* Range 43 - 59 is available for new GHC and common events */ /* Range 60 - 80 is used by eden for parallel tracing * see http://www.mathematik.uni-marburg.de/~eden/ */ +/* Range 100 - 139 is reserved for Mercury */ + /* * The highest event code +1 that ghc itself emits. Note that some event * ranges higher than this are reserved but not currently emitted by ghc. * This must match the size of the EventDesc[] array in EventLog.c */ -#define NUM_EVENT_TAGS 34 +#define NUM_GHC_EVENT_TAGS 42 #if 0 /* DEPRECATED EVENTS: */ +/* we don't actually need to record the thread, it's implicit */ +#define EVENT_RUN_SPARK 5 /* (thread) */ +#define EVENT_STEAL_SPARK 6 /* (thread, victim_cap) */ /* ghc changed how it handles sparks so these are no longer applicable */ #define EVENT_CREATE_SPARK 13 /* (cap, thread) */ #define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */ diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h index 42ca671768..46f1eb893b 100644 --- a/includes/rts/Flags.h +++ b/includes/rts/Flags.h @@ -127,8 +127,10 @@ struct PROFILING_FLAGS { struct TRACE_FLAGS { int tracing; rtsBool timestamp; /* show timestamp in stderr output */ - rtsBool scheduler; /* trace scheduler events */ + rtsBool gc; /* trace GC events */ + rtsBool sparks_sampled; /* trace spark events by a sampled method */ + rtsBool sparks_full; /* trace spark events 100% accurately */ }; struct CONCURRENT_FLAGS { diff --git a/includes/rts/Globals.h b/includes/rts/Globals.h index 218b7ef155..9a2fbd0dd4 100644 --- a/includes/rts/Globals.h +++ b/includes/rts/Globals.h @@ -17,7 +17,6 @@ #ifndef RTS_GLOBALS_H #define RTS_GLOBALS_H -StgStablePtr getOrSetTypeableStore(StgStablePtr value); StgStablePtr getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr value); StgStablePtr getOrSetGHCConcWindowsPendingDelaysStore(StgStablePtr ptr); StgStablePtr getOrSetGHCConcWindowsIOManagerThreadStore(StgStablePtr ptr); diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index 73517f9ebc..122f446227 100644 --- a/includes/rts/storage/ClosureMacros.h +++ b/includes/rts/storage/ClosureMacros.h @@ -452,10 +452,10 @@ INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, lnat n) In multicore mode, we *cannot* overwrite slop with zeroes, because another thread might be reading it. So, - PROFILING is not compatible with +RTS -N<n> (for n > 1) + LDV PROFILING is not compatible with +RTS -N<n> (for n > 1) THREADED_RTS can be used with DEBUG, but full heap sanity - checking is disabled. + checking is disabled except after major GC. -------------------------------------------------------------------------- */ diff --git a/includes/stg/SMP.h b/includes/stg/SMP.h index 52fd6f1bc6..87ec4fb242 100644 --- a/includes/stg/SMP.h +++ b/includes/stg/SMP.h @@ -83,7 +83,7 @@ EXTERN_INLINE void busy_wait_nop(void); * http://gee.cs.oswego.edu/dl/jmm/cookbook.html * * To check whether you got these right, try the test in - * testsuite/tests/ghc-regress/rts/testwsdeque.c + * testsuite/tests/rts/testwsdeque.c * This tests the work-stealing deque implementation, which relies on * properly working store_load and load_load memory barriers. */ diff --git a/libraries/bin-package-db/bin-package-db.cabal b/libraries/bin-package-db/bin-package-db.cabal index b8b1f65094..697b954f30 100644 --- a/libraries/bin-package-db/bin-package-db.cabal +++ b/libraries/bin-package-db/bin-package-db.cabal @@ -25,7 +25,7 @@ Library { build-depends: base >= 4 && < 5 build-depends: binary == 0.5.*, - Cabal >= 1.8 && < 1.12 + Cabal >= 1.8 && < 1.14 extensions: CPP } diff --git a/mk/build.mk.sample b/mk/build.mk.sample index a31b57618b..0d10ae8121 100644 --- a/mk/build.mk.sample +++ b/mk/build.mk.sample @@ -27,6 +27,9 @@ # A development build, working on the stage 2 compiler: #BuildFlavour = devel2 +# An unregisterised, optimised build of ghc, for porting: +#BuildFlavour = unreg + GhcLibWays = v # -------- 1. A Performance/Distribution build-------------------------------- @@ -133,6 +136,26 @@ BUILD_DOCBOOK_PDF = NO endif +# -------- A Unregisterised build) ------------------------------------------- + +ifeq "$(BuildFlavour)" "unreg" + +GhcUnregisterised = YES +GhcWithNativeCodeGen = NO + +SRC_HC_OPTS = -O -H64m +GhcStage1HcOpts = -O +GhcStage2HcOpts = -O2 +GhcHcOpts = -Rghc-timing +GhcLibHcOpts = -O2 +SplitObjs = NO +HADDOCK_DOCS = NO +BUILD_DOCBOOK_HTML = NO +BUILD_DOCBOOK_PS = NO +BUILD_DOCBOOK_PDF = NO + +endif + # ----------------------------------------------------------------------------- # Other settings that might be useful diff --git a/mk/config.mk.in b/mk/config.mk.in index 18e60e793b..e39c5c7381 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -417,9 +417,6 @@ SRC_HC_OPTS += -H32m -O # These flags make flex 8-bit SRC_FLEX_OPTS += -8 -# Default fptools options for dllwrap. -SRC_BLD_DLL_OPTS += --target=i386-mingw32 - # Flags for CPP when running GreenCard on .pgc files GC_CPP_OPTS += -P -E -x c -traditional -D__GLASGOW_HASKELL__ @@ -538,6 +535,7 @@ endif WhatGccIsCalled = @WhatGccIsCalled@ GccVersion = @GccVersion@ GccLT34 = @GccLT34@ +GccLT46 = @GccLT46@ CC = $(WhatGccIsCalled) CC_STAGE0 = @CC_STAGE0@ CC_STAGE1 = $(CC) @@ -742,8 +740,6 @@ XSLTPROC_LABEL_OPTS = --stringparam toc.section.depth 3 \ #----------------------------------------------------------------------------- # FPtools support software -BLD_DLL = dllwrap - # # ghc-pkg # diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 184dfe2ff7..f4c5162607 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -4,7 +4,16 @@ WERROR = -Werror HADDOCK_DOCS = YES + SRC_CC_OPTS += -Wall $(WERROR) +# Debian doesn't turn -Werror=unused-but-set-variable on by default, so +# we turn it on explicitly for consistency with other users +ifeq "$(GccLT46)" "NO" +SRC_CC_OPTS += -Werror=unused-but-set-variable +# gcc 4.6 gives 3 warning for giveCapabilityToTask not being inlined +SRC_CC_OPTS += -Wno-error=inline +endif + SRC_HC_OPTS += -Wall $(WERROR) -H64m -O0 # Safe by default @@ -45,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 @@ -52,7 +66,9 @@ libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-incomplete-patterns libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-identities # Temporarily turn off unused-do-bind warnings for the time package -libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind +# Temporary: mkTyCon is deprecated +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-deprecations # On Windows, there are also some unused import warnings libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports -fno-warn-identities @@ -64,7 +64,6 @@ libraries/old-locale - packages/old-locale.git libraries/old-time - packages/old-time.git git libraries/pretty - packages/pretty.git git libraries/process - packages/process.git git -libraries/random - packages/random.git git libraries/template-haskell - packages/template-haskell.git git libraries/terminfo - packages/terminfo.git git libraries/unix - packages/unix.git git @@ -76,6 +75,7 @@ nofib nofib nofib.git libraries/deepseq extra packages/deepseq.git git libraries/parallel extra packages/parallel.git git libraries/stm extra packages/stm.git git +libraries/random dph packages/random.git git libraries/primitive dph packages/primitive.git git libraries/vector dph packages/vector.git git libraries/dph dph packages/dph.git git diff --git a/quickcheck/HeaderInfoTests.hs b/quickcheck/HeaderInfoTests.hs deleted file mode 100644 index 6f8bef6239..0000000000 --- a/quickcheck/HeaderInfoTests.hs +++ /dev/null @@ -1,129 +0,0 @@ -module HeaderInfoTests - ( prop_optionsIdentity - , prop_languageParse - , prop_languageError - ) where - -import Test.QuickCheck -import Test.QuickCheck.Batch -import Data.Char - -import Control.Monad -import System.IO.Unsafe - -import HeaderInfo -import StringBuffer -import SrcLoc - -import Language.Haskell.Extension - -newtype CmdOptions = CmdOptions {cmdOptions :: [String]} - deriving Show - -instance Arbitrary CmdOptions where - arbitrary = resize 30 $ liftM CmdOptions arbitrary - coarbitrary = undefined - -instance Arbitrary Char where - arbitrary = elements $ ['a'..'z']++['A'..'Z'] - coarbitrary = undefined - -data Options = Options - | Options_GHC - deriving Show - -instance Arbitrary Options where - arbitrary = elements [Options,Options_GHC] - coarbitrary = undefined - --- Test that OPTIONS are correctly extracted from a buffer --- with comments and garbage. -prop_optionsIdentity lowercase options cmds - = not (null cmds) ==> - all (all (not.null).cmdOptions) cmds ==> - concatMap cmdOptions cmds == map unLoc (getOptions buffer "somefile") - where buffer = unsafePerformIO $ stringToStringBuffer str - str = concatMap mkPragma cmds ++ - "\n @#@# garbage #@#@ \n" - mkPragma (CmdOptions cmd) - = unlines [ "-- Pragma: " - , unwords $ ["{-#", pragma]++cmd++["#-}"] - , "{- End of pragma -}" ] - pragma = (if lowercase then map toLower else map toUpper) $ - case options of - Options -> "OPTIONS" - Options_GHC -> "OPTIONS_GHC" - -newtype Extensions = Extensions [Extension] - deriving Show - -instance Arbitrary Extensions where - arbitrary = resize 30 $ liftM Extensions arbitrary - coarbitrary = undefined - -extensions :: [Extension] -extensions = [ OverlappingInstances - , UndecidableInstances - , IncoherentInstances - , RecursiveDo - , ParallelListComp - , MultiParamTypeClasses - , NoMonomorphismRestriction - , FunctionalDependencies - , Rank2Types - , RankNTypes - , PolymorphicComponents - , ExistentialQuantification - , ScopedTypeVariables - , ImplicitParams - , FlexibleContexts - , FlexibleInstances - , EmptyDataDecls - , CPP - , TypeSynonymInstances - , TemplateHaskell - , ForeignFunctionInterface - , InlinePhase - , ContextStack - , Arrows - , Generics - , NoImplicitPrelude - , NamedFieldPuns - , PatternGuards - , GeneralizedNewtypeDeriving - , ExtensibleRecords - , RestrictedTypeSynonyms - , HereDocuments ] - --- derive Enum for Extension? -instance Arbitrary Extension where - arbitrary = elements extensions - coarbitrary = undefined - --- Test that we can parse all known extensions. -prop_languageParse lowercase (Extensions exts) - = not (null exts) ==> - not (isBottom (getOptions buffer "somefile")) - where buffer = unsafePerformIO $ stringToStringBuffer str - str = unlines [ "-- Pragma: " - , unwords $ ["{-#", pragma, ppExts exts "" , "#-}"] - , "{- End of pragma -}" - , "garbage#@$#$" ] - ppExts [e] = shows e - ppExts (x:xs) = shows x . showChar ',' . ppExts xs - ppExts [] = id - pragma = (if lowercase then map toLower else map toUpper) - "LANGUAGE" - --- Test that invalid extensions cause exceptions. -prop_languageError lowercase ext - = not (null ext) ==> - ext `notElem` map show extensions ==> - isBottom (foldr seq () (getOptions buffer "somefile")) - where buffer = unsafePerformIO $ stringToStringBuffer str - str = unlines [ "-- Pragma: " - , unwords $ ["{-#", pragma, ext , "#-}"] - , "{- End of pragma -}" - , "garbage#@$#$" ] - pragma = (if lowercase then map toLower else map toUpper) - "LANGUAGE" diff --git a/quickcheck/README b/quickcheck/README deleted file mode 100644 index 251bc807e0..0000000000 --- a/quickcheck/README +++ /dev/null @@ -1,9 +0,0 @@ -QuickCheck for the GHC library. - -Requirements: - stage2 of ghc. - -Usage: - ./run.sh - ./run.sh debug # runs quickCheck in debug mode. - ./run.sh ghci [file] # loads [file] with the stage2 compiler. diff --git a/quickcheck/RunTests.hs b/quickcheck/RunTests.hs deleted file mode 100644 index 4aabb48584..0000000000 --- a/quickcheck/RunTests.hs +++ /dev/null @@ -1,62 +0,0 @@ -module RunTests where - -import Test.QuickCheck.Batch hiding (runTests) -import System.Exit -import System.Environment - -import HeaderInfoTests as HI - -runUnitTests :: Bool -> IO () -runUnitTests debug = exitWith =<< performTests debug - -performTests :: Bool -> IO ExitCode -performTests debug = - do e1 <- exeTests "HeaderInfo" opts - [ run HI.prop_optionsIdentity - , run HI.prop_languageParse - , run HI.prop_languageError ] - return (foldr1 cat [e1]) - where opts = TestOptions 100 10 debug - cat (e@(ExitFailure _)) _ = e - cat _ e = e - -exeTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ExitCode -exeTests name scale actions = - do putStr (rjustify 25 name ++ " : ") - tr 1 actions [] 0 False - where - rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s - tr n [] xs c e = do - putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n") - mapM_ fa xs - if e - then return (ExitFailure 1) - else return ExitSuccess - tr n (action:actions) others c e = - do r <- action scale - case r of - (TestOk _ m _) - -> do { putStr "." ; - tr (n+1) actions others (c+m) e } - (TestExausted s m ss) - -> do { putStr "?" ; - tr (n+1) actions others (c+m) e } - (TestAborted e) - -> do { print e; - putStr "*" ; - tr (n+1) actions others c True } - (TestFailed f num) - -> do { putStr "#" ; - tr (n+1) actions ((f,n,num):others) (c+num) True } - fa :: ([String],Int,Int) -> IO () - fa (f,n,no) = - do putStr "\n" - putStr (" ** test " - ++ show (n :: Int) - ++ " of " - ++ name - ++ " failed with the binding(s)\n") - sequence_ [putStr (" ** " ++ v ++ "\n") - | v <- f ] - putStr "\n" - diff --git a/quickcheck/run.sh b/quickcheck/run.sh deleted file mode 100644 index cff728abee..0000000000 --- a/quickcheck/run.sh +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/sh - -# I suck at bash scripting. Please feel free to make this code better. - -Root=../compiler - -ExtraOptions="-cpp -fglasgow-exts -package ghc" - -HC=$Root/stage2/ghc-inplace - -Debug="False" - -if [ "$1" == "debug" ] - then - Debug="True" -fi - -if [ "$1" == "ghci" ] - then - $HC --interactive $ExtraOptions $2 - else - $HC --interactive -e "runUnitTests $Debug" $ExtraOptions RunTests.hs -fi
\ No newline at end of file diff --git a/rts/Adjustor.c b/rts/Adjustor.c index 607c0b8abe..0f038c4396 100644 --- a/rts/Adjustor.c +++ b/rts/Adjustor.c @@ -47,7 +47,7 @@ Haskell side. #include <string.h> #endif -#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) extern void adjustorCode(void); #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) // from AdjustorAsm.s @@ -152,7 +152,8 @@ createAdjustor (int cconv, #else #define UNDERSCORE "" #endif -#if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS) + +#if defined(x86_64_HOST_ARCH) /* Now here's something obscure for you: @@ -170,20 +171,6 @@ createAdjustor (int cconv, returning in some static piece of memory and arrange to return to it before tail jumping from the adjustor thunk. */ -static void GNUC3_ATTRIBUTE(used) obscure_ccall_wrapper(void) -{ - __asm__ ( - ".globl " UNDERSCORE "obscure_ccall_ret_code\n" - UNDERSCORE "obscure_ccall_ret_code:\n\t" - "addl $0x4, %esp\n\t" - "ret" - ); -} -extern void obscure_ccall_ret_code(void); - -#endif - -#if defined(x86_64_HOST_ARCH) static void GNUC3_ATTRIBUTE(used) obscure_ccall_wrapper(void) { __asm__ ( @@ -288,7 +275,7 @@ typedef struct AdjustorStub { #endif #endif -#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) /* !!! !!! WARNING: !!! !!! * This structure is accessed from AdjustorAsm.s @@ -304,7 +291,7 @@ typedef struct AdjustorStub { } AdjustorStub; #endif -#if (defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) +#if defined(i386_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) static int totalArgumentSize(char *typeString) { int sz = 0; @@ -380,54 +367,14 @@ createAdjustor(int cconv, StgStablePtr hptr, break; case 1: /* _ccall */ -#if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS) - /* Magic constant computed by inspecting the code length of - the following assembly language snippet - (offset and machine code prefixed): - - <00>: 68 ef be ad de pushl $0xdeadbeef # constant is large enough to - # hold a StgStablePtr - <05>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr - <0a>: 68 ef be ad de pushl $obscure_ccall_ret_code # push the return address - <0f>: ff e0 jmp *%eax # jump to wptr - - The ccall'ing version is a tad different, passing in the return - address of the caller to the auto-generated C stub (which enters - via the stable pointer.) (The auto-generated C stub is in on this - game, don't worry :-) - - See the comment next to obscure_ccall_ret_code why we need to - perform a tail jump instead of a call, followed by some C stack - fixup. - - Note: The adjustor makes the assumption that any return value - coming back from the C stub is not stored on the stack. - That's (thankfully) the case here with the restricted set of - return types that we support. - */ - adjustor = allocateExec(17,&code); - { - unsigned char *const adj_code = (unsigned char *)adjustor; - - adj_code[0x00] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */ - *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr; - - adj_code[0x05] = (unsigned char)0xb8; /* movl $wptr, %eax */ - *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr; - - adj_code[0x0a] = (unsigned char)0x68; /* pushl obscure_ccall_ret_code */ - *((StgFunPtr*)(adj_code + 0x0b)) = - (StgFunPtr)obscure_ccall_ret_code; - - adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */ - adj_code[0x10] = (unsigned char)0xe0; - } -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) { /* - What's special about Darwin/Mac OS X on i386? - It wants the stack to stay 16-byte aligned. - + Most of the trickiness here is due to the need to keep the + stack pointer 16-byte aligned (see #5250). That means we + can't just push another argument on the stack and call the + wrapper, we may have to shuffle the whole argument block. + We offload most of the work to AdjustorAsm.S. */ AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub),&code); @@ -1107,25 +1054,17 @@ TODO: Depending on how much allocation overhead stgMallocBytes uses for void freeHaskellFunctionPtr(void* ptr) { -#if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS) - if ( *(unsigned char*)ptr != 0x68 && +#if defined(i386_HOST_ARCH) + if ( *(unsigned char*)ptr != 0xe8 && *(unsigned char*)ptr != 0x58 ) { errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr); return; } - - /* Free the stable pointer first..*/ - if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */ - freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01))); + if (*(unsigned char*)ptr == 0xe8) { /* Aha, a ccall adjustor! */ + freeStablePtr(((AdjustorStub*)ptr)->hptr); } else { freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02))); } -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) -if ( *(unsigned char*)ptr != 0xe8 ) { - errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr); - return; - } - freeStablePtr(((AdjustorStub*)ptr)->hptr); #elif defined(x86_64_HOST_ARCH) if ( *(StgWord16 *)ptr == 0x894d ) { freeStablePtr(*(StgStablePtr*)((StgWord8*)ptr+0x20)); diff --git a/rts/AdjustorAsm.S b/rts/AdjustorAsm.S index cfdef68349..75b83f6947 100644 --- a/rts/AdjustorAsm.S +++ b/rts/AdjustorAsm.S @@ -147,7 +147,7 @@ adjustorCode: /* ********************************* i386 ********************************** */ -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#elif defined(i386_HOST_ARCH) #define WS 4 #define RETVAL_OFF 5 @@ -158,8 +158,13 @@ adjustorCode: #define FRAMESIZE_OFF (HEADER_BYTES + 2*WS) #define ARGWORDS_OFF (HEADER_BYTES + 3*WS) +#ifdef LEADING_UNDERSCORE .globl _adjustorCode _adjustorCode: +#else + .globl adjustorCode +adjustorCode: +#endif popl %eax subl $RETVAL_OFF, %eax diff --git a/rts/Capability.c b/rts/Capability.c index fe5dbdca40..91c5e2d98e 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -92,12 +92,17 @@ findSpark (Capability *cap) // spark = reclaimSpark(cap->sparks); // However, measurements show that this makes at least one benchmark // slower (prsa) and doesn't affect the others. - spark = tryStealSpark(cap); + spark = tryStealSpark(cap->sparks); + while (spark != NULL && fizzledSpark(spark)) { + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); + spark = tryStealSpark(cap->sparks); + } if (spark != NULL) { - cap->sparks_converted++; + cap->spark_stats.converted++; // Post event for running a spark from capability's own pool. - traceEventRunSpark(cap, cap->r.rCurrentTSO); + traceEventSparkRun(cap); return spark; } @@ -121,7 +126,12 @@ findSpark (Capability *cap) if (emptySparkPoolCap(robbed)) // nothing to steal here continue; - spark = tryStealSpark(robbed); + spark = tryStealSpark(robbed->sparks); + while (spark != NULL && fizzledSpark(spark)) { + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); + spark = tryStealSpark(robbed->sparks); + } if (spark == NULL && !emptySparkPoolCap(robbed)) { // we conflicted with another thread while trying to steal; // try again later. @@ -129,9 +139,8 @@ findSpark (Capability *cap) } if (spark != NULL) { - cap->sparks_converted++; - - traceEventStealSpark(cap, cap->r.rCurrentTSO, robbed->no); + cap->spark_stats.converted++; + traceEventSparkSteal(cap, robbed->no); return spark; } @@ -224,11 +233,13 @@ initCapability( Capability *cap, nat i ) cap->returning_tasks_hd = NULL; cap->returning_tasks_tl = NULL; cap->inbox = (Message*)END_TSO_QUEUE; - cap->sparks_created = 0; - cap->sparks_dud = 0; - cap->sparks_converted = 0; - cap->sparks_gcd = 0; - cap->sparks_fizzled = 0; + cap->sparks = allocSparkPool(); + cap->spark_stats.created = 0; + cap->spark_stats.dud = 0; + cap->spark_stats.overflowed = 0; + cap->spark_stats.converted = 0; + cap->spark_stats.gcd = 0; + cap->spark_stats.fizzled = 0; #endif cap->f.stgEagerBlackholeInfo = (W_)&__stg_EAGER_BLACKHOLE_info; @@ -255,6 +266,9 @@ initCapability( Capability *cap, nat i ) cap->pinned_object_block = NULL; traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i); +#if defined(THREADED_RTS) + traceSparkCounters(cap); +#endif } /* --------------------------------------------------------------------------- @@ -608,6 +622,7 @@ yieldCapability (Capability** pCap, Task *task) traceEventGcStart(cap); gcWorkerThread(cap); traceEventGcEnd(cap); + traceSparkCounters(cap); return; } @@ -819,7 +834,9 @@ shutdownCapability (Capability *cap, // threads performing foreign calls that will eventually try to // return via resumeThread() and attempt to grab cap->lock. // closeMutex(&cap->lock); - + + traceSparkCounters(cap); + #endif /* THREADED_RTS */ traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, cap->no); @@ -834,6 +851,10 @@ shutdownCapabilities(Task *task, rtsBool safe) shutdownCapability(&capabilities[i], task, safe); } traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT); + +#if defined(THREADED_RTS) + ASSERT(checkSparkCountInvariant()); +#endif } static void @@ -904,3 +925,34 @@ markCapabilities (evac_fn evac, void *user) markCapability(evac, user, &capabilities[n], rtsFalse); } } + +#if defined(THREADED_RTS) +rtsBool checkSparkCountInvariant (void) +{ + SparkCounters sparks = { 0, 0, 0, 0, 0, 0 }; + StgWord64 remaining = 0; + nat i; + + for (i = 0; i < n_capabilities; i++) { + sparks.created += capabilities[i].spark_stats.created; + sparks.dud += capabilities[i].spark_stats.dud; + sparks.overflowed+= capabilities[i].spark_stats.overflowed; + sparks.converted += capabilities[i].spark_stats.converted; + sparks.gcd += capabilities[i].spark_stats.gcd; + sparks.fizzled += capabilities[i].spark_stats.fizzled; + remaining += sparkPoolSize(capabilities[i].sparks); + } + + /* The invariant is + * created = converted + remaining + gcd + fizzled + */ + debugTrace(DEBUG_sparks,"spark invariant: %ld == %ld + %ld + %ld + %ld " + "(created == converted + remaining + gcd + fizzled)", + sparks.created, sparks.converted, remaining, + sparks.gcd, sparks.fizzled); + + return (sparks.created == + sparks.converted + remaining + sparks.gcd + sparks.fizzled); + +} +#endif diff --git a/rts/Capability.h b/rts/Capability.h index d380af9cff..10c7c496e4 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -98,11 +98,7 @@ struct Capability_ { SparkPool *sparks; // Stats on spark creation/conversion - nat sparks_created; - nat sparks_dud; - nat sparks_converted; - nat sparks_gcd; - nat sparks_fizzled; + SparkCounters spark_stats; #endif // Per-capability STM-related data @@ -143,6 +139,10 @@ struct Capability_ { ASSERT(myTask() == task); \ ASSERT_TASK_ID(task); +#if defined(THREADED_RTS) +rtsBool checkSparkCountInvariant (void); +#endif + // Converts a *StgRegTable into a *Capability. // INLINE_HEADER Capability * diff --git a/rts/Globals.c b/rts/Globals.c index 7b8967f685..06b2f9721f 100644 --- a/rts/Globals.c +++ b/rts/Globals.c @@ -19,7 +19,6 @@ #include "Stable.h" typedef enum { - TypeableStore, GHCConcSignalSignalHandlerStore, GHCConcWindowsPendingDelaysStore, GHCConcWindowsIOManagerThreadStore, @@ -80,13 +79,6 @@ static StgStablePtr getOrSetKey(StoreKey key, StgStablePtr ptr) return ret; } - -StgStablePtr -getOrSetTypeableStore(StgStablePtr ptr) -{ - return getOrSetKey(TypeableStore,ptr); -} - StgStablePtr getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr ptr) { diff --git a/rts/Interpreter.c b/rts/Interpreter.c index ade4ad18ed..37e0e051c4 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -49,13 +49,21 @@ /* Sp points to the lowest live word on the stack. */ -#define BCO_NEXT instrs[bciPtr++] -#define BCO_NEXT_32 (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1])) -#define BCO_NEXT_64 (bciPtr += 4, (((StgWord) instrs[bciPtr-4]) << 48) + (((StgWord) instrs[bciPtr-3]) << 32) + (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1])) +#define BCO_NEXT instrs[bciPtr++] +#define BCO_NEXT_32 (bciPtr += 2) +#define BCO_READ_NEXT_32 (BCO_NEXT_32, (((StgWord) instrs[bciPtr-2]) << 16) \ + + ( (StgWord) instrs[bciPtr-1])) +#define BCO_NEXT_64 (bciPtr += 4) +#define BCO_READ_NEXT_64 (BCO_NEXT_64, (((StgWord) instrs[bciPtr-4]) << 48) \ + + (((StgWord) instrs[bciPtr-3]) << 32) \ + + (((StgWord) instrs[bciPtr-2]) << 16) \ + + ( (StgWord) instrs[bciPtr-1])) #if WORD_SIZE_IN_BITS == 32 #define BCO_NEXT_WORD BCO_NEXT_32 +#define BCO_READ_NEXT_WORD BCO_READ_NEXT_32 #elif WORD_SIZE_IN_BITS == 64 #define BCO_NEXT_WORD BCO_NEXT_64 +#define BCO_READ_NEXT_WORD BCO_READ_NEXT_64 #else #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64 #endif @@ -776,8 +784,12 @@ run_BCO: register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); +#ifdef DEBUG int bcoSize; - bcoSize = BCO_NEXT_WORD; + bcoSize = BCO_READ_NEXT_WORD; +#else + BCO_NEXT_WORD; +#endif IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize)); #ifdef INTERP_STATS diff --git a/rts/Linker.c b/rts/Linker.c index 28ba9a0aa9..781f705536 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -787,7 +787,6 @@ typedef struct _RtsSymbolVal { SymI_HasProto(forkProcess) \ SymI_HasProto(forkOS_createThread) \ SymI_HasProto(freeHaskellFunctionPtr) \ - SymI_HasProto(getOrSetTypeableStore) \ SymI_HasProto(getOrSetGHCConcSignalSignalHandlerStore) \ SymI_HasProto(getOrSetGHCConcWindowsPendingDelaysStore) \ SymI_HasProto(getOrSetGHCConcWindowsIOManagerThreadStore) \ @@ -1190,11 +1189,15 @@ initLinker( void ) compileResult = regcomp(&re_invalid, "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)", REG_EXTENDED); - ASSERT( compileResult == 0 ); + if (compileResult != 0) { + barf("Compiling re_invalid failed"); + } compileResult = regcomp(&re_realso, "(GROUP|INPUT) *\\( *(([^ )])+)", REG_EXTENDED); - ASSERT( compileResult == 0 ); + if (compileResult != 0) { + barf("Compiling re_realso failed"); + } # endif #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH) @@ -3941,7 +3944,7 @@ static int getSectionKind_ELF( Elf_Shdr *hdr, int *is_bss ) static int ocGetNames_ELF ( ObjectCode* oc ) { - int i, j, k, nent; + int i, j, nent; Elf_Sym* stab; char* ehdrC = (char*)(oc->image); @@ -3951,7 +3954,6 @@ ocGetNames_ELF ( ObjectCode* oc ) ASSERT(symhash != NULL); - k = 0; for (i = 0; i < ehdr->e_shnum; i++) { /* Figure out what kind of section it is. Logic derived from Figure 1.14 ("Special Sections") of the ELF document @@ -4125,10 +4127,14 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, Elf_Addr P = ((Elf_Addr)targ) + offset; Elf_Word* pP = (Elf_Word*)P; +#if defined(i386_HOST_ARCH) || defined(DEBUG) Elf_Addr A = *pP; +#endif Elf_Addr S; void* S_tmp; +#ifdef i386_HOST_ARCH Elf_Addr value; +#endif StgStablePtr stablePtr; StgPtr stableVal; @@ -4172,7 +4178,9 @@ do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, (void*)P, (void*)S, (void*)A )); checkProddableBlock ( oc, pP ); +#ifdef i386_HOST_ARCH value = S + A; +#endif switch (ELF_R_TYPE(info)) { # ifdef i386_HOST_ARCH diff --git a/rts/Printer.c b/rts/Printer.c index fcc483dce6..008427113a 100644 --- a/rts/Printer.c +++ b/rts/Printer.c @@ -418,10 +418,8 @@ printStackObj( StgPtr sp ) static void printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size ) { - StgPtr p; nat i; - p = payload; for(i = 0; i < size; i++, bitmap >>= 1 ) { debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i); if ((bitmap & 1) == 0) { @@ -531,11 +529,9 @@ printStackChunk( StgPtr sp, StgPtr spBottom ) { StgFunInfoTable *fun_info; StgRetFun *ret_fun; - nat size; ret_fun = (StgRetFun *)sp; fun_info = get_fun_itbl(ret_fun->fun); - size = ret_fun->size; debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, fun_info->f.fun_type); switch (fun_info->f.fun_type) { case ARG_GEN: diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 7d2a450129..9d95b4ccc0 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -827,6 +827,84 @@ dumpCensus( Census *census ) printSample(rtsFalse, census->time); } + +static void heapProfObject(Census *census, StgClosure *p, nat size, + rtsBool prim +#ifndef PROFILING + STG_UNUSED +#endif + ) +{ + void *identity; + nat real_size; + counter *ctr; + + identity = NULL; + +#ifdef PROFILING + // subtract the profiling overhead + real_size = size - sizeofW(StgProfHeader); +#else + real_size = size; +#endif + + if (closureSatisfiesConstraints((StgClosure*)p)) { +#ifdef PROFILING + if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) { + if (prim) + census->prim += real_size; + else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) + census->not_used += real_size; + else + census->used += real_size; + } else +#endif + { + identity = closureIdentity((StgClosure *)p); + + if (identity != NULL) { + ctr = lookupHashTable( census->hash, (StgWord)identity ); + if (ctr != NULL) { +#ifdef PROFILING + if (RtsFlags.ProfFlags.bioSelector != NULL) { + if (prim) + ctr->c.ldv.prim += real_size; + else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) + ctr->c.ldv.not_used += real_size; + else + ctr->c.ldv.used += real_size; + } else +#endif + { + ctr->c.resid += real_size; + } + } else { + ctr = arenaAlloc( census->arena, sizeof(counter) ); + initLDVCtr(ctr); + insertHashTable( census->hash, (StgWord)identity, ctr ); + ctr->identity = identity; + ctr->next = census->ctrs; + census->ctrs = ctr; + +#ifdef PROFILING + if (RtsFlags.ProfFlags.bioSelector != NULL) { + if (prim) + ctr->c.ldv.prim = real_size; + else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) + ctr->c.ldv.not_used = real_size; + else + ctr->c.ldv.used = real_size; + } else +#endif + { + ctr->c.resid = real_size; + } + } + } + } + } +} + /* ----------------------------------------------------------------------------- * Code to perform a heap census. * -------------------------------------------------------------------------- */ @@ -835,26 +913,26 @@ heapCensusChain( Census *census, bdescr *bd ) { StgPtr p; StgInfoTable *info; - void *identity; nat size; - counter *ctr; - nat real_size; rtsBool prim; for (; bd != NULL; bd = bd->link) { - // HACK: ignore pinned blocks, because they contain gaps. - // It's not clear exactly what we'd like to do here, since we - // can't tell which objects in the block are actually alive. - // Perhaps the whole block should be counted as SYSTEM memory. - if (bd->flags & BF_PINNED) { - continue; - } + // HACK: pretend a pinned block is just one big ARR_WORDS + // owned by CCS_SYSTEM. These blocks can be full of holes due + // to alignment constraints so we can't traverse the memory + // and do a proper census. + if (bd->flags & BF_PINNED) { + StgClosure arr; + SET_HDR(&arr, &stg_ARR_WORDS_info, CCS_SYSTEM); + heapProfObject(census, &arr, bd->blocks * BLOCK_SIZE_W, rtsTrue); + continue; + } p = bd->start; while (p < bd->free) { info = get_itbl((StgClosure *)p); - prim = rtsFalse; + prim = rtsFalse; switch (info->type) { @@ -904,7 +982,7 @@ heapCensusChain( Census *census, bdescr *bd ) break; case BCO: - prim = rtsTrue; + prim = rtsTrue; size = bco_sizeW((StgBCO *)p); break; @@ -985,70 +1063,7 @@ heapCensusChain( Census *census, bdescr *bd ) barf("heapCensus, unknown object: %d", info->type); } - identity = NULL; - -#ifdef PROFILING - // subtract the profiling overhead - real_size = size - sizeofW(StgProfHeader); -#else - real_size = size; -#endif - - if (closureSatisfiesConstraints((StgClosure*)p)) { -#ifdef PROFILING - if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) { - if (prim) - census->prim += real_size; - else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) - census->not_used += real_size; - else - census->used += real_size; - } else -#endif - { - identity = closureIdentity((StgClosure *)p); - - if (identity != NULL) { - ctr = lookupHashTable( census->hash, (StgWord)identity ); - if (ctr != NULL) { -#ifdef PROFILING - if (RtsFlags.ProfFlags.bioSelector != NULL) { - if (prim) - ctr->c.ldv.prim += real_size; - else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) - ctr->c.ldv.not_used += real_size; - else - ctr->c.ldv.used += real_size; - } else -#endif - { - ctr->c.resid += real_size; - } - } else { - ctr = arenaAlloc( census->arena, sizeof(counter) ); - initLDVCtr(ctr); - insertHashTable( census->hash, (StgWord)identity, ctr ); - ctr->identity = identity; - ctr->next = census->ctrs; - census->ctrs = ctr; - -#ifdef PROFILING - if (RtsFlags.ProfFlags.bioSelector != NULL) { - if (prim) - ctr->c.ldv.prim = real_size; - else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) - ctr->c.ldv.not_used = real_size; - else - ctr->c.ldv.used = real_size; - } else -#endif - { - ctr->c.resid = real_size; - } - } - } - } - } + heapProfObject(census,(StgClosure*)p,size,prim); p += size; } @@ -1056,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/Profiling.h b/rts/Profiling.h index e27ad4c5ed..3e365fe536 100644 --- a/rts/Profiling.h +++ b/rts/Profiling.h @@ -12,6 +12,13 @@ #include <stdio.h> #include "BeginPrivate.h" +#include "Rts.h" + +#ifdef PROFILING +#define PROFILING_ONLY(s) s +#else +#define PROFILING_ONLY(s) doNothing() +#endif void initProfiling1 (void); void initProfiling2 (void); diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index 4bfda6fef8..028b3e335a 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -1754,6 +1754,7 @@ retainRoot(void *user STG_UNUSED, StgClosure **tl) currentStackBoundary = stackTop; c = UNTAG_CLOSURE(*tl); + maybeInitRetainerSet(c); if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) { retainClosure(c, c, getRetainerFrom(c)); } else { @@ -1856,6 +1857,15 @@ computeRetainerSet( void ) * However, this is not necessary because any static indirection objects * are just traversed through to reach dynamic objects. In other words, * they are not taken into consideration in computing retainer sets. + * + * SDM (20/7/2011): I don't think this is doing anything sensible, + * because it happens before retainerProfile() and at the beginning of + * retainerProfil() we change the sense of 'flip'. So all of the + * calls to maybeInitRetainerSet() here are initialising retainer sets + * with the wrong flip. Also, I don't see why this is necessary. I + * added a maybeInitRetainerSet() call to retainRoot(), and that seems + * to have fixed the assertion failure in retainerSetOf() I was + * encountering. * -------------------------------------------------------------------------- */ void resetStaticObjectForRetainerProfiling( StgClosure *static_objects ) diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index 24181d32b0..fcc1f49a36 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -163,6 +163,9 @@ void initRtsFlagsDefaults(void) RtsFlags.TraceFlags.tracing = TRACE_NONE; RtsFlags.TraceFlags.timestamp = rtsFalse; RtsFlags.TraceFlags.scheduler = rtsFalse; + RtsFlags.TraceFlags.gc = rtsFalse; + RtsFlags.TraceFlags.sparks_sampled= rtsFalse; + RtsFlags.TraceFlags.sparks_full = rtsFalse; #endif RtsFlags.MiscFlags.tickInterval = 20; /* In milliseconds */ @@ -288,9 +291,15 @@ usage_text[] = { # endif " where [flags] can contain:", " s scheduler events", +" g GC events", +" p par spark events (sampled)", +" f par spark events (full detail)", # ifdef DEBUG " t add time stamps (only useful with -v)", # endif +" a all event classes above", +" -x disable an event class, for any flag above", +" the initial enabled event classes are 'sgp'", #endif #if !defined(PROFILING) @@ -1429,19 +1438,64 @@ decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) static void read_trace_flags(char *arg) { char *c; + rtsBool enabled = rtsTrue; + /* Syntax for tracing flags currently looks like: + * + * -l To turn on eventlog tracing with default trace classes + * -lx Turn on class 'x' (for some class listed below) + * -l-x Turn off class 'x' + * -la Turn on all classes + * -l-a Turn off all classes + * + * This lets users say things like: + * -la-p "all but sparks" + * -l-ap "only sparks" + */ + + /* Start by turning on the default tracing flags. + * + * Currently this is all the trace classes, except full-detail sparks. + * Similarly, in future we might default to slightly less verbose + * scheduler or GC tracing. + */ + RtsFlags.TraceFlags.scheduler = rtsTrue; + RtsFlags.TraceFlags.gc = rtsTrue; + RtsFlags.TraceFlags.sparks_sampled = rtsTrue; for (c = arg; *c != '\0'; c++) { switch(*c) { case '\0': break; + case '-': + enabled = rtsFalse; + break; + case 'a': + RtsFlags.TraceFlags.scheduler = enabled; + RtsFlags.TraceFlags.gc = enabled; + RtsFlags.TraceFlags.sparks_sampled = enabled; + RtsFlags.TraceFlags.sparks_full = enabled; + enabled = rtsTrue; + break; + case 's': - RtsFlags.TraceFlags.scheduler = rtsTrue; + RtsFlags.TraceFlags.scheduler = enabled; + enabled = rtsTrue; + break; + case 'p': + RtsFlags.TraceFlags.sparks_sampled = enabled; + enabled = rtsTrue; + break; + case 'f': + RtsFlags.TraceFlags.sparks_full = enabled; + enabled = rtsTrue; break; case 't': - RtsFlags.TraceFlags.timestamp = rtsTrue; + RtsFlags.TraceFlags.timestamp = enabled; + enabled = rtsTrue; break; case 'g': - // ignored for backwards-compat + RtsFlags.TraceFlags.gc = enabled; + enabled = rtsTrue; break; default: errorBelch("unknown trace option: %c",*c); diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d index bd32fca385..04005108d5 100644 --- a/rts/RtsProbes.d +++ b/rts/RtsProbes.d @@ -43,8 +43,6 @@ provider HaskellEvent { probe stop__thread (EventCapNo, EventThreadID, EventThreadStatus, EventThreadID); probe thread__runnable (EventCapNo, EventThreadID); probe migrate__thread (EventCapNo, EventThreadID, EventCapNo); - probe run__spark (EventCapNo, EventThreadID); - probe steal__spark (EventCapNo, EventThreadID, EventCapNo); probe shutdown (EventCapNo); probe thread_wakeup (EventCapNo, EventThreadID, EventCapNo); probe gc__start (EventCapNo); @@ -67,4 +65,16 @@ provider HaskellEvent { probe capset__assign__cap(EventCapsetID, EventCapNo); probe capset__remove__cap(EventCapsetID, EventCapNo); + probe spark__counters(EventCapNo, + StgWord, StgWord, StgWord, + StgWord, StgWord, StgWord, + StgWord); + + probe spark__create (EventCapNo); + probe spark__dud (EventCapNo); + probe spark__overflow (EventCapNo); + probe spark__run (EventCapNo); + probe spark__steal (EventCapNo, EventCapNo); + probe spark__fizzle (EventCapNo); + probe spark__gc (EventCapNo); }; @@ -1089,7 +1089,7 @@ static void disconnect_invariant(Capability *cap, FOR_EACH_ENTRY(last_execution, e, { StgTVar *s = e -> tvar; StgTVarWatchQueue *q = s -> first_watch_queue_entry; - StgBool found = FALSE; + DEBUG_ONLY( StgBool found = FALSE ); TRACE(" looking for trec on tvar=%p", s); for (q = s -> first_watch_queue_entry; q != END_STM_WATCH_QUEUE; @@ -1110,7 +1110,7 @@ static void disconnect_invariant(Capability *cap, } TRACE(" found it in watch queue entry %p", q); free_stg_tvar_watch_queue(cap, q); - found = TRUE; + DEBUG_ONLY( found = TRUE ); break; } } diff --git a/rts/Schedule.c b/rts/Schedule.c index fd5536b913..834e3eb420 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -581,6 +581,10 @@ static void schedulePreLoop(void) { // initialisation for scheduler - what cannot go into initScheduler() + +#if defined(mingw32_HOST_OS) + win32AllocStack(); +#endif } /* ----------------------------------------------------------------------------- @@ -715,7 +719,9 @@ schedulePushWork(Capability *cap USED_IF_THREADS, if (n_free_caps > 0) { StgTSO *prev, *t, *next; +#ifdef SPARK_PUSHING rtsBool pushed_to_all; +#endif debugTrace(DEBUG_sched, "cap %d: %s and %d free capabilities, sharing...", @@ -725,7 +731,9 @@ schedulePushWork(Capability *cap USED_IF_THREADS, n_free_caps); i = 0; +#ifdef SPARK_PUSHING pushed_to_all = rtsFalse; +#endif if (cap->run_queue_hd != END_TSO_QUEUE) { prev = cap->run_queue_hd; @@ -740,7 +748,9 @@ schedulePushWork(Capability *cap USED_IF_THREADS, setTSOPrev(cap, t, prev); prev = t; } else if (i == n_free_caps) { +#ifdef SPARK_PUSHING pushed_to_all = rtsTrue; +#endif i = 0; // keep one for us setTSOLink(cap, prev, t); @@ -773,6 +783,10 @@ schedulePushWork(Capability *cap USED_IF_THREADS, if (emptySparkPoolCap(free_caps[i])) { spark = tryStealSpark(cap->sparks); if (spark != NULL) { + /* TODO: if anyone wants to re-enable this code then + * they must consider the fizzledSpark(spark) case + * and update the per-cap spark statistics. + */ debugTrace(DEBUG_sched, "pushing spark %p to capability %d", spark, free_caps[i]->no); traceEventStealSpark(free_caps[i], t, cap->no); @@ -1400,6 +1414,11 @@ scheduleDoGC (Capability *cap, Task *task USED_IF_THREADS, rtsBool force_major) // multi-threaded GC: make sure all the Capabilities donate one // GC thread each. waitForGcThreads(cap); + +#if defined(THREADED_RTS) + // Stable point where we can do a global check on our spark counters + ASSERT(checkSparkCountInvariant()); +#endif } #endif @@ -1424,12 +1443,14 @@ delete_threads_and_gc: // reset waiting_for_gc *before* GC, so that when the GC threads // emerge they don't immediately re-enter the GC. waiting_for_gc = 0; - GarbageCollect(force_major || heap_census, gc_type, cap); + GarbageCollect(force_major || heap_census, heap_census, gc_type, cap); #else - GarbageCollect(force_major || heap_census, 0, cap); + GarbageCollect(force_major || heap_census, heap_census, 0, cap); #endif traceEventGcEnd(cap); + traceSparkCounters(cap); + if (recent_activity == ACTIVITY_INACTIVE && force_major) { // We are doing a GC because the system has been idle for a @@ -1447,10 +1468,14 @@ delete_threads_and_gc: recent_activity = ACTIVITY_YES; } +#if defined(THREADED_RTS) + // Stable point where we can do a global check on our spark counters + ASSERT(checkSparkCountInvariant()); +#endif + + // The heap census itself is done during GarbageCollect(). if (heap_census) { - debugTrace(DEBUG_sched, "performing heap census"); - heapCensus(); - performHeapProfile = rtsFalse; + performHeapProfile = rtsFalse; } #if defined(THREADED_RTS) @@ -1892,7 +1917,7 @@ Capability * scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability *cap) { Task *task; - StgThreadID id; + DEBUG_ONLY( StgThreadID id ); // We already created/initialised the Task task = cap->running_task; @@ -1908,7 +1933,7 @@ scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability *cap) appendToRunQueue(cap,tso); - id = tso->id; + DEBUG_ONLY( id = tso->id ); debugTrace(DEBUG_sched, "new bound thread (%lu)", (unsigned long)id); cap = schedule(cap,task); @@ -1986,10 +2011,6 @@ initScheduler(void) initTaskManager(); -#if defined(THREADED_RTS) - initSparkPools(); -#endif - RELEASE_LOCK(&sched_mutex); #if defined(THREADED_RTS) diff --git a/rts/Sparks.c b/rts/Sparks.c index a826190941..4241656795 100644 --- a/rts/Sparks.c +++ b/rts/Sparks.c @@ -17,14 +17,10 @@ #if defined(THREADED_RTS) -void -initSparkPools( void ) +SparkPool * +allocSparkPool( void ) { - /* walk over the capabilities, allocating a spark pool for each one */ - nat i; - for (i = 0; i < n_capabilities; i++) { - capabilities[i].sparks = newWSDeque(RtsFlags.ParFlags.maxLocalSparks); - } + return newWSDeque(RtsFlags.ParFlags.maxLocalSparks); } void @@ -63,48 +59,23 @@ newSpark (StgRegTable *reg, StgClosure *p) Capability *cap = regTableToCapability(reg); SparkPool *pool = cap->sparks; - /* I am not sure whether this is the right thing to do. - * Maybe it is better to exploit the tag information - * instead of throwing it away? - */ - p = UNTAG_CLOSURE(p); - - if (closure_SHOULD_SPARK(p)) { - pushWSDeque(pool,p); - cap->sparks_created++; + if (!fizzledSpark(p)) { + if (pushWSDeque(pool,p)) { + cap->spark_stats.created++; + traceEventSparkCreate(cap); + } else { + /* overflowing the spark pool */ + cap->spark_stats.overflowed++; + traceEventSparkOverflow(cap); + } } else { - cap->sparks_dud++; + cap->spark_stats.dud++; + traceEventSparkDud(cap); } return 1; } -/* ----------------------------------------------------------------------------- - * - * tryStealSpark: try to steal a spark from a Capability. - * - * Returns a valid spark, or NULL if the pool was empty, and can - * occasionally return NULL if there was a race with another thread - * stealing from the same pool. In this case, try again later. - * - -------------------------------------------------------------------------- */ - -StgClosure * -tryStealSpark (Capability *cap) -{ - SparkPool *pool = cap->sparks; - StgClosure *stolen; - - do { - stolen = stealWSDeque_(pool); - // use the no-loopy version, stealWSDeque_(), since if we get a - // spurious NULL here the caller may want to try stealing from - // other pools before trying again. - } while (stolen != NULL && !closure_SHOULD_SPARK(stolen)); - - return stolen; -} - /* -------------------------------------------------------------------------- * Remove all sparks from the spark queues which should not spark any * more. Called after GC. We assume exclusive access to the structure @@ -205,7 +176,8 @@ pruneSparkQueue (Capability *cap) // evaluated, but it doesn't hurt to have this check for // robustness. pruned_sparks++; - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } else { info = spark->header.info; if (IS_FORWARDING_PTR(info)) { @@ -217,7 +189,8 @@ pruneSparkQueue (Capability *cap) n++; } else { pruned_sparks++; // discard spark - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } } else if (HEAP_ALLOCED(spark)) { if ((Bdescr((P_)spark)->flags & BF_EVACUATED)) { @@ -227,11 +200,13 @@ pruneSparkQueue (Capability *cap) n++; } else { pruned_sparks++; // discard spark - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } } else { pruned_sparks++; // discard spark - cap->sparks_gcd++; + cap->spark_stats.gcd++; + traceEventSparkGC(cap); } } else { if (INFO_PTR_TO_STRUCT(info)->type == THUNK_STATIC) { @@ -241,11 +216,13 @@ pruneSparkQueue (Capability *cap) n++; } else { pruned_sparks++; // discard spark - cap->sparks_gcd++; + cap->spark_stats.gcd++; + traceEventSparkGC(cap); } } else { pruned_sparks++; // discard spark - cap->sparks_fizzled++; + cap->spark_stats.fizzled++; + traceEventSparkFizzle(cap); } } } diff --git a/rts/Sparks.h b/rts/Sparks.h index cffe99dd39..e381dd540f 100644 --- a/rts/Sparks.h +++ b/rts/Sparks.h @@ -15,12 +15,22 @@ /* typedef for SparkPool in RtsTypes.h */ +/* Stats on spark creation/conversion */ +typedef struct { + StgWord created; + StgWord dud; + StgWord overflowed; + StgWord converted; + StgWord gcd; + StgWord fizzled; +} SparkCounters; + #if defined(THREADED_RTS) typedef WSDeque SparkPool; // Initialisation -void initSparkPools (void); +SparkPool *allocSparkPool (void); // Take a spark from the "write" end of the pool. Can be called // by the pool owner only. @@ -30,7 +40,9 @@ INLINE_HEADER StgClosure* reclaimSpark(SparkPool *pool); // if the pool is almost empty). INLINE_HEADER rtsBool looksEmpty(SparkPool* deque); -StgClosure * tryStealSpark (Capability *cap); +INLINE_HEADER StgClosure * tryStealSpark (SparkPool *pool); +INLINE_HEADER rtsBool fizzledSpark (StgClosure *); + void freeSparkPool (SparkPool *pool); void createSparkThread (Capability *cap); void traverseSparkQueue(evac_fn evac, void *user, Capability *cap); @@ -63,6 +75,32 @@ INLINE_HEADER void discardSparks (SparkPool *pool) discardElements(pool); } +/* ---------------------------------------------------------------------------- + * + * tryStealSpark: try to steal a spark from a Capability. + * + * Returns either: + * (a) a useful spark; + * (b) a fizzled spark (use fizzledSpark to check); + * (c) or NULL if the pool was empty, and can occasionally return NULL + * if there was a race with another thread stealing from the same + * pool. In this case, try again later. + * + -------------------------------------------------------------------------- */ + +INLINE_HEADER StgClosure * tryStealSpark (SparkPool *pool) +{ + return stealWSDeque_(pool); + // use the no-loopy version, stealWSDeque_(), since if we get a + // spurious NULL here the caller may want to try stealing from + // other pools before trying again. +} + +INLINE_HEADER rtsBool fizzledSpark (StgClosure *spark) +{ + return (GET_CLOSURE_TAG(spark) != 0 || !closure_SHOULD_SPARK(spark)); +} + #endif // THREADED_RTS #include "EndPrivate.h" diff --git a/rts/Stats.c b/rts/Stats.c index 9fc702a2a3..c071ec0202 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -57,7 +57,7 @@ static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time #endif static lnat max_residency = 0; // in words; for stats only -static lnat avg_residency = 0; +static lnat cumulative_residency = 0; static lnat residency_samples = 0; // for stats only static lnat max_slop = 0; @@ -84,11 +84,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 +105,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 +151,7 @@ initStats0(void) #endif max_residency = 0; - avg_residency = 0; + cumulative_residency = 0; residency_samples = 0; max_slop = 0; @@ -362,7 +368,7 @@ stat_endGC (gc_thread *gct, max_residency = live; } residency_samples++; - avg_residency += live; + cumulative_residency += live; } if (slop > max_slop) max_slop = slop; @@ -629,21 +635,20 @@ stat_exit(int alloc) { nat i; - lnat sparks_created = 0; - lnat sparks_dud = 0; - lnat sparks_converted = 0; - lnat sparks_gcd = 0; - lnat sparks_fizzled = 0; + SparkCounters sparks = { 0, 0, 0, 0, 0, 0}; for (i = 0; i < n_capabilities; i++) { - sparks_created += capabilities[i].sparks_created; - sparks_dud += capabilities[i].sparks_dud; - sparks_converted += capabilities[i].sparks_converted; - sparks_gcd += capabilities[i].sparks_gcd; - sparks_fizzled += capabilities[i].sparks_fizzled; + sparks.created += capabilities[i].spark_stats.created; + sparks.dud += capabilities[i].spark_stats.dud; + sparks.overflowed+= capabilities[i].spark_stats.overflowed; + sparks.converted += capabilities[i].spark_stats.converted; + sparks.gcd += capabilities[i].spark_stats.gcd; + sparks.fizzled += capabilities[i].spark_stats.fizzled; } - statsPrintf(" SPARKS: %ld (%ld converted, %ld dud, %ld GC'd, %ld fizzled)\n\n", - sparks_created + sparks_dud, sparks_converted, sparks_dud, sparks_gcd, sparks_fizzled); + statsPrintf(" SPARKS: %ld (%ld converted, %ld overflowed, %ld dud, %ld GC'd, %ld fizzled)\n\n", + sparks.created + sparks.dud + sparks.overflowed, + sparks.converted, sparks.overflowed, sparks.dud, + sparks.gcd, sparks.fizzled); } #endif @@ -740,7 +745,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)), 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/StgCRun.c b/rts/StgCRun.c index e28353c353..69d9549f6e 100644 --- a/rts/StgCRun.c +++ b/rts/StgCRun.c @@ -128,18 +128,29 @@ StgFunPtr StgReturn(void) #define STG_GLOBAL ".global " #endif -StgRegTable * -StgRun(StgFunPtr f, StgRegTable *basereg) { +static void GNUC3_ATTRIBUTE(used) +StgRunIsImplementedInAssembler(void) +{ + __asm__ volatile ( + STG_GLOBAL STG_RUN "\n" + STG_RUN ":\n\t" - unsigned char space[ RESERVED_C_STACK_BYTES + 4*sizeof(void *) ]; - StgRegTable * r; + /* + * move %esp down to reserve an area for temporary storage + * during the execution of STG code. + * + * The stack pointer has to be aligned to a multiple of 16 + * bytes from here - this is a requirement of the C ABI, so + * that C code can assign SSE2 registers directly to/from + * stack locations. + */ + "subl %0, %%esp\n\t" - __asm__ volatile ( /* * save callee-saves registers on behalf of the STG code. */ - "movl %%esp, %%eax\n\t" - "addl %4, %%eax\n\t" + "movl %%esp, %%eax\n\t" + "addl %0-16, %%eax\n\t" "movl %%ebx,0(%%eax)\n\t" "movl %%esi,4(%%eax)\n\t" "movl %%edi,8(%%eax)\n\t" @@ -147,25 +158,17 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { /* * Set BaseReg */ - "movl %3,%%ebx\n\t" + "movl 24(%%eax),%%ebx\n\t" /* * grab the function argument from the stack */ - "movl %2,%%eax\n\t" - - /* - * Darwin note: - * The stack pointer has to be aligned to a multiple of 16 bytes at - * this point. This works out correctly with gcc 4.0.1, but it might - * break at any time in the future. TODO: Make this future-proof. - */ - - /* + "movl 20(%%eax),%%eax\n\t" + /* * jump to it */ "jmp *%%eax\n\t" - STG_GLOBAL STG_RETURN "\n" + STG_GLOBAL STG_RETURN "\n" STG_RETURN ":\n\t" "movl %%esi, %%eax\n\t" /* Return value in R1 */ @@ -174,19 +177,32 @@ StgRun(StgFunPtr f, StgRegTable *basereg) { * restore callee-saves registers. (Don't stomp on %%eax!) */ "movl %%esp, %%edx\n\t" - "addl %4, %%edx\n\t" + "addl %0-16, %%edx\n\t" "movl 0(%%edx),%%ebx\n\t" /* restore the registers saved above */ "movl 4(%%edx),%%esi\n\t" "movl 8(%%edx),%%edi\n\t" "movl 12(%%edx),%%ebp\n\t" - : "=&a" (r), "=m" (space) - : "m" (f), "m" (basereg), "i" (RESERVED_C_STACK_BYTES) - : "edx" /* stomps on %edx */ + "addl %0, %%esp\n\t" + "ret" + + : : "i" (RESERVED_C_STACK_BYTES + 16 + 12) + // + 16 to make room for the 4 registers we have to save + // + 12 because we need to align %esp to a 16-byte boundary (#5250) ); +} - return r; +#if defined(mingw32_HOST_OS) +// On windows the stack has to be allocated 4k at a time, otherwise +// we get a segfault. The C compiler knows how to do this (it calls +// _alloca()), so we make sure that we can allocate as much stack as +// we need: +StgWord8 *win32AllocStack(void) +{ + StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12]; + return stack; } +#endif #endif diff --git a/rts/StgRun.h b/rts/StgRun.h index f277097df7..71b92e2d88 100644 --- a/rts/StgRun.h +++ b/rts/StgRun.h @@ -11,4 +11,8 @@ RTS_PRIVATE StgRegTable * StgRun (StgFunPtr f, StgRegTable *basereg); +#if defined(mingw32_HOST_OS) +StgWord8 *win32AllocStack(void); +#endif + #endif /* STGRUN_H */ diff --git a/rts/Task.c b/rts/Task.c index e77a030f39..cf406b2abe 100644 --- a/rts/Task.c +++ b/rts/Task.c @@ -347,8 +347,8 @@ taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time) void workerTaskStop (Task *task) { - OSThreadId id; - id = osThreadId(); + DEBUG_ONLY( OSThreadId id ); + DEBUG_ONLY( id = osThreadId() ); ASSERT(task->id == id); ASSERT(myTask() == task); diff --git a/rts/Trace.c b/rts/Trace.c index 70f4a39742..1dce968490 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -47,6 +47,9 @@ int DEBUG_sparks; // events int TRACE_sched; +int TRACE_gc; +int TRACE_spark_sampled; +int TRACE_spark_full; #ifdef THREADED_RTS static Mutex trace_utx; @@ -90,8 +93,25 @@ void initTracing (void) RtsFlags.TraceFlags.scheduler || RtsFlags.DebugFlags.scheduler; + // -Dg turns on gc tracing too + TRACE_gc = + RtsFlags.TraceFlags.gc || + RtsFlags.DebugFlags.gc; + + TRACE_spark_sampled = + RtsFlags.TraceFlags.sparks_sampled; + + // -Dr turns on full spark tracing + TRACE_spark_full = + RtsFlags.TraceFlags.sparks_full || + RtsFlags.DebugFlags.sparks; + eventlog_enabled = RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG; + /* Note: we can have TRACE_sched or TRACE_spark turned on even when + eventlog_enabled is off. In the DEBUG way we may be tracing to stderr. + */ + if (eventlog_enabled) { initEventLogging(); } @@ -179,22 +199,10 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, debugBelch("cap %d: thread %lu appended to run queue\n", cap->no, (lnat)tso->id); break; - case EVENT_RUN_SPARK: // (cap, thread) - debugBelch("cap %d: thread %lu running a spark\n", - cap->no, (lnat)tso->id); - break; - case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) - debugBelch("cap %d: creating spark thread %lu\n", - cap->no, (long)info1); - break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) debugBelch("cap %d: thread %lu migrating to cap %d\n", cap->no, (lnat)tso->id, (int)info1); break; - case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) - debugBelch("cap %d: thread %lu stealing a spark from cap %d\n", - cap->no, (lnat)tso->id, (int)info1); - break; case EVENT_THREAD_WAKEUP: // (cap, thread, info1_cap) debugBelch("cap %d: waking up thread %lu on cap %d\n", cap->no, (lnat)tso->id, (int)info1); @@ -212,27 +220,6 @@ static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, case EVENT_SHUTDOWN: // (cap) debugBelch("cap %d: shutting down\n", cap->no); break; - case EVENT_REQUEST_SEQ_GC: // (cap) - debugBelch("cap %d: requesting sequential GC\n", cap->no); - break; - case EVENT_REQUEST_PAR_GC: // (cap) - debugBelch("cap %d: requesting parallel GC\n", cap->no); - break; - case EVENT_GC_START: // (cap) - debugBelch("cap %d: starting GC\n", cap->no); - break; - case EVENT_GC_END: // (cap) - debugBelch("cap %d: finished GC\n", cap->no); - break; - case EVENT_GC_IDLE: // (cap) - debugBelch("cap %d: GC idle\n", cap->no); - break; - case EVENT_GC_WORK: // (cap) - debugBelch("cap %d: GC working\n", cap->no); - break; - case EVENT_GC_DONE: // (cap) - debugBelch("cap %d: GC done\n", cap->no); - break; default: debugBelch("cap %d: thread %lu: event %d\n\n", cap->no, (lnat)tso->id, tag); @@ -256,6 +243,56 @@ void traceSchedEvent_ (Capability *cap, EventTypeNum tag, } } +#ifdef DEBUG +static void traceGcEvent_stderr (Capability *cap, EventTypeNum tag) +{ + ACQUIRE_LOCK(&trace_utx); + + tracePreface(); + switch (tag) { + case EVENT_REQUEST_SEQ_GC: // (cap) + debugBelch("cap %d: requesting sequential GC\n", cap->no); + break; + case EVENT_REQUEST_PAR_GC: // (cap) + debugBelch("cap %d: requesting parallel GC\n", cap->no); + break; + case EVENT_GC_START: // (cap) + debugBelch("cap %d: starting GC\n", cap->no); + break; + case EVENT_GC_END: // (cap) + debugBelch("cap %d: finished GC\n", cap->no); + break; + case EVENT_GC_IDLE: // (cap) + debugBelch("cap %d: GC idle\n", cap->no); + break; + case EVENT_GC_WORK: // (cap) + debugBelch("cap %d: GC working\n", cap->no); + break; + case EVENT_GC_DONE: // (cap) + debugBelch("cap %d: GC done\n", cap->no); + break; + default: + barf("traceGcEvent: unknown event tag %d", tag); + break; + } + + RELEASE_LOCK(&trace_utx); +} +#endif + +void traceGcEvent_ (Capability *cap, EventTypeNum tag) +{ +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + traceGcEvent_stderr(cap, tag); + } else +#endif + { + /* currently all GC events are nullary events */ + postEvent(cap, tag); + } +} + void traceCapsetModify_ (EventTypeNum tag, CapsetID capset, StgWord32 other) @@ -335,15 +372,80 @@ void traceOSProcessInfo_(void) { } } -void traceEvent_ (Capability *cap, EventTypeNum tag) +#ifdef DEBUG +static void traceSparkEvent_stderr (Capability *cap, EventTypeNum tag, + StgWord info1) +{ + ACQUIRE_LOCK(&trace_utx); + + tracePreface(); + switch (tag) { + + case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) + debugBelch("cap %d: creating spark thread %lu\n", + cap->no, (long)info1); + break; + case EVENT_SPARK_CREATE: // (cap) + debugBelch("cap %d: added spark to pool\n", + cap->no); + break; + case EVENT_SPARK_DUD: // (cap) + debugBelch("cap %d: discarded dud spark\n", + cap->no); + break; + case EVENT_SPARK_OVERFLOW: // (cap) + debugBelch("cap %d: discarded overflowed spark\n", + cap->no); + break; + case EVENT_SPARK_RUN: // (cap) + debugBelch("cap %d: running a spark\n", + cap->no); + break; + case EVENT_SPARK_STEAL: // (cap, victim_cap) + debugBelch("cap %d: stealing a spark from cap %d\n", + cap->no, (int)info1); + break; + case EVENT_SPARK_FIZZLE: // (cap) + debugBelch("cap %d: fizzled spark removed from pool\n", + cap->no); + break; + case EVENT_SPARK_GC: // (cap) + debugBelch("cap %d: GCd spark removed from pool\n", + cap->no); + break; + default: + barf("traceSparkEvent: unknown event tag %d", tag); + break; + } + + RELEASE_LOCK(&trace_utx); +} +#endif + +void traceSparkEvent_ (Capability *cap, EventTypeNum tag, StgWord info1) +{ +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + traceSparkEvent_stderr(cap, tag, info1); + } else +#endif + { + postSparkEvent(cap,tag,info1); + } +} + +void traceSparkCounters_ (Capability *cap, + SparkCounters counters, + StgWord remaining) { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { - traceSchedEvent_stderr(cap, tag, 0, 0, 0); + /* we currently don't do debug tracing of spark stats but we must + test for TRACE_STDERR because of the !eventlog_enabled case. */ } else #endif { - postEvent(cap,tag); + postSparkCountersEvent(cap, counters, remaining); } } diff --git a/rts/Trace.h b/rts/Trace.h index 1544971077..f896c0e7a2 100644 --- a/rts/Trace.h +++ b/rts/Trace.h @@ -62,6 +62,9 @@ extern int DEBUG_sparks; // events extern int TRACE_sched; +extern int TRACE_gc; +extern int TRACE_spark_sampled; +extern int TRACE_spark_full; // ----------------------------------------------------------------------------- // Posting events @@ -96,16 +99,30 @@ void traceEnd (void); void traceSchedEvent_ (Capability *cap, EventTypeNum tag, StgTSO *tso, StgWord info1, StgWord info2); +/* + * Record a GC event + */ +#define traceGcEvent(cap, tag) \ + if (RTS_UNLIKELY(TRACE_gc)) { \ + traceGcEvent_(cap, tag); \ + } -/* - * Record a nullary event +void traceGcEvent_ (Capability *cap, EventTypeNum tag); + +/* + * Record a spark event */ -#define traceEvent(cap, tag) \ - if (RTS_UNLIKELY(TRACE_sched)) { \ - traceEvent_(cap, tag); \ +#define traceSparkEvent(cap, tag) \ + if (RTS_UNLIKELY(TRACE_spark_full)) { \ + traceSparkEvent_(cap, tag, 0); \ + } + +#define traceSparkEvent2(cap, tag, other) \ + if (RTS_UNLIKELY(TRACE_spark_full)) { \ + traceSparkEvent_(cap, tag, other); \ } -void traceEvent_ (Capability *cap, EventTypeNum tag); +void traceSparkEvent_ (Capability *cap, EventTypeNum tag, StgWord info1); // variadic macros are C99, and supported by gcc. However, the // ##__VA_ARGS syntax is a gcc extension, which allows the variable @@ -184,19 +201,26 @@ void traceCapsetModify_ (EventTypeNum tag, void traceOSProcessInfo_ (void); +void traceSparkCounters_ (Capability *cap, + SparkCounters counters, + StgWord remaining); + #else /* !TRACING */ #define traceSchedEvent(cap, tag, tso, other) /* nothing */ #define traceSchedEvent2(cap, tag, tso, other, info) /* nothing */ -#define traceEvent(cap, tag) /* nothing */ +#define traceGcEvent(cap, tag) /* nothing */ +#define traceSparkEvent(cap, tag) /* nothing */ +#define traceSparkEvent2(cap, tag, other) /* nothing */ #define traceCap(class, cap, msg, ...) /* nothing */ #define trace(class, msg, ...) /* nothing */ #define debugTrace(class, str, ...) /* nothing */ #define debugTraceCap(class, cap, str, ...) /* nothing */ #define traceThreadStatus(class, tso) /* nothing */ -#define traceEventStartup_(n_caps) /* nothing */ +INLINE_HEADER void traceEventStartup_ (int n_caps STG_UNUSED) {}; #define traceCapsetModify_(tag, capset, other) /* nothing */ #define traceOSProcessInfo_() /* nothing */ +#define traceSparkCounters_(cap, counters, remaining) /* nothing */ #endif /* TRACING */ @@ -225,10 +249,6 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); HASKELLEVENT_THREAD_RUNNABLE(cap, tid) #define dtraceMigrateThread(cap, tid, new_cap) \ HASKELLEVENT_MIGRATE_THREAD(cap, tid, new_cap) -#define dtraceRunSpark(cap, tid) \ - HASKELLEVENT_RUN_SPARK(cap, tid) -#define dtraceStealSpark(cap, tid, victim_cap) \ - HASKELLEVENT_STEAL_SPARK(cap, tid, victim_cap) #define dtraceShutdown(cap) \ HASKELLEVENT_SHUTDOWN(cap) #define dtraceThreadWakeup(cap, tid, other_cap) \ @@ -243,8 +263,9 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); HASKELLEVENT_REQUEST_PAR_GC(cap) #define dtraceCreateSparkThread(cap, spark_tid) \ HASKELLEVENT_CREATE_SPARK_THREAD(cap, spark_tid) -#define dtraceStartup(num_caps) \ - HASKELLEVENT_STARTUP(num_caps) +INLINE_HEADER void dtraceStartup (int num_caps) { + HASKELLEVENT_STARTUP(num_caps); +} #define dtraceUserMsg(cap, msg) \ HASKELLEVENT_USER_MSG(cap, msg) #define dtraceGcIdle(cap) \ @@ -261,6 +282,22 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno) #define dtraceCapsetRemoveCap(capset, capno) \ HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno) +#define dtraceSparkCounters(cap, a, b, c, d, e, f, g) \ + HASKELLEVENT_SPARK_COUNTERS(cap, a, b, c, d, e, f, g) +#define dtraceSparkCreate(cap) \ + HASKELLEVENT_SPARK_CREATE(cap) +#define dtraceSparkDud(cap) \ + HASKELLEVENT_SPARK_DUD(cap) +#define dtraceSparkOverflow(cap) \ + HASKELLEVENT_SPARK_OVERFLOW(cap) +#define dtraceSparkRun(cap) \ + HASKELLEVENT_SPARK_RUN(cap) +#define dtraceSparkSteal(cap, victim_cap) \ + HASKELLEVENT_SPARK_STEAL(cap, victim_cap) +#define dtraceSparkFizzle(cap) \ + HASKELLEVENT_SPARK_FIZZLE(cap) +#define dtraceSparkGc(cap) \ + HASKELLEVENT_SPARK_GC(cap) #else /* !defined(DTRACE) */ @@ -269,8 +306,6 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); #define dtraceStopThread(cap, tid, status, info) /* nothing */ #define dtraceThreadRunnable(cap, tid) /* nothing */ #define dtraceMigrateThread(cap, tid, new_cap) /* nothing */ -#define dtraceRunSpark(cap, tid) /* nothing */ -#define dtraceStealSpark(cap, tid, victim_cap) /* nothing */ #define dtraceShutdown(cap) /* nothing */ #define dtraceThreadWakeup(cap, tid, other_cap) /* nothing */ #define dtraceGcStart(cap) /* nothing */ @@ -278,7 +313,7 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); #define dtraceRequestSeqGc(cap) /* nothing */ #define dtraceRequestParGc(cap) /* nothing */ #define dtraceCreateSparkThread(cap, spark_tid) /* nothing */ -#define dtraceStartup(num_caps) /* nothing */ +INLINE_HEADER void dtraceStartup (int num_caps STG_UNUSED) {}; #define dtraceUserMsg(cap, msg) /* nothing */ #define dtraceGcIdle(cap) /* nothing */ #define dtraceGcWork(cap) /* nothing */ @@ -287,6 +322,14 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg); #define dtraceCapsetDelete(capset) /* nothing */ #define dtraceCapsetAssignCap(capset, capno) /* nothing */ #define dtraceCapsetRemoveCap(capset, capno) /* nothing */ +#define dtraceSparkCounters(cap, a, b, c, d, e, f, g) /* nothing */ +#define dtraceSparkCreate(cap) /* nothing */ +#define dtraceSparkDud(cap) /* nothing */ +#define dtraceSparkOverflow(cap) /* nothing */ +#define dtraceSparkRun(cap) /* nothing */ +#define dtraceSparkSteal(cap, victim_cap) /* nothing */ +#define dtraceSparkFizzle(cap) /* nothing */ +#define dtraceSparkGc(cap) /* nothing */ #endif @@ -351,22 +394,6 @@ INLINE_HEADER void traceEventMigrateThread(Capability *cap STG_UNUSED, (EventCapNo)new_cap); } -INLINE_HEADER void traceEventRunSpark(Capability *cap STG_UNUSED, - StgTSO *tso STG_UNUSED) -{ - traceSchedEvent(cap, EVENT_RUN_SPARK, tso, 0); - dtraceRunSpark((EventCapNo)cap->no, (EventThreadID)tso->id); -} - -INLINE_HEADER void traceEventStealSpark(Capability *cap STG_UNUSED, - StgTSO *tso STG_UNUSED, - nat victim_cap STG_UNUSED) -{ - traceSchedEvent(cap, EVENT_STEAL_SPARK, tso, victim_cap); - dtraceStealSpark((EventCapNo)cap->no, (EventThreadID)tso->id, - (EventCapNo)victim_cap); -} - INLINE_HEADER void traceEventShutdown(Capability *cap STG_UNUSED) { traceSchedEvent(cap, EVENT_SHUTDOWN, 0, 0); @@ -384,40 +411,51 @@ INLINE_HEADER void traceEventThreadWakeup(Capability *cap STG_UNUSED, INLINE_HEADER void traceEventGcStart(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_GC_START, 0, 0); + traceGcEvent(cap, EVENT_GC_START); dtraceGcStart((EventCapNo)cap->no); } INLINE_HEADER void traceEventGcEnd(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_GC_END, 0, 0); + traceGcEvent(cap, EVENT_GC_END); dtraceGcEnd((EventCapNo)cap->no); } INLINE_HEADER void traceEventRequestSeqGc(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_REQUEST_SEQ_GC, 0, 0); + traceGcEvent(cap, EVENT_REQUEST_SEQ_GC); dtraceRequestSeqGc((EventCapNo)cap->no); } INLINE_HEADER void traceEventRequestParGc(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_REQUEST_PAR_GC, 0, 0); + traceGcEvent(cap, EVENT_REQUEST_PAR_GC); dtraceRequestParGc((EventCapNo)cap->no); } -INLINE_HEADER void traceEventCreateSparkThread(Capability *cap STG_UNUSED, - StgThreadID spark_tid STG_UNUSED) +INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED) { - traceSchedEvent(cap, EVENT_CREATE_SPARK_THREAD, 0, spark_tid); - dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid); + traceGcEvent(cap, EVENT_GC_IDLE); + dtraceGcIdle((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventGcWork(Capability *cap STG_UNUSED) +{ + traceGcEvent(cap, EVENT_GC_WORK); + dtraceGcWork((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED) +{ + traceGcEvent(cap, EVENT_GC_DONE); + dtraceGcDone((EventCapNo)cap->no); } INLINE_HEADER void traceEventStartup(void) { int n_caps; #ifdef THREADED_RTS - // XXX n_capabilities hasn't been initislised yet + // XXX n_capabilities hasn't been initialised yet n_caps = RtsFlags.ParFlags.nNodes; #else n_caps = 1; @@ -427,24 +465,6 @@ INLINE_HEADER void traceEventStartup(void) dtraceStartup(n_caps); } -INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED) -{ - traceEvent(cap, EVENT_GC_IDLE); - dtraceGcIdle((EventCapNo)cap->no); -} - -INLINE_HEADER void traceEventGcWork(Capability *cap STG_UNUSED) -{ - traceEvent(cap, EVENT_GC_WORK); - dtraceGcWork((EventCapNo)cap->no); -} - -INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED) -{ - traceEvent(cap, EVENT_GC_DONE); - dtraceGcDone((EventCapNo)cap->no); -} - INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED, CapsetType capset_type STG_UNUSED) { @@ -479,6 +499,73 @@ INLINE_HEADER void traceOSProcessInfo(void) * is available to DTrace directly */ } +INLINE_HEADER void traceEventCreateSparkThread(Capability *cap STG_UNUSED, + StgThreadID spark_tid STG_UNUSED) +{ + traceSparkEvent2(cap, EVENT_CREATE_SPARK_THREAD, spark_tid); + dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid); +} + +INLINE_HEADER void traceSparkCounters(Capability *cap STG_UNUSED) +{ +#ifdef THREADED_RTS + if (RTS_UNLIKELY(TRACE_spark_sampled)) { + traceSparkCounters_(cap, cap->spark_stats, sparkPoolSize(cap->sparks)); + } + dtraceSparkCounters((EventCapNo)cap->no, + cap->spark_stats.created, + cap->spark_stats.dud, + cap->spark_stats.overflowed, + cap->spark_stats.converted, + cap->spark_stats.gcd, + cap->spark_stats.fizzled, + sparkPoolSize(cap->sparks)); +#endif +} + +INLINE_HEADER void traceEventSparkCreate(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_CREATE); + dtraceSparkCreate((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkDud(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_DUD); + dtraceSparkDud((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkOverflow(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_OVERFLOW); + dtraceSparkOverflow((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkRun(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_RUN); + dtraceSparkRun((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkSteal(Capability *cap STG_UNUSED, + nat victim_cap STG_UNUSED) +{ + traceSparkEvent2(cap, EVENT_SPARK_STEAL, victim_cap); + dtraceSparkSteal((EventCapNo)cap->no, (EventCapNo)victim_cap); +} + +INLINE_HEADER void traceEventSparkFizzle(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_FIZZLE); + dtraceSparkFizzle((EventCapNo)cap->no); +} + +INLINE_HEADER void traceEventSparkGC(Capability *cap STG_UNUSED) +{ + traceSparkEvent(cap, EVENT_SPARK_GC); + dtraceSparkGc((EventCapNo)cap->no); +} + #include "EndPrivate.h" #endif /* TRACE_H */ diff --git a/rts/WSDeque.c b/rts/WSDeque.c index 090a549709..71633d9fc3 100644 --- a/rts/WSDeque.c +++ b/rts/WSDeque.c @@ -32,7 +32,7 @@ * * Both popWSDeque and stealWSDeque also return NULL when the queue is empty. * - * Testing: see testsuite/tests/ghc-regress/rts/testwsdeque.c. If + * Testing: see testsuite/tests/rts/testwsdeque.c. If * there's anything wrong with the deque implementation, this test * will probably catch it. * diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index cea313e660..db0f3e4ad5 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -60,8 +60,6 @@ char *EventDesc[] = { [EVENT_STOP_THREAD] = "Stop thread", [EVENT_THREAD_RUNNABLE] = "Thread runnable", [EVENT_MIGRATE_THREAD] = "Migrate thread", - [EVENT_RUN_SPARK] = "Run spark", - [EVENT_STEAL_SPARK] = "Steal spark", [EVENT_SHUTDOWN] = "Shutdown", [EVENT_THREAD_WAKEUP] = "Wakeup thread", [EVENT_GC_START] = "Starting GC", @@ -84,7 +82,15 @@ char *EventDesc[] = { [EVENT_PROGRAM_ARGS] = "Program arguments", [EVENT_PROGRAM_ENV] = "Program environment variables", [EVENT_OSPROCESS_PID] = "Process ID", - [EVENT_OSPROCESS_PPID] = "Parent process ID" + [EVENT_OSPROCESS_PPID] = "Parent process ID", + [EVENT_SPARK_COUNTERS] = "Spark counters", + [EVENT_SPARK_CREATE] = "Spark create", + [EVENT_SPARK_DUD] = "Spark dud", + [EVENT_SPARK_OVERFLOW] = "Spark overflow", + [EVENT_SPARK_RUN] = "Spark run", + [EVENT_SPARK_STEAL] = "Spark steal", + [EVENT_SPARK_FIZZLE] = "Spark fizzle", + [EVENT_SPARK_GC] = "Spark GC", }; // Event type. @@ -95,7 +101,7 @@ typedef struct _EventType { char *desc; // Description } EventType; -EventType eventTypes[NUM_EVENT_TAGS]; +EventType eventTypes[NUM_GHC_EVENT_TAGS]; static void initEventsBuf(EventsBuf* eb, StgWord64 size, EventCapNo capno); static void resetEventsBuf(EventsBuf* eb); @@ -194,7 +200,7 @@ initEventLogging(void) + 10 /* .eventlog */, "initEventLogging"); - if (sizeof(EventDesc) / sizeof(char*) != NUM_EVENT_TAGS) { + if (sizeof(EventDesc) / sizeof(char*) != NUM_GHC_EVENT_TAGS) { barf("EventDesc array has the wrong number of elements"); } @@ -244,7 +250,7 @@ initEventLogging(void) // Mark beginning of event types in the header. postInt32(&eventBuf, EVENT_HET_BEGIN); - for (t = 0; t < NUM_EVENT_TAGS; ++t) { + for (t = 0; t < NUM_GHC_EVENT_TAGS; ++t) { eventTypes[t].etNum = t; eventTypes[t].desc = EventDesc[t]; @@ -253,13 +259,11 @@ initEventLogging(void) case EVENT_CREATE_THREAD: // (cap, thread) case EVENT_RUN_THREAD: // (cap, thread) case EVENT_THREAD_RUNNABLE: // (cap, thread) - case EVENT_RUN_SPARK: // (cap, thread) case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) eventTypes[t].size = sizeof(EventThreadID); break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) - case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) case EVENT_THREAD_WAKEUP: // (cap, thread, other_cap) eventTypes[t].size = sizeof(EventThreadID) + sizeof(EventCapNo); @@ -295,6 +299,11 @@ initEventLogging(void) sizeof(EventCapsetID) + sizeof(StgWord32); break; + case EVENT_SPARK_STEAL: // (cap, victim_cap) + eventTypes[t].size = + sizeof(EventCapNo); + break; + case EVENT_SHUTDOWN: // (cap) case EVENT_REQUEST_SEQ_GC: // (cap) case EVENT_REQUEST_PAR_GC: // (cap) @@ -303,6 +312,12 @@ initEventLogging(void) case EVENT_GC_IDLE: case EVENT_GC_WORK: case EVENT_GC_DONE: + case EVENT_SPARK_CREATE: // (cap) + case EVENT_SPARK_DUD: // (cap) + case EVENT_SPARK_OVERFLOW: // (cap) + case EVENT_SPARK_RUN: // (cap) + case EVENT_SPARK_FIZZLE: // (cap) + case EVENT_SPARK_GC: // (cap) eventTypes[t].size = 0; break; @@ -314,6 +329,10 @@ initEventLogging(void) eventTypes[t].size = 0xffff; break; + case EVENT_SPARK_COUNTERS: // (cap, 7*counter) + eventTypes[t].size = 7 * sizeof(StgWord64); + break; + case EVENT_BLOCK_MARKER: eventTypes[t].size = sizeof(StgWord32) + sizeof(EventTimestamp) + sizeof(EventCapNo); @@ -435,7 +454,6 @@ postSchedEvent (Capability *cap, case EVENT_CREATE_THREAD: // (cap, thread) case EVENT_RUN_THREAD: // (cap, thread) case EVENT_THREAD_RUNNABLE: // (cap, thread) - case EVENT_RUN_SPARK: // (cap, thread) { postThreadID(eb,thread); break; @@ -448,7 +466,6 @@ postSchedEvent (Capability *cap, } case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) - case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) case EVENT_THREAD_WAKEUP: // (cap, thread, other_cap) { postThreadID(eb,thread); @@ -465,19 +482,83 @@ postSchedEvent (Capability *cap, } case EVENT_SHUTDOWN: // (cap) - case EVENT_REQUEST_SEQ_GC: // (cap) - case EVENT_REQUEST_PAR_GC: // (cap) - case EVENT_GC_START: // (cap) - case EVENT_GC_END: // (cap) { break; } default: - barf("postEvent: unknown event tag %d", tag); + barf("postSchedEvent: unknown event tag %d", tag); + } +} + +void +postSparkEvent (Capability *cap, + EventTypeNum tag, + StgWord info1) +{ + EventsBuf *eb; + + eb = &capEventBuf[cap->no]; + + if (!hasRoomForEvent(eb, tag)) { + // Flush event buffer to make room for new event. + printAndClearEventBuf(eb); + } + + postEventHeader(eb, tag); + + switch (tag) { + case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) + { + postThreadID(eb,info1 /* spark_thread */); + break; + } + + case EVENT_SPARK_STEAL: // (cap, victim_cap) + { + postCapNo(eb,info1 /* victim_cap */); + break; + } + + case EVENT_SPARK_CREATE: // (cap) + case EVENT_SPARK_DUD: // (cap) + case EVENT_SPARK_OVERFLOW: // (cap) + case EVENT_SPARK_RUN: // (cap) + case EVENT_SPARK_FIZZLE: // (cap) + case EVENT_SPARK_GC: // (cap) + { + break; + } + + default: + barf("postSparkEvent: unknown event tag %d", tag); } } +void +postSparkCountersEvent (Capability *cap, + SparkCounters counters, + StgWord remaining) +{ + EventsBuf *eb; + + eb = &capEventBuf[cap->no]; + + if (!hasRoomForEvent(eb, EVENT_SPARK_COUNTERS)) { + // Flush event buffer to make room for new event. + printAndClearEventBuf(eb); + } + + postEventHeader(eb, EVENT_SPARK_COUNTERS); + postWord64(eb,counters.created); + postWord64(eb,counters.dud); + postWord64(eb,counters.overflowed); + postWord64(eb,counters.converted); + postWord64(eb,counters.gcd); + postWord64(eb,counters.fizzled); + postWord64(eb,remaining); +} + void postCapsetModifyEvent (EventTypeNum tag, EventCapsetID capset, StgWord32 other) diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h index 602ac2c87b..6bb1404e92 100644 --- a/rts/eventlog/EventLog.h +++ b/rts/eventlog/EventLog.h @@ -69,6 +69,18 @@ void postCapsetVecEvent (EventTypeNum tag, int argc, char *msg[]); +/* + * Post a `par` spark event + */ +void postSparkEvent(Capability *cap, EventTypeNum tag, StgWord info1); + +/* + * Post an event with several counters relating to `par` sparks. + */ +void postSparkCountersEvent (Capability *cap, + SparkCounters counters, + StgWord remaining); + #else /* !TRACING */ INLINE_HEADER void postSchedEvent (Capability *cap STG_UNUSED, diff --git a/rts/ghc.mk b/rts/ghc.mk index 38ddbc0d46..5ae873a46a 100644 --- a/rts/ghc.mk +++ b/rts/ghc.mk @@ -45,12 +45,8 @@ rts_CMM_SRCS := $(wildcard rts/*.cmm) # Don't compile .S files when bootstrapping a new arch ifneq "$(PORTING_HOST)" "YES" -ifneq "$(findstring $(TargetArch_CPP), powerpc powerpc64)" "" +ifneq "$(findstring $(TargetArch_CPP), i386 powerpc powerpc64)" "" rts_S_SRCS += rts/AdjustorAsm.S -else -ifneq "$(findstring $(TargetOS_CPP), darwin)" "" -rts_S_SRCS += rts/AdjustorAsm.S -endif endif endif diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 51eab4e2be..2252cfcd63 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -171,17 +171,22 @@ StgPtr mark_sp; // pointer to the next unallocated mark stack entry void GarbageCollect (rtsBool force_major_gc, + rtsBool do_heap_census, nat gc_type USED_IF_THREADS, Capability *cap) { bdescr *bd; generation *gen; lnat live_blocks, live_words, allocated, max_copied, avg_copied; +#if defined(THREADED_RTS) gc_thread *saved_gct; +#endif nat g, n; // necessary if we stole a callee-saves register for gct: +#if defined(THREADED_RTS) saved_gct = gct; +#endif #ifdef PROFILING CostCentreStack *prev_CCS; @@ -657,6 +662,17 @@ GarbageCollect (rtsBool force_major_gc, // fill slop. IF_DEBUG(sanity, checkSanity(rtsTrue /* after GC */, major_gc)); + // If a heap census is due, we need to do it before + // resurrectThreads(), for the same reason as checkSanity above: + // resurrectThreads() will overwrite some closures and leave slop + // behind. + if (do_heap_census) { + debugTrace(DEBUG_sched, "performing heap census"); + RELEASE_SM_LOCK; + heapCensus(gct->gc_start_cpu); + ACQUIRE_SM_LOCK; + } + // send exceptions to any threads which were about to die RELEASE_SM_LOCK; resurrectThreads(resurrected_threads); @@ -956,7 +972,7 @@ any_work (void) static void scavenge_until_all_done (void) { - nat r; + DEBUG_ONLY( nat r ); loop: @@ -973,8 +989,13 @@ loop: collect_gct_blocks(); // scavenge_loop() only exits when there's no work to do + +#ifdef DEBUG r = dec_running(); - +#else + dec_running(); +#endif + traceEventGcIdle(gct->cap); debugTrace(DEBUG_gc, "%d GC threads still running", r); @@ -1400,8 +1421,10 @@ mark_root(void *user USED_IF_THREADS, StgClosure **root) // so we need to save and restore it here. NB. only call // mark_root() from the main GC thread, otherwise gct will be // incorrect. +#if defined(THREADED_RTS) gc_thread *saved_gct; saved_gct = gct; +#endif SET_GCT(user); evacuate(root); diff --git a/rts/sm/GC.h b/rts/sm/GC.h index 38fc87ca44..eb1802338b 100644 --- a/rts/sm/GC.h +++ b/rts/sm/GC.h @@ -16,7 +16,9 @@ #include "BeginPrivate.h" -void GarbageCollect(rtsBool force_major_gc, nat gc_type, Capability *cap); +void GarbageCollect (rtsBool force_major_gc, + rtsBool do_heap_census, + nat gc_type, Capability *cap); typedef void (*evac_fn)(void *user, StgClosure **root); diff --git a/rts/sm/GCUtils.c b/rts/sm/GCUtils.c index ef8d0bd56d..677998ff14 100644 --- a/rts/sm/GCUtils.c +++ b/rts/sm/GCUtils.c @@ -91,9 +91,6 @@ bdescr * grab_local_todo_block (gen_workspace *ws) { bdescr *bd; - generation *gen; - - gen = ws->gen; bd = ws->todo_overflow; if (bd != NULL) @@ -214,8 +211,8 @@ todo_block_full (nat size, gen_workspace *ws) // Otherwise, push this block out to the global list. else { - generation *gen; - gen = ws->gen; + DEBUG_ONLY( generation *gen ); + DEBUG_ONLY( gen = ws->gen ); debugTrace(DEBUG_gc, "push todo block %p (%ld words), step %d, todo_q: %ld", bd->start, (unsigned long)(bd->free - bd->u.scan), gen->no, dequeElements(ws->todo_q)); diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 0ec552c047..b6c5926ab8 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -45,10 +45,8 @@ static void checkSTACK (StgStack *stack); static void checkSmallBitmap( StgPtr payload, StgWord bitmap, nat size ) { - StgPtr p; nat i; - p = payload; for(i = 0; i < size; i++, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { checkClosureShallow((StgClosure *)payload[i]); @@ -211,14 +209,12 @@ static void checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args) { StgClosure *fun; - StgClosure *p; StgFunInfoTable *fun_info; fun = UNTAG_CLOSURE(tagged_fun); ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun)); fun_info = get_fun_itbl(fun); - p = (StgClosure *)payload; switch (fun_info->f.fun_type) { case ARG_GEN: checkSmallBitmap( (StgPtr)payload, diff --git a/rules/build-package.mk b/rules/build-package.mk index c735e5137a..c15a8c5c50 100644 --- a/rules/build-package.mk +++ b/rules/build-package.mk @@ -132,7 +132,9 @@ check_$1: $$(GHC_CABAL_INPLACE) $$(GHC_CABAL_INPLACE) check $1 endif +ifneq "$3" "0" $(call haddock,$1,$2) +endif # Don't put bootstrapping packages in the bindist ifneq "$3" "0" diff --git a/rules/extra-packages.mk b/rules/extra-packages.mk index e3af94f8db..98868b45db 100644 --- a/rules/extra-packages.mk +++ b/rules/extra-packages.mk @@ -27,9 +27,13 @@ # add P to the list of packages define extra-packages + +# Collects some dirs containing ghc.mk files that we need to include: +BUILD_DIRS_EXTRA= + $$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+$$$$' packages | sed 's/ .*//'))),\ $$(if $$(wildcard libraries/$$p/ghc-packages),\ - $$(eval BUILD_DIRS += libraries/$$p) \ + $$(eval BUILD_DIRS_EXTRA += libraries/$$p) \ $$(foreach q,$$(shell cat libraries/$$p/ghc-packages2),$$(eval $$(call extra-package,$$p,$$p/$$q))),\ $$(eval $$(call extra-package,$$p,$$p)))\ ) diff --git a/settings.in b/settings.in index 5d4e1d3a76..6ddeb181e8 100644 --- a/settings.in +++ b/settings.in @@ -1,8 +1,11 @@ [("GCC extra via C opts", "@GccExtraViaCOpts@"), - ("C compiler command", "@WhatGccIsCalled@"), - ("C compiler flags", "@CONF_CC_OPTS_STAGE2@"), + ("C compiler command", "@SettingsCCompilerCommand@"), + ("C compiler flags", "@SettingsCCompilerFlags@"), ("ar command", "@ArCmd@"), ("ar flags", "@ArArgs@"), ("ar supports at file", "@ArSupportsAtFile@"), - ("perl command", "@PerlCmd@")] + ("touch command", "@SettingsTouchCommand@"), + ("dllwrap command", "@SettingsDllWrapCommand@"), + ("windres command", "@SettingsWindresCommand@"), + ("perl command", "@SettingsPerlCommand@")] @@ -3,76 +3,21 @@ use strict; use Cwd; -# Usage: -# -# ./sync-all [-q] [-s] [--ignore-failure] [-r repo] -# [--nofib] [--testsuite] [--checked-out] cmd [git flags] -# -# Applies the command "cmd" to each repository in the tree. -# sync-all will try to do the right thing for both git and darcs repositories. -# -# e.g. -# ./sync-all -r http://darcs.haskell.org/ghc get -# To get any repos which do not exist in the local tree -# -# ./sync-all pull -# To pull everything from the default repos -# -# -------------- Flags ------------------- -# -q says to be quite, and -s to be silent. -# -# --ignore-failure says to ignore errors and move on to the next repository -# -# -r repo says to use repo as the location of package repositories -# -# --checked-out says that the remote repo is in checked-out layout, as -# opposed to the layout used for the main repo. By default a repo on -# the local filesystem is assumed to be checked-out, and repos accessed -# via HTTP or SSH are assumed to be in the main repo layout; use -# --checked-out to override the latter. -# -# --nofib, --testsuite also get the nofib and testsuite repos respectively -# -# ------------ Which repos to use ------------- -# sync-all uses the following algorithm to decide which remote repos to use -# -# It always computes the remote repos from a single base, $repo_base -# How is $repo_base set? -# If you say "-r repo", then that's $repo_base -# otherwise $repo_base is set by asking git where the ghc repo came -# from, and removing the last component (e.g. /ghc.git/ of /ghc/). -# -# Then sync-all iterates over the package found in the file -# ./packages; see that file for a description of the contents. -# -# If $repo_base looks like a local filesystem path, or if you give -# the --checked-out flag, sync-all works on repos of form -# $repo_base/<local-path> -# otherwise sync-all works on repos of form -# $repo_base/<remote-path> -# This logic lets you say -# both sync-all -r http://darcs.haskell.org/ghc-6.12 pull -# and sync-all -r ../HEAD pull -# The latter is called a "checked-out tree". - -# NB: sync-all *ignores* the defaultrepo of all repos other than the -# root one. So the remote repos must be laid out in one of the two -# formats given by <local-path> and <remote-path> in the file 'packages'. - $| = 1; # autoflush stdout after each print, to avoid output after die my $defaultrepo; my @packages; my $verbose = 2; +my $try_to_resume = 0; my $ignore_failure = 0; -my $checked_out_flag = 0; +my $checked_out_flag = 0; # NOT the opposite of bare_flag (describes remote repo state) my $get_mode; +my $bare_flag = ""; # NOT the opposite of checked_out_flag (describes local repo state) my %tags; # Figure out where to get the other repositories from. sub getrepo { - my $basedir = "."; my $repo; if (defined($defaultrepo)) { @@ -81,9 +26,14 @@ sub getrepo { } else { # Figure out where to get the other repositories from, # based on where this GHC repo came from. - my $branch = `git branch | grep "\* " | sed "s/^\* //"`; chomp $branch; - my $remote = `git config branch.$branch.remote`; chomp $remote; - $repo = `git config remote.$remote.url`; chomp $repo; + my $git_dir = $bare_flag ? "--git-dir=ghc.git" : ""; + my $branch = `git $git_dir branch | grep "\* " | sed "s/^\* //"`; chomp $branch; + my $remote = `git $git_dir config branch.$branch.remote`; chomp $remote; + if ($remote eq "") { + # remotes are not mandatory for branches (e.g. not recorded by default for bare repos) + $remote = "origin"; + } + $repo = `git $git_dir config remote.$remote.url`; chomp $repo; } my $repo_base; @@ -117,10 +67,19 @@ sub getrepo { } } elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) { - # Local filesystem, either absolute or relative path - # (assumes a checked-out tree): + # Local filesystem, either absolute (C:/ or /) or relative (../) path $repo_base = $repo; - $checked_out_tree = 1; + if (-f "$repo/HEAD") { + # assume a local mirror: + $checked_out_tree = 0; + $repo_base =~ s#/[^/]+/?$##; + } elsif (-d "$repo/ghc.git") { + # assume a local mirror: + $checked_out_tree = 0; + } else { + # assume a checked-out tree: + $checked_out_tree = 1; + } } else { die "Couldn't work out repo"; @@ -133,7 +92,9 @@ sub parsePackages { my @repos; my $lineNum; - open IN, "< packages" or die "Can't open packages file"; + open IN, "< packages.conf" + or open IN, "< packages" # clashes with packages directory when using --bare + or die "Can't open packages file (or packages.conf)"; @repos = <IN>; close IN; @@ -207,6 +168,10 @@ sub scmall { my $pwd; my @args; + my $started; + my $doing; + my $start_repo; + my ($repo_base, $checked_out_tree) = getrepo(); my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/; @@ -219,16 +184,16 @@ sub scmall { while (@_ > 0 && $_[0] =~ /^-/) { push(@args,shift); } - if (@_ < 1) { help(); } + if (@_ < 1) { help(1); } $subcommand = shift; if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') { - help(); + help(1); } while (@_ > 0 && $_[0] =~ /^-/) { push(@args,shift); } if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) { - help(); + help(1); } elsif (@_ < 1) { # set-url $branch_name = 'origin'; } else { @@ -244,29 +209,59 @@ sub scmall { push(@args, @_); - for $line (@packages) { + # $doing is a good enough approximation to what we are doing that + # we can use it to check that --resume is resuming the right command + $doing = join(" ", ($command, @args)); + $started = 1; + if ($try_to_resume && -f "resume") { + my $what; + open RESUME, "< resume" + or die "Can't open resume file"; + $start_repo = <RESUME>; + chomp $start_repo; + $what = <RESUME>; + chomp $what; + close RESUME; + if ($what eq $doing) { + $started = 0; + } + } - $localpath = $$line{"localpath"}; + for $line (@packages) { $tag = $$line{"tag"}; - $remotepath = $$line{"remotepath"}; $scm = $$line{"vcs"}; + # Use the "remote" structure for bare git repositories + $localpath = ($bare_flag && $scm eq "git") ? + $$line{"remotepath"} : $$line{"localpath"}; + $remotepath = ($checked_out_tree) ? + $$line{"localpath"} : $$line{"remotepath"}; + + if (!$started) { + if ($start_repo eq $localpath) { + $started = 1; + } + else { + next; + } + } + + open RESUME, "> resume.tmp"; + print RESUME "$localpath\n"; + print RESUME "$doing\n"; + close RESUME; + rename "resume.tmp", "resume"; # Check the SCM is OK as early as possible die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git")); # We can't create directories on GitHub, so we translate - # "package/foo" into "package-foo". + # "packages/foo" into "package-foo". if ($is_github_repo) { $remotepath =~ s/\//-/; } - # Work out the path for this package in the repo we pulled from - if ($checked_out_tree) { - $path = "$repo_base/$localpath"; - } - else { - $path = "$repo_base/$remotepath"; - } + # Construct the path for this package in the repo we pulled from + $path = "$repo_base/$remotepath"; if ($command =~ /^(?:g|ge|get)$/) { # Skip any repositories we have not included the tag for @@ -297,18 +292,22 @@ sub scmall { scm (".", $scm, "get", $get_mode, $path, $localpath, @args); } else { - scm (".", $scm, "clone", $path, $localpath, @args); + my @argsWithBare = @args; + push @argsWithBare, $bare_flag if $bare_flag; + scm (".", $scm, "clone", $path, $localpath, @argsWithBare); scm ($localpath, $scm, "config", "core.ignorecase", "true"); } next; } - if (-d "$localpath/_darcs") { - if (-d "$localpath/.git") { + my $darcs_repo_present = 1 if -d "$localpath/_darcs"; + my $git_repo_present = 1 if -d "$localpath/.git" || ($bare_flag && -d "$localpath"); + if ($darcs_repo_present) { + if ($git_repo_present) { die "Found both _darcs and .git in $localpath"; } $scm = "darcs"; - } elsif (-d "$localpath/.git") { + } elsif ($git_repo_present) { $scm = "git"; } elsif ($tag eq "") { die "Required repo $localpath is missing"; @@ -368,6 +367,7 @@ sub scmall { } elsif ($command =~ /^remote$/) { my @scm_args; + $ignore_failure = 1; if ($subcommand eq 'add') { @scm_args = ("remote", "add", $branch_name, $path); } elsif ($subcommand eq 'rm') { @@ -405,43 +405,159 @@ sub scmall { die "Unknown command: $command"; } } -} + unlink "resume"; +} -sub help() +sub help { + my $exit = shift; + # Get the built in help my $help = <<END; -What do you want to do? -Supported commands: - - * whatsnew - * commit - * push - * pull - * get, with options: - * --<package-tag> - * --complete - * --partial - * fetch - * send - * new - * remote add <branch-name> - * remote rm <branch-name> - * remote set-url [--push] <branch-name> - * checkout - * grep - * clean - * reset - * config - * log +Usage: + +./sync-all [-q] [-s] [--ignore-failure] [-r repo] [--checked-out] [--bare] + [--nofib] [--extra] [--testsuite] [--resume] cmd [git flags] + +Applies the command "cmd" to each repository in the tree. + +A full repository tree is obtained by first cloning the ghc +repository, then getting the subrepositories with "sync-all get": + + \$ git clone http://darcs.haskell.org/ghc.git + \$ cd ghc + \$ ./sync-all get + +After this, "./sync-all pull" will pull from the original repository +tree. + +A remote pointing to another local repository tree can be added like +this: + + \$ ./sync-all -r /path/to/ghc remote add otherlocal + +and then we can pull from this other tree with + + \$ ./sync-all pull otherlocal + +-------------- Commands ----------------- +get + + Clones all sub-repositories from the same place that the ghc + repository was cloned from. See "which repos to use" below + for details of how the subrepositories are laid out. + + There are various --<package-tag> options that can be given + before "get" that enable extra repositories. The full list is + given at the end of this help. For example: + + ./sync-all --testsuite get + + would get the testsuite repository in addition to the usual set of + subrepositories. + +remote add <remote-name> +remote rm <remote-name> +remote set-url [--push] <remote-name> + + Runs a "git remote" command on each subrepository, adjusting the + repository location in each case appropriately. For example, to + add a new remote pointing to the upstream repositories: + + ./sync-all -r http://darcs.haskell.org/ remote add upstream + + The -r flag points to the root of the repository tree (see "which + repos to use" below). For a repository on the local filesystem it + would point to the ghc reposiroty, and for a remote repository it + points to the directory containing "ghc.git". + +These commands just run the equivalent git command on each repository, passing +any extra arguments to git: + + checkout + clean + commit + config + fetch + grep + log + new + pull + push + reset + send + status + +-------------- Flags ------------------- + These flags are given *before* the command and modify the way + sync-all behaves. Flags given *after* the command are passed to + git. + + -q says to be quite, and -s to be silent. + + --resume will restart a command that failed, from the repo at which + it failed. This means you don't need to wait while, e.g., "pull" + goes through all the repos it's just pulled, and tries to pull them + again. + + --ignore-failure says to ignore errors and move on to the next repository + + -r repo says to use repo as the location of package repositories + + --checked-out says that the remote repo is in checked-out layout, as + opposed to the layout used for the main repo. By default a repo on + the local filesystem is assumed to be checked-out, and repos accessed + via HTTP or SSH are assumed to be in the main repo layout; use + --checked-out to override the latter. + + --bare says that the local repo is in bare layout, same as the main repo. + It also means that these repos are bare. You only have to use this flag if + you don't have a bare ghc.git in the current directory and would like to 'get' + all of the repos bare. Requires packages.conf to be present in the current + directory (a renamed packages file from the main ghc repo). + + Note: --cheched-out and --bare flags are NOT the opposite of each other. + --checked-out: describes the layout of the remote repository tree. + --bare: describes the layout of the local repository tree. + + --nofib, --testsuite also get the nofib and testsuite repos respectively + + +------------ Which repos to use ------------- + sync-all uses the following algorithm to decide which remote repos to use + + It always computes the remote repos from a single base, <repo_base> + How is <repo_base> set? + If you say "-r repo", then that's <repo_base> + otherwise <repo_base> is set by asking git where the ghc repo came + from, and removing the last component (e.g. /ghc.git/ or /ghc/). + + Then sync-all iterates over the package found in the file + ./packages; see that file for a description of the contents. + + If <repo_base> looks like a local filesystem path, or if you give + the --checked-out flag, sync-all works on repos of form + <repo_base>/<local-path> + otherwise sync-all works on repos of form + <repo_base>/<remote-path> + This logic lets you say + both sync-all -r http://darcs.haskell.org/ghc-6.12 remote add ghc-6.12 + and sync-all -r ../working remote add working + The latter is called a "checked-out tree". + + NB: sync-all *ignores* the defaultrepo of all repos other than the + root one. So the remote repos must be laid out in one of the two + formats given by <local-path> and <remote-path> in the file 'packages'. Available package-tags are: END # Collect all the tags in the packages file my %available_tags; - open IN, "< packages" or die "Can't open packages file"; + open IN, "< packages.conf" + or open IN, "< packages" # clashes with packages directory when using --bare + or die "Can't open packages file (or packages.conf)"; while (<IN>) { chomp; if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) { @@ -457,14 +573,11 @@ END # Show those tags and the help text my @available_tags = keys %available_tags; - print "$help@available_tags\n"; - exit 1; + print "$help@available_tags\n\n"; + exit $exit; } sub main { - if (! -d ".git" || ! -d "compiler") { - die "error: sync-all must be run from the top level of the ghc tree." - } $tags{"-"} = 1; $tags{"dph"} = 1; @@ -482,17 +595,28 @@ sub main { elsif ($arg eq "-r") { $defaultrepo = shift; } + elsif ($arg eq "--resume") { + $try_to_resume = 1; + } elsif ($arg eq "--ignore-failure") { $ignore_failure = 1; } elsif ($arg eq "--complete" || $arg eq "--partial") { $get_mode = $arg; } - # Use --checked-out if the remote repos are a checked-out tree, + # Use --checked-out if the _remote_ repos are a checked-out tree, # rather than the master trees. elsif ($arg eq "--checked-out") { $checked_out_flag = 1; } + # Use --bare if the _local_ repos are bare repos, + # rather than a checked-out tree. + elsif ($arg eq "--bare") { + $bare_flag = $arg; + } + elsif ($arg eq "--help") { + help(0); + } # --<tag> says we grab the libs tagged 'tag' with # 'get'. It has no effect on the other commands. elsif ($arg =~ m/^--no-(.*)$/) { @@ -510,8 +634,24 @@ sub main { } } + # check for ghc repositories in cwd + my $checked_out_found = 1 if (-d ".git" && -d "compiler"); + my $bare_found = 1 if (-d "ghc.git"); + + if ($bare_flag && ! $bare_found && ! $defaultrepo) { + die "error: bare repository ghc.git not found.\n" + . " Either clone a bare ghc repo first or specify the repo location. E.g.:\n" + . " ./sync-all --bare [--testsuite --nofib --extra] -r http://darcs.haskell.org/ get\n" + } + elsif ($bare_found) { + $bare_flag = "--bare"; + } + elsif (! $bare_flag && ! $checked_out_found) { + die "error: sync-all must be run from the top level of the ghc tree."; + } + if ($#_ eq -1) { - help(); + help(1); } else { # Give the command and rest of the arguments to the main loop diff --git a/utils/fingerprint/fingerprint.py b/utils/fingerprint/fingerprint.py index f04b98ecd4..5a753279e6 100755 --- a/utils/fingerprint/fingerprint.py +++ b/utils/fingerprint/fingerprint.py @@ -159,7 +159,7 @@ def validate(opts, args, parser): if opts.dir: fname = opts.output if fname is None: - fname = datetime.today().strftime("%Y-%m%-%d_%H-%M-%S") + ".fp" + fname = datetime.today().strftime("%Y-%m-%d_%H-%M-%S") + ".fp" path = os.path.join(opts.dir, fname) opts.output_file = path opts.output = file(path, "w") diff --git a/utils/ghc-cabal/ghc-cabal.cabal b/utils/ghc-cabal/ghc-cabal.cabal index cd8d550c2e..55a4a188ad 100644 --- a/utils/ghc-cabal/ghc-cabal.cabal +++ b/utils/ghc-cabal/ghc-cabal.cabal @@ -16,7 +16,7 @@ Executable ghc-cabal Main-Is: ghc-cabal.hs Build-Depends: base >= 3 && < 5, - Cabal >= 1.10 && < 1.12, + Cabal >= 1.10 && < 1.14, directory >= 1.1 && < 1.2, filepath >= 1.2 && < 1.3 diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk index 9026eb18a8..39a26f07d3 100644 --- a/utils/ghc-cabal/ghc.mk +++ b/utils/ghc-cabal/ghc.mk @@ -14,16 +14,16 @@ # Euch, hideous hack: # XXX This should be in a different Makefile -CABAL_DOTTED_VERSION := $(shell grep "^Version:" libraries/Cabal/Cabal.cabal | sed "s/^Version: //") +CABAL_DOTTED_VERSION := $(shell grep "^Version:" libraries/Cabal/cabal/Cabal.cabal | sed "s/^Version: //") CABAL_VERSION := $(subst .,$(comma),$(CABAL_DOTTED_VERSION)) CABAL_CONSTRAINT := --constraint="Cabal == $(CABAL_DOTTED_VERSION)" $(GHC_CABAL_INPLACE) : $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext) | $$(dir $$@)/. "$(CP)" $< $@ -$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Distribution/*/*/*.hs) -$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Distribution/*/*.hs) -$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Distribution/*.hs) +$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/cabal/Distribution/*/*/*.hs) +$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/cabal/Distribution/*/*.hs) +$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/cabal/Distribution/*.hs) $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs | $$(dir $$@)/. bootstrapping/. "$(GHC)" $(SRC_HC_OPTS) --make $(GHC_CABAL_DIR)/Main.hs -o $@ \ @@ -32,9 +32,10 @@ $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs | $ -DCABAL_VERSION=$(CABAL_VERSION) \ -odir bootstrapping \ -hidir bootstrapping \ - -ilibraries/Cabal \ + -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/ghc-pkg/ghc-pkg.cabal b/utils/ghc-pkg/ghc-pkg.cabal index a0f3c36e1d..4f96dcc4ba 100644 --- a/utils/ghc-pkg/ghc-pkg.cabal +++ b/utils/ghc-pkg/ghc-pkg.cabal @@ -20,7 +20,7 @@ Executable ghc-pkg Build-Depends: base >= 4 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, filepath, Cabal, binary, diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk index 6bc9be57a4..03c9523e37 100644 --- a/utils/ghc-pkg/ghc.mk +++ b/utils/ghc-pkg/ghc.mk @@ -58,7 +58,7 @@ utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main -hidir bootstrapping \ -iutils/ghc-pkg \ -XCPP -XExistentialQuantification -XDeriveDataTypeable \ - -ilibraries/Cabal \ + -ilibraries/Cabal/cabal \ -ilibraries/filepath \ -ilibraries/extensible-exceptions \ -ilibraries/hpc \ diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 4ba8157dcc..fafd63eabb 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -11,7 +11,7 @@ import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) import Panic ( panic ) -import DynFlags ( defaultDynFlags ) +import DynFlags ( defaultLogAction ) import Bag import Exception import FastString @@ -102,7 +102,7 @@ main = do then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler (defaultDynFlags (panic "No settings")) $ + GHC.defaultErrorHandler defaultLogAction $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags diff --git a/utils/lndir/lndir.c b/utils/lndir/lndir.c index bfce2b515e..8269f6ec9e 100644 --- a/utils/lndir/lndir.c +++ b/utils/lndir/lndir.c @@ -324,6 +324,8 @@ int rel; /* if true, prepend "../" to fn before using */ continue; if (!strcmp (dp->d_name, ".svn")) continue; + if (!strcmp (dp->d_name, ".git")) + continue; if (!strcmp (dp->d_name, "_darcs")) continue; if (!strcmp (dp->d_name, "CVS.adm")) diff --git a/utils/runghc/runghc.cabal.in b/utils/runghc/runghc.cabal.in index 7dfdc97a5d..3bab879c91 100644 --- a/utils/runghc/runghc.cabal.in +++ b/utils/runghc/runghc.cabal.in @@ -21,7 +21,7 @@ Executable runghc if flag(base3) Build-Depends: base >= 3 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1 + process >= 1 && < 1.2 else Build-Depends: base < 3 Build-Depends: filepath @@ -45,6 +45,13 @@ do shift done +if ! [ -d testsuite ] +then + echo 'You need the testsuite to validate' >&2 + echo 'Run "./sync-all --testsuite get" to get it' >&2 + exit 1 +fi + if [ "$THREADS" = "" ]; then if [ "$CPUS" = "" ]; then threads=2 @@ -147,7 +154,7 @@ the minimal testing procedure, please do further testing as necessary. When you are satisfied that you haven't broken anything, go ahead and push/send your patches. EOF - if grep -q "^[^#]" mk/validate.mk + if [ -f mk/validate.mk ] && grep -q "^[^#]" mk/validate.mk then cat <<EOF |