.gitignore

@@ -237,3 +237,5 @@ _darcs/
 
 
 /extra-gcc-opts
+
+.tm_properties

ANNOUNCE

 
-   ==============================================================
-    The (Interactive) Glasgow Haskell Compiler -- version 6.10.1
-   ==============================================================
+   =============================================================
+    The (Interactive) Glasgow Haskell Compiler -- version 7.4.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.4.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
+Here are some of the highlights of the 7.4 branch since 7.2 and 7.0:
 
- * Type families have been completely re-implemented
+  * The Num class no longer has Eq or Show superclasses.
 
- * Now comes with Haddock 2, which supports all GHC extensions
+  * There is a new feature Safe Haskell (-XSafe, -XTrustworthy, -XUnsafe).
+    The design has changed since 7.2.
 
- * Parallel garbage collection
+  * There is a new feature kind polymorphism (-XPolyKinds).
+    A side-effect of this is that, when the extension is not enabled, in
+    certain circumstances kinds are now defaulted to * rather than being
+    inferred.
 
- * Base provides extensible exceptions
+  * There is a new feature constraint kinds (-XConstraintKinds).
 
- * The GHC API is easier to use
+  * It is now possible to give any sort of declaration at the ghci prompt.
+    For example, you can now declare datatypes within ghci.
 
- * External core (output only) now works again
+  * The profiling and hpc implementations have been merged and overhauled.
+    Visible changes include renaming of profiling flags, and a new
+    semantics for the cost-centre stacks (which should in most cases
+    result in more useful and intuitive profiles). The +RTS -xc flag now
+    also gives a stack trace.
 
- * Data Parallel Haskell (DPH) comes as part of GHC
+  * It is now possible to write compiler plugins.
 
-The full release notes are here:
+  * DPH support has been significantly improved.
 
-  http://haskell.org/ghc/docs/6.10.1/html/users_guide/release-6-10-1.html
+  * There is now preliminary support for registerised compilation using
+    LLVM on the ARM platform.
+
+Full release notes are here:
+
+  http://www.haskell.org/ghc/docs/7.4.1/html/users_guide/release-7-4-1.html
 
 How to get it
 ~~~~~~~~~~~~~

README

@@ -50,12 +50,12 @@ For full information on building GHC, see the GHC Building Guide [3].
 Here follows a summary - if you get into trouble, the Building Guide
 has all the answers.
 
-NB. you need GHC installed in order to build GHC, because the compiler
-is itself written in Haskell.  For instructions on how to port GHC to a
-new platform, see the Building Guide.
+Before building GHC you may need to install some other tools and
+libraries.  See "Setting up your system for building GHC" [8].
 
-If you're building from git sources (as opposed to a source
-distribution) then you also need to install Happy [4] and Alex [5].
+NB. in particular you need GHC installed in order to build GHC,
+because the compiler is itself written in Haskell.  For instructions
+on how to port GHC to a new platform, see the Building Guide [3].
 
 For building library documentation, you'll need Haddock [6].  To build
 the compiler documentation, you need a good DocBook XML toolchain and
@@ -93,6 +93,7 @@ References
  [5] http://www.haskell.org/alex/                       Alex
  [6] http://www.haskell.org/haddock/                    Haddock
  [7] http://hackage.haskell.org/trac/ghc/wiki/Building/SyncAll
+ [8] http://hackage.haskell.org/trac/ghc/wiki/Building/Preparation
 
 
 Contributors

aclocal.m4

@@ -174,16 +174,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
             GET_ARM_ISA()
             test -z "[$]2" || eval "[$]2=\"ArchARM {armISA = \$ARM_ISA, armISAExt = \$ARM_ISA_EXT}\""
             ;;
