.gitignore

 # -----------------------------------------------------------------------------
 # 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

ANNOUNCE

 
-   ==============================================================
-    The (Interactive) Glasgow Haskell Compiler -- version 6.10.1
-   ==============================================================
+   =============================================================
+    The (Interactive) Glasgow Haskell Compiler -- version 7.2.1
+   =============================================================
 
-The GHC Team is pleased to announce a new major release of GHC. There
-have been a number of significant changes since the last major release,
-including:
+The GHC Team is pleased to announce a new major release of GHC, 7.2.1.
 
- * Some new language features have been implemented:
-   * Record syntax: wild-card patterns, punning, and field disambiguation
-   * Generalised quasi-quotes
-   * Generalised list comprehensions
-   * View patterns
+The 7.2 branch is intended to be more of a "technology preview" than
+normal GHC stable branches; in particular, it supports a significantly
+improved version of DPH, as well as new features such as compiler
+plugins and "safe Haskell". The design of these new features may evolve
+as we get more experience with them. See the release notes for more
+details of what's new and what's changed.
 
- * Type families have been completely re-implemented
+We are also using this branch as an opportunity to work out the best
+workflows to use with git.
 
- * Now comes with Haddock 2, which supports all GHC extensions
+We expect the 7.2 branch to be short-lived, with 7.4.1 coming out
+shortly after ICFP as normal.
 
- * Parallel garbage collection
 
- * Base provides extensible exceptions
+Full release notes are here:
 
- * The GHC API is easier to use
-
- * External core (output only) now works again
-
- * Data Parallel Haskell (DPH) comes as part of GHC
-
-The full release notes are here:
-
-  http://haskell.org/ghc/docs/6.10.1/html/users_guide/release-6-10-1.html
+  http://www.haskell.org/ghc/docs/7.2.1/html/users_guide/release-7-2-1.html
 
 How to get it
 ~~~~~~~~~~~~~

Makefile

@@ -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
 

aclocal.m4

@@ -1523,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"
@@ -1567,13 +1570,59 @@ fi
 AC_SUBST($1)
 ])
 
-# LIBRARY_VERSION(lib)
+# LIBRARY_VERSION(lib, [dir])
 # --------------------------------
 # Gets the version number of a library.
 # If $1 is ghc-prim, then we define LIBRARY_ghc_prim_VERSION as 1.2.3
+# $2 points to the directory under libraries/
 AC_DEFUN([LIBRARY_VERSION],[
-LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/$1/$1.cabal | sed "s/.* //"`
+dir=m4_default([$2],[$1])
+LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/${dir}/$1.cabal | sed "s/.* //"`
 AC_SUBST(LIBRARY_[]translit([$1], [-], [_])[]_VERSION)
 ])
 
+# XCODE_VERSION()
+# --------------------------------
+# Gets the version number of XCode, if on a Mac
+AC_DEFUN([XCODE_VERSION],[
+    if test "$TargetOS_CPP" = "darwin"
+    then
+        AC_MSG_CHECKING(XCode version)
+        XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"`
+        # Old XCode versions don't actually give the XCode version
+        if test "$XCodeVersion" = ""
+        then
+            AC_MSG_RESULT(not found (too old?))
+            XCodeVersion1=0
+            XCodeVersion2=0
+        else
+            AC_MSG_RESULT($XCodeVersion)
+            XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'`
+            changequote(, )dnl
+            XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'`
+            changequote([, ])dnl
+            AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1)
+            AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2)
+        fi
+    fi
+])
+
+# FIND_GCC()
+# --------------------------------
+# Finds where gcc is
+AC_DEFUN([FIND_GCC],[
+    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)
+])
+
 # LocalWords:  fi

boot

@@ -174,7 +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},\$(STAGE0_PACKAGES)),\$(eval \$(call build-package,${package},dist-boot,0)))\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: $!";

compiler/HsVersions.h