-        alpha)
-            test -z "[$]2" || eval "[$]2=ArchAlpha"
-            ;;
-        mips|mipseb)
-            test -z "[$]2" || eval "[$]2=ArchMipseb"
-            ;;
-        mipsel)
-            test -z "[$]2" || eval "[$]2=ArchMipsel"
-            ;;
-        hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
+        alpha|mips|mipseb|mipsel|hppa|hppa1_1|ia64|m68k|rs6000|s390|s390x|sparc64|vax)
             test -z "[$]2" || eval "[$]2=ArchUnknown"
             ;;
         *)
@@ -221,13 +212,19 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
         freebsd)
             test -z "[$]2" || eval "[$]2=OSFreeBSD"
             ;;
+        kfreebsdgnu)
+            test -z "[$]2" || eval "[$]2=OSKFreeBSD"
+            ;;
         openbsd)
             test -z "[$]2" || eval "[$]2=OSOpenBSD"
             ;;
         netbsd)
             test -z "[$]2" || eval "[$]2=OSNetBSD"
             ;;
-        dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku)
+        haiku)
+            test -z "[$]2" || eval "[$]2=OSHaiku"
+            ;;
+        dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
             test -z "[$]2" || eval "[$]2=OSUnknown"
             ;;
         *)
@@ -355,6 +352,7 @@ AC_DEFUN([FP_SETTINGS],
     then
         SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe'
         SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
+        SettingsArCommand='$topdir/../mingw/bin/ar.exe'
         SettingsPerlCommand='$topdir/../perl/perl.exe'
         SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe'
         SettingsWindresCommand='$topdir/../mingw/bin/windres.exe'
@@ -362,6 +360,7 @@ AC_DEFUN([FP_SETTINGS],
     else
         SettingsCCompilerCommand="$WhatGccIsCalled"
         SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
+        SettingsArCommand="$ArCmd"
         SettingsPerlCommand="$PerlCmd"
         SettingsDllWrapCommand="/bin/false"
         SettingsWindresCommand="/bin/false"
@@ -369,6 +368,7 @@ AC_DEFUN([FP_SETTINGS],
     fi
     AC_SUBST(SettingsCCompilerCommand)
     AC_SUBST(SettingsCCompilerFlags)
+    AC_SUBST(SettingsArCommand)
     AC_SUBST(SettingsPerlCommand)
     AC_SUBST(SettingsDllWrapCommand)
     AC_SUBST(SettingsWindresCommand)
@@ -1894,6 +1894,12 @@ AC_DEFUN([BOOTSTRAPPING_GHC_INFO_FIELD],[
 if test $GhcCanonVersion -ge 701
 then
     $1=`"$WithGhc" --info | grep "^ ,(\"$2\"," | sed -e 's/.*","//' -e 's/")$//'`
+    tmp=${$1#\$topdir/}
+    if test "${$1}" != "$tmp"
+    then
+        topdir=`"$WithGhc" --print-libdir | sed 's#\\\\#/#g'`
+        $1="$topdir/$tmp"
+    fi
 else
     $1=$3
 fi
@@ -1942,10 +1948,12 @@ AC_DEFUN([XCODE_VERSION],[
 # Finds where gcc is
 AC_DEFUN([FIND_GCC],[
     if test "$TargetOS_CPP" = "darwin" &&
-        test "$XCodeVersion1" -ge 4
+       test "$XCodeVersion1" -eq 4 &&
+       test "$XCodeVersion2" -lt 2
     then
-        # From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy
-        # backend (instead of the LLVM backend)
+        # In Xcode 4.1, 'gcc-4.2' is the gcc legacy backend (rather
+        # than the LLVM backend). We prefer the legacy gcc, but in
+        # Xcode 4.2 'gcc-4.2' was removed.
         FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2])
     else
         FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])

compiler/basicTypes/Name.lhs

@@ -55,7 +55,7 @@ module Name (
 	nameOccName, nameModule, nameModule_maybe,
 	tidyNameOcc, 
 	hashName, localiseName,
-  mkLocalisedOccName,
+        mkLocalisedOccName,
 
 	nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt,
 
@@ -430,6 +430,9 @@ instance Outputable Name where
 
 instance OutputableBndr Name where
     pprBndr _ name = pprName name
+    pprInfixOcc  = pprInfixName
+    pprPrefixOcc = pprPrefixName
+
 
 pprName :: Name -> SDoc
 pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ})

compiler/basicTypes/RdrName.lhs

@@ -49,7 +49,8 @@ module RdrName (
 
 	-- * Local mapping of 'RdrName' to 'Name.Name'
 	LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
-	lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv,
+	lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv, inLocalRdrEnvScope, 
+        localRdrEnvElts, delLocalRdrEnvList,
 
 	-- * Global mapping of 'RdrName' to 'GlobalRdrElt's
 	GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, 
@@ -70,6 +71,7 @@ module RdrName (
 
 import Module
 import Name
+import NameSet
 import Maybes
 import SrcLoc
 import FastString
@@ -273,6 +275,9 @@ instance OutputableBndr RdrName where
 	| isTvOcc (rdrNameOcc n) = char '@' <+> ppr n
 	| otherwise		 = ppr n
 
+    pprInfixOcc  rdr = pprInfixVar  (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+    pprPrefixOcc rdr = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr)
+
 showRdrName :: RdrName -> String
 showRdrName r = showSDoc (ppr r)
 
@@ -326,30 +331,42 @@ instance Ord RdrName where
 \begin{code}
 -- | This environment is used to store local bindings (@let@, @where@, lambda, @case@).
 -- It is keyed by OccName, because we never use it for qualified names
-type LocalRdrEnv = OccEnv Name
+-- We keep the current mapping, *and* the set of all Names in scope
+-- Reason: see Note [Splicing Exact Names] in RnEnv
+type LocalRdrEnv = (OccEnv Name, NameSet) 
 
 emptyLocalRdrEnv :: LocalRdrEnv
-emptyLocalRdrEnv = emptyOccEnv
+emptyLocalRdrEnv = (emptyOccEnv, emptyNameSet)
 
 extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
-extendLocalRdrEnv env name
-  = extendOccEnv env (nameOccName name) name
+extendLocalRdrEnv (env, ns) name
+  = (extendOccEnv env (nameOccName name) name, addOneToNameSet ns name)
 
 extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
-extendLocalRdrEnvList env names
-  = extendOccEnvList env [(nameOccName n, n) | n <- names]
+extendLocalRdrEnvList (env, ns) names
+  = (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet  ns names)
 
 lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
-lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ
-lookupLocalRdrEnv _   _            = Nothing
+lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ
+lookupLocalRdrEnv _        _            = Nothing
 
 lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name
-lookupLocalRdrOcc env occ = lookupOccEnv env occ
+lookupLocalRdrOcc (env, _) occ = lookupOccEnv env occ
 
 elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool
-elemLocalRdrEnv rdr_name env 
+elemLocalRdrEnv rdr_name (env, _)
   | isUnqual rdr_name = rdrNameOcc rdr_name `elemOccEnv` env
   | otherwise	      = False
+
+localRdrEnvElts :: LocalRdrEnv -> [Name]
+localRdrEnvElts (env, _) = occEnvElts env
+
+inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool
+-- This is the point of the NameSet
+inLocalRdrEnvScope name (_, ns) = name `elemNameSet` ns
+
+delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv
+delLocalRdrEnvList (env, ns) occs = (delListFromOccEnv env occs, ns)
 \end{code}
 
 %************************************************************************

compiler/cmm/PprC.hs

@@ -757,12 +757,14 @@ isStrangeTypeReg (CmmLocal _)   = False
 isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
 
 isStrangeTypeGlobal :: GlobalReg -> Bool
+isStrangeTypeGlobal CCCS                = True
 isStrangeTypeGlobal CurrentTSO          = True
 isStrangeTypeGlobal CurrentNursery      = True
 isStrangeTypeGlobal BaseReg             = True
 isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
 
 strangeRegType :: CmmReg -> Maybe SDoc
+strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *"))
 strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
 strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
 strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
@@ -793,6 +795,7 @@ pprGlobalReg gr = case gr of
     SpLim          -> ptext (sLit "SpLim")
     Hp             -> ptext (sLit "Hp")
     HpLim          -> ptext (sLit "HpLim")
+    CCCS           -> ptext (sLit "CCCS")
     CurrentTSO     -> ptext (sLit "CurrentTSO")
     CurrentNursery -> ptext (sLit "CurrentNursery")
     HpAlloc        -> ptext (sLit "HpAlloc")

compiler/codeGen/CgClosure.lhs

@@ -374,7 +374,7 @@ mkSlowEntryCode cl_info reg_args
 
      stk_adj_pop   = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
      stk_adj_push  = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
-     jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) []
+     jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) []
 \end{code}
 
 

compiler/codeGen/CgForeignCall.hs

@@ -271,7 +271,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 
 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
 tso_stackobj = closureField oFFSET_StgTSO_stackobj
-tso_CCCS     = closureField oFFSET_StgTSO_CCCS
+tso_CCCS     = closureField oFFSET_StgTSO_cccs
 stack_STACK  = closureField oFFSET_StgStack_stack
 stack_SP     = closureField oFFSET_StgStack_sp
 

compiler/codeGen/CgProf.hs

@@ -178,8 +178,8 @@ emitCostCentreDecl cc = do
 	      label,	-- char *label,
 	      modl,	-- char *module,
               loc,      -- char *srcloc,
+              zero64,   -- StgWord64 mem_alloc
               zero,     -- StgWord time_ticks
-              zero64,	-- StgWord64 mem_alloc
               is_caf,   -- StgInt is_caf
               zero      -- struct _CostCentre *link
 	    ] 

compiler/codeGen/ClosureInfo.lhs

@@ -963,7 +963,10 @@ infoTableLabelFromCI :: ClosureInfo -> CLabel
 infoTableLabelFromCI = fst . labelsFromCI
 
 entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI = snd . labelsFromCI
+entryLabelFromCI ci
+  | tablesNextToCode = info_lbl
+  | otherwise        = entry_lbl
+  where (info_lbl, entry_lbl) = labelsFromCI ci
 
 labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry)
 labelsFromCI cl@(ClosureInfo { closureName = name,

compiler/codeGen/StgCmmForeign.hs

@@ -246,7 +246,7 @@ nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 
 tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
 tso_stackobj = closureField oFFSET_StgTSO_stackobj
-tso_CCCS     = closureField oFFSET_StgTSO_CCCS
+tso_CCCS     = closureField oFFSET_StgTSO_cccs
 stack_STACK  = closureField oFFSET_StgStack_stack
 stack_SP     = closureField oFFSET_StgStack_sp
 

compiler/codeGen/StgCmmProf.hs

@@ -223,14 +223,14 @@ emitCostCentreDecl cc = do
                 -- All cost centres will be in the main package, since we
                 -- don't normally use -auto-all or add SCCs to other packages.
                 -- Hence don't emit the package name in the module here.
-  ; let lits = [ zero,   	-- StgInt ccID,
-	      	 label,	-- char *label,
-                 modl,  -- char *module,
-                 loc,   -- char *srcloc,
-                 zero,  -- StgWord time_ticks
-              	 zero64,	-- StgWord64 mem_alloc
-                 is_caf,   -- StgInt is_caf
-                 zero   -- struct _CostCentre *link
+  ; let lits = [ zero,    -- StgInt ccID,
+	      	 label,	  -- char *label,
+                 modl,    -- char *module,
+                 loc,     -- char *srcloc,
+                 zero64,  -- StgWord64 mem_alloc
+                 zero,    -- StgWord time_ticks
+                 is_caf,  -- StgInt is_caf
+                 zero     -- struct _CostCentre *link
 	       ] 
   ; emitDataLits (mkCCLabel cc) lits
   }

compiler/coreSyn/CoreLint.lhs

@@ -700,29 +700,6 @@ lintTyBndrKind tv =
   else lintKind ki  -- type forall
 
 -------------------
-{-
-lint_prim_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
-lint_prim_eq_co tc co arg_cos = case arg_cos of 
-  [co1,co2] -> do { (t1,s1) <- lintCoercion co1
-                  ; (t2,s2) <- lintCoercion co2
-                  ; checkL (typeKind t1 `eqKind` typeKind t2) $ 
-                    ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
-                  ; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
-  _ -> failWithL (ptext (sLit "Unsaturated or oversaturated ~# coercion") <+> ppr co)
-
-lint_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType) 
-lint_eq_co tc co arg_cos = case arg_cos of 
-  [co1,co2] -> do { (t1,s1) <- lintCoercion co1
-                  ; (t2,s2) <- lintCoercion co2
-                  ; checkL (typeKind t1 `eqKind` typeKind t2) $
-                    ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
-                  ; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
-  [co1] -> do { (t1,s1) <- lintCoercion co1
-              ; return (mkTyConApp tc [t1], mkTyConApp tc [s1]) }
-  [] -> return (mkTyConApp tc [], mkTyConApp tc [])
-  _ -> failWithL (ptext (sLit "Oversaturated ~ coercion") <+> ppr co) 
--}
-
 lintKindCoercion :: OutCoercion -> LintM OutKind
 -- Kind coercions are only reflexivity because they mean kind
 -- instantiation.  See Note [Kind coercions] in Coercion
@@ -742,21 +719,6 @@ lintCoercion (Refl ty)
        ; return (ty, ty) }
 
 lintCoercion co@(TyConAppCo tc cos)
-{- DV: This grievous hack (from ghc-constraint-solver) should not be needed any more:
-  | tc `hasKey` eqPrimTyConKey      -- Just as in lintType, treat applications of (~) and (~#)
-  = lint_prim_eq_co tc co cos       -- specially to allow for polymorphism. This hack will 
-                                    -- hopefully go away when we merge in kind polymorphism.
-  | tc `hasKey` eqTyConKey
-  = lint_eq_co tc co cos
-
-  | otherwise
-  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
-       ; let kind_to_check = if (tc `hasKey` funTyConKey) && (length cos == 2)
-                             then mkArrowKinds [argTypeKind,openTypeKind] liftedTypeKind
-                             else tyConKind tc -- TODO: Fix this when kind polymorphism is in! 
-       ; check_co_app co kind_to_check ss
-       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
--}
   = do   -- We use the kind of the type constructor to know how many
          -- kind coercions we have (one kind coercion for one kind
          -- instantiation).
@@ -876,7 +838,10 @@ lintType ty@(FunTy t1 t2)
   = lint_ty_app ty (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) [t1,t2]
 
 lintType ty@(TyConApp tc tys)
-  | tyConHasKind tc
+  | tyConHasKind tc   -- Guards for SuperKindOon
+  , not (isUnLiftedTyCon tc) || tys `lengthIs` tyConArity tc
+       -- Check that primitive types are saturated
+       -- See Note [The kind invariant] in TypeRep
   = lint_ty_app ty (tyConKind tc) tys
   | otherwise
   = failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))

compiler/coreSyn/CorePrep.lhs

@@ -26,7 +26,7 @@ import CoreFVs
 import CoreMonad	( endPass, CoreToDo(..) )
 import CoreSyn
 import CoreSubst
-import MkCore
+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here
 import Type
 import Literal
 import Coercion

compiler/coreSyn/CoreSyn.lhs

@@ -26,6 +26,7 @@ module CoreSyn (
 	
 	mkIntLit, mkIntLitInt,
 	mkWordLit, mkWordLitWord,
+	mkWord64LitWord64, mkInt64LitInt64,
 	mkCharLit, mkStringLit,
 	mkFloatLit, mkFloatLitFloat,
 	mkDoubleLit, mkDoubleLitDouble,
@@ -104,6 +105,7 @@ import Outputable
 import Util
 
 import Data.Data hiding (TyCon)
+import Data.Int
 import Data.Word
 
 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
@@ -992,6 +994,8 @@ instance Outputable b => Outputable (TaggedBndr b) where
 
 instance Outputable b => OutputableBndr (TaggedBndr b) where
   pprBndr _ b = ppr b	-- Simple
+  pprInfixOcc  b = ppr b
+  pprPrefixOcc b = ppr b
 \end{code}
 
 
@@ -1042,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b
 mkWordLit     w = Lit (mkMachWord w)
 mkWordLitWord w = Lit (mkMachWord (toInteger w))
 
+mkWord64LitWord64 :: Word64 -> Expr b
+mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w))
+
+mkInt64LitInt64 :: Int64 -> Expr b
+mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w))
+
 -- | Create a machine character literal expression of type @Char#@.
 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
 mkCharLit :: Char -> Expr b

compiler/coreSyn/CoreUtils.lhs

@@ -21,7 +21,8 @@ module CoreUtils (
         exprType, coreAltType, coreAltsType,
         exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
-        exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
+        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
+        exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
 
         -- * Expression and bindings size
@@ -752,35 +753,39 @@ it's applied only to dictionaries.
 --
 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 -- side effects, and can't diverge or raise an exception.
-exprOkForSpeculation :: Expr b -> Bool
+exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
+exprOkForSpeculation = expr_ok primOpOkForSpeculation
+exprOkForSideEffects = expr_ok primOpOkForSideEffects
   -- Polymorphic in binder type
   -- There is one call at a non-Id binder type, in SetLevels
-exprOkForSpeculation (Lit _)      = True
-exprOkForSpeculation (Type _)     = True
-exprOkForSpeculation (Coercion _) = True
-exprOkForSpeculation (Var v)      = appOkForSpeculation v []
-exprOkForSpeculation (Cast e _)   = exprOkForSpeculation e
+
+expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
+expr_ok _ (Lit _)      = True
+expr_ok _ (Type _)     = True
+expr_ok _ (Coercion _) = True
+expr_ok primop_ok (Var v)      = app_ok primop_ok v []
+expr_ok primop_ok (Cast e _)   = expr_ok primop_ok e
 
 -- Tick annotations that *tick* cannot be speculated, because these
 -- are meant to identify whether or not (and how often) the particular
 -- source expression was evaluated at runtime.
-exprOkForSpeculation (Tick tickish e)
+expr_ok primop_ok (Tick tickish e)
    | tickishCounts tickish = False
-   | otherwise             = exprOkForSpeculation e
+   | otherwise             = expr_ok primop_ok e
 
-exprOkForSpeculation (Case e _ _ alts)
-  =  exprOkForSpeculation e  -- Note [exprOkForSpeculation: case expressions]
-  && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
-  && altsAreExhaustive alts     -- Note [exprOkForSpeculation: exhaustive alts]
+expr_ok primop_ok (Case e _ _ alts)
+  =  expr_ok primop_ok e  -- Note [exprOkForSpeculation: case expressions]
+  && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
+  && altsAreExhaustive alts     -- Note [Exhaustive alts]
 
-exprOkForSpeculation other_expr
+expr_ok primop_ok other_expr
   = case collectArgs other_expr of
-        (Var f, args) -> appOkForSpeculation f args
+        (Var f, args) -> app_ok primop_ok f args
         _             -> False
 
 -----------------------------
-appOkForSpeculation :: Id -> [Expr b] -> Bool
-appOkForSpeculation fun args
+app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
+app_ok primop_ok fun args
   = case idDetails fun of
       DFunId new_type ->  not new_type
          -- DFuns terminate, unless the dict is implemented 
@@ -794,7 +799,7 @@ appOkForSpeculation fun args
       PrimOpId op
         | isDivOp op              -- Special case for dividing operations that fail
         , [arg1, Lit lit] <- args -- only if the divisor is zero
-        -> not (isZeroLit lit) && exprOkForSpeculation arg1
+        -> not (isZeroLit lit) && expr_ok primop_ok arg1
                   -- Often there is a literal divisor, and this
                   -- can get rid of a thunk in an inner looop
 
@@ -802,14 +807,14 @@ appOkForSpeculation fun args
         -> True
 
         | otherwise
-        -> primOpOkForSpeculation op &&
-           all exprOkForSpeculation args
-                                  -- A bit conservative: we don't really need
+        -> primop_ok op        -- A bit conservative: we don't really need
+        && all (expr_ok primop_ok) args
+                                  
                                   -- to care about lazy arguments, but this is easy
 
       _other -> isUnLiftedType (idType fun)          -- c.f. the Var case of exprIsHNF
              || idArity fun > n_val_args             -- Partial apps
-             || (n_val_args ==0 && 
+             || (n_val_args == 0 && 
                  isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
              where
                n_val_args = valArgCount args
@@ -872,13 +877,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
 
 The inner case is redundant, and should be nuked.
 
-Note [exprOkForSpeculation: exhaustive alts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Exhaustive alts]
+~~~~~~~~~~~~~~~~~~~~~~
 We might have something like
   case x of {
     A -> ...
     _ -> ...(case x of { B -> ...; C -> ... })...
-Here, the inner case is fine, becuase the A alternative
+Here, the inner case is fine, because the A alternative
 can't happen, but it's not ok to float the inner case outside
 the outer one (even if we know x is evaluated outside), because
 then it would be non-exhaustive. See Trac #5453.

compiler/coreSyn/MkCore.lhs

@@ -21,6 +21,9 @@ module MkCore (
         mkFloatExpr, mkDoubleExpr,
         mkCharExpr, mkStringExpr, mkStringExprFS,
 
+        -- * Floats
+        FloatBind(..), wrapFloat,
+
         -- * Constructing/deconstructing implicit parameter boxes
         mkIPUnbox, mkIPBox,
 
@@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type
 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
 \end{code}
 
+
+%************************************************************************
+%*                                                                      *
+                Floats
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+data FloatBind 
+  = FloatLet  CoreBind
+  | FloatCase CoreExpr Id AltCon [Var]       
+      -- case e of y { C ys -> ... }
+      -- See Note [Floating cases] in SetLevels
+
+wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
+wrapFloat (FloatLet defns)       body = Let defns body
+wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
+\end{code}
+
 %************************************************************************
 %*                                                                      *
 \subsection{Tuple destructors}

compiler/coreSyn/PprCore.lhs

@@ -21,6 +21,7 @@ module PprCore (
 
 import CoreSyn
 import Literal( pprLiteral )
+import Name( pprInfixName, pprPrefixName )
 import Var
 import Id
 import IdInfo
@@ -268,6 +269,8 @@ and @pprCoreExpr@ functions.
 \begin{code}
 instance OutputableBndr Var where
   pprBndr = pprCoreBinder
+  pprInfixOcc  = pprInfixName  . varName
+  pprPrefixOcc = pprPrefixName . varName
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder

compiler/deSugar/Desugar.lhs

@@ -300,8 +300,8 @@ addExportFlagsAndRules target exports keep_alive rules prs
 	-- isExternalName separates the user-defined top-level names from those
 	-- introduced by the type checker.
     is_exported :: Name -> Bool
-    is_exported | target == HscInterpreted = isExternalName
-		| otherwise 		   = (`elemNameSet` exports)
+    is_exported | targetRetainsAllBindings target = isExternalName
+                | otherwise                       = (`elemNameSet` exports)
 \end{code}