@@ -36,19 +36,19 @@ you will screw up the layout where they are used in case expressions!
 name :: IORef (ty);                \
 name = Util.global (value);
 
-#define GLOBAL_MVAR(name,value,ty) \
-{-# NOINLINE name #-};             \
-name :: MVar (ty);                 \
-name = Util.globalMVar (value);
+#define GLOBAL_VAR_M(name,value,ty) \
+{-# NOINLINE name #-};              \
+name :: IORef (ty);                 \
+name = Util.globalM (value);
 #endif
 #else /* __HADDOCK__ */
 #define GLOBAL_VAR(name,value,ty)  \
 name :: IORef (ty);                \
 name = Util.global (value);
 
-#define GLOBAL_MVAR(name,value,ty) \
-name :: MVar (ty);                 \
-name = Util.globalMVar (value);
+#define GLOBAL_VAR_M(name,value,ty) \
+name :: IORef (ty);                 \
+name = Util.globalM (value);
 #endif
 
 #define COMMA ,

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,
@@ -94,6 +96,16 @@ import Data.Function (on)
 type Arity = Int
 \end{code}
 
+%************************************************************************
+%*									*
+\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

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"

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
 

compiler/basicTypes/IdInfo.lhs

@@ -38,7 +38,7 @@ module IdInfo (
 
 	-- ** The OccInfo type
 	OccInfo(..),
-	isDeadOcc, isLoopBreaker,
+	isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker,
 	occInfo, setOccInfo,
 
 	InsideLam, OneBranch,

compiler/basicTypes/MkId.lhs

@@ -584,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
 

compiler/basicTypes/Name.lhs

@@ -57,7 +57,7 @@ module Name (
 	isValName, isVarName,
 	isWiredInName, isBuiltInSyntax,
 	wiredInNameTyThing_maybe, 
-	nameIsLocalOrFrom,
+	nameIsLocalOrFrom, stableNameCmp,
 
 	-- * Class 'NamedThing' and overloaded friends
 	NamedThing(..),
@@ -341,6 +341,26 @@ hashName name = getKey (nameUnique name) + 1
 
 cmpName :: Name -> Name -> Ordering
 cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2)
+
+stableNameCmp :: Name -> Name -> Ordering
+-- Compare lexicographically
+stableNameCmp (Name { n_sort = s1, n_occ = occ1 })
+	      (Name { n_sort = s2, n_occ = occ2 })
+  = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2)
+    -- The ordinary compare on OccNames is lexicogrpahic
+  where
+    -- Later constructors are bigger
+    sort_cmp (External m1) (External m2)       = m1 `stableModuleCmp` m2
+    sort_cmp (External {}) _                   = LT
+    sort_cmp (WiredIn {}) (External {})        = GT
+    sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2
+    sort_cmp (WiredIn {})     _                = LT
+    sort_cmp Internal         (External {})    = GT
+    sort_cmp Internal         (WiredIn {})     = GT
+    sort_cmp Internal         Internal         = EQ
+    sort_cmp Internal         System           = LT
+    sort_cmp System           System           = EQ
+    sort_cmp System           _                = GT
 \end{code}
 
 %************************************************************************

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

compiler/basicTypes/RdrName.lhs

@@ -320,7 +320,6 @@ extendLocalRdrEnvList env names
   = extendOccEnvList env [(nameOccName n, n) | n <- names]
 
 lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
-lookupLocalRdrEnv _   (Exact name) = Just name
 lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ
 lookupLocalRdrEnv _   _            = Nothing
 
@@ -391,7 +390,8 @@ globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]
 globalRdrEnvElts env = foldOccEnv (++) [] env
 
 instance Outputable GlobalRdrElt where
-  ppr gre = ppr name <+> parens (ppr (gre_par gre) <+> pprNameProvenance gre)
+  ppr gre = hang (ppr name)
+               2 (parens (ppr (gre_par gre) <+> pprNameProvenance gre))
 	  where
 	    name = gre_name gre
 

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,24 @@ 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 +375,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

compiler/cmm/CLabel.hs

@@ -65,6 +65,7 @@ module CLabel (
 
 	mkTopTickyCtrLabel,
         mkCAFBlackHoleInfoTableLabel,
+        mkCAFBlackHoleEntryLabel,
 	mkRtsPrimOpLabel,
 	mkRtsSlowTickyCtrLabel,
 
@@ -99,7 +100,7 @@ module CLabel (
         mkHpcTicksLabel,
 
         hasCAF,
-	infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
+	cvtToClosureLbl,
 	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	        -- ^ Entry point
   | Slow		-- ^ Slow entry point
 
   | RednCounts		-- ^ Label of place to keep Ticky-ticky  info for this Id
@@ -356,12 +360,12 @@ mkRednCountsLabel     	name c 	= IdLabel name  c RednCounts
 
 -- These have local & (possibly) external variants:
 mkLocalClosureLabel	name c 	= IdLabel name  c Closure
-mkLocalInfoTableLabel  	name c 	= IdLabel name  c InfoTable
+mkLocalInfoTableLabel  	name c 	= IdLabel name  c (InfoTable True)
 mkLocalEntryLabel	name c 	= IdLabel name  c Entry
 mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable
 
 mkClosureLabel name         c     = IdLabel name c Closure
-mkInfoTableLabel name       c     = IdLabel name c InfoTable
+mkInfoTableLabel name       c     = IdLabel name c (InfoTable False)
 mkEntryLabel name           c     = IdLabel name c Entry
 mkClosureTableLabel name    c     = IdLabel name c ClosureTable
 mkLocalConInfoTableLabel    c con = IdLabel con c ConInfoTable
@@ -386,6 +390,7 @@ mkMAP_DIRTY_infoLabel		= CmmLabel rtsPackageId (fsLit "stg_MUT_ARR_PTRS_DIRTY")
 mkEMPTY_MVAR_infoLabel		= CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR")	CmmInfo
 mkTopTickyCtrLabel		= CmmLabel rtsPackageId (fsLit "top_ct")		CmmData
 mkCAFBlackHoleInfoTableLabel	= CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE")	CmmInfo
+mkCAFBlackHoleEntryLabel	= CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE")	CmmEntry
 
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
@@ -495,32 +500,10 @@ mkPlainModuleInitLabel :: Module -> CLabel
 mkPlainModuleInitLabel mod	= PlainModuleInitLabel mod
 
 -- -----------------------------------------------------------------------------
--- Converting between info labels and entry/ret labels.
-
-infoLblToEntryLbl :: CLabel -> CLabel 
-infoLblToEntryLbl (IdLabel n c InfoTable)	= IdLabel n c Entry
-infoLblToEntryLbl (IdLabel n c ConInfoTable)	= IdLabel n c ConEntry
-infoLblToEntryLbl (IdLabel n c StaticInfoTable)	= IdLabel n c StaticConEntry
-infoLblToEntryLbl (CaseLabel n CaseReturnInfo)	= CaseLabel n CaseReturnPt
-infoLblToEntryLbl (CmmLabel m str CmmInfo)	= CmmLabel m str CmmEntry
-infoLblToEntryLbl (CmmLabel m str CmmRetInfo)	= CmmLabel m str CmmRet
-infoLblToEntryLbl _
-	= panic "CLabel.infoLblToEntryLbl"
-
-
-entryLblToInfoLbl :: CLabel -> CLabel 
-entryLblToInfoLbl (IdLabel n c Entry)		= IdLabel n c InfoTable
-entryLblToInfoLbl (IdLabel n c ConEntry)	= IdLabel n c ConInfoTable
-entryLblToInfoLbl (IdLabel n c StaticConEntry)	= IdLabel n c StaticInfoTable
-entryLblToInfoLbl (CaseLabel n CaseReturnPt)	= CaseLabel n CaseReturnInfo
-entryLblToInfoLbl (CmmLabel m str CmmEntry)	= CmmLabel m str CmmInfo
-entryLblToInfoLbl (CmmLabel m str CmmRet)	= CmmLabel m str CmmRetInfo
-entryLblToInfoLbl l				
-	= pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
-
-
-cvtToClosureLbl   (IdLabel n c InfoTable)	= IdLabel n c Closure
-cvtToClosureLbl   (IdLabel n c Entry)		= IdLabel n c Closure
+-- Brutal method of obtaining a closure label
+
+cvtToClosureLbl   (IdLabel n c (InfoTable _))	= IdLabel n c Closure
+cvtToClosureLbl   (IdLabel n c Entry)	        = IdLabel n c Closure
 cvtToClosureLbl   (IdLabel n c ConEntry)	= IdLabel n c Closure
 cvtToClosureLbl   (IdLabel n c RednCounts)	= IdLabel n c Closure
 cvtToClosureLbl l@(IdLabel n c Closure)		= l
@@ -528,14 +511,6 @@ cvtToClosureLbl l
 	= pprPanic "cvtToClosureLbl" (pprCLabel l)
 
 
-cvtToSRTLbl   (IdLabel n c InfoTable)		= mkSRTLabel n c
-cvtToSRTLbl   (IdLabel n c Entry)		= mkSRTLabel n c
-cvtToSRTLbl   (IdLabel n c ConEntry)		= mkSRTLabel n c
-cvtToSRTLbl l@(IdLabel n c Closure)		= mkSRTLabel n c
-cvtToSRTLbl l 
-	= pprPanic "cvtToSRTLbl" (pprCLabel l)
-
-
 -- -----------------------------------------------------------------------------
 -- Does a CLabel refer to a CAF?
 hasCAF :: CLabel -> Bool
@@ -691,7 +666,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 +674,11 @@ externallyVisibleCLabel (HpcTicksLabel _)	= True
 externallyVisibleCLabel (LargeBitmapLabel _)    = False
 externallyVisibleCLabel (LargeSRTLabel _)	= False
 
+externallyVisibleIdLabel :: IdLabelInfo -> Bool
+externallyVisibleIdLabel SRT             = False
+externallyVisibleIdLabel (InfoTable lcl) = not lcl
+externallyVisibleIdLabel _               = True
+
 -- -----------------------------------------------------------------------------
 -- Finding the "type" of a CLabel 
 
@@ -744,7 +724,7 @@ labelType _                                     = DataLabel
 
 idInfoLabelType info =
   case info of
-    InfoTable  	  -> DataLabel
+    InfoTable _   -> DataLabel
     Closure    	  -> GcPtrLabel
     ConInfoTable  -> DataLabel
     StaticInfoTable -> DataLabel
@@ -847,6 +827,8 @@ entry.
 
 instance Outputable CLabel where
   ppr = pprCLabel
+instance PlatformOutputable CLabel where
+  pprPlatform _ = pprCLabel
 
 pprCLabel :: CLabel -> SDoc
 
@@ -980,7 +962,7 @@ ppIdFlavor x = pp_cSEP <>
 	       (case x of
 		       Closure	    	-> ptext (sLit "closure")
 		       SRT		-> ptext (sLit "srt")
-		       InfoTable    	-> ptext (sLit "info")
+		       InfoTable _	-> ptext (sLit "info")
 		       Entry	    	-> ptext (sLit "entry")
 		       Slow	    	-> ptext (sLit "slow")
 		       RednCounts	-> ptext (sLit "ct")

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

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

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) =

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            -- Entry label
      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,6 +70,7 @@ data GenCmmTop d h g
 -- Info table as a haskell data type
 data CmmInfoTable
   = CmmInfoTable
+      CLabel -- Info table label
       HasStaticClosure
       ProfilingInfo
       ClosureTypeTag -- Int
@@ -139,10 +133,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 -}