Commit b4b7647f authored by dimitris's avatar dimitris
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-new-flavor

parents cc2d2e1d 9606231d
Simon Marlow <marlowsd@gmail.com>, simonmar, simonmar@microsoft.com, simonm
Ross Paterson <ross@soi.city.ac.uk>, ross
Sven Panne <sven.panne@aedion.de>, panne
Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>, malcolm
Simon Peyton Jones <simonpj@microsoft.com>, simonpj
Don Stewart <dons@galois.com>, dons
Tim Harris <tharris@microsoft.com>, tharris
Lennart Augustsson <lennart@augustsson.net>, lennart.augustsson@credit-suisse.com
Duncan Coutts <duncan@haskell.org>, duncan.coutts@worc.ox.ac.uk, duncan@well-typed.com
Ben Lippmeier <benl@ouroborus.net>, benl@cse.unsw.edu.au, Ben.Lippmeier@anu.edu.au, Ben.Lippmeier.anu.edu.au
Manuel M T Chakravarty <chak@cse.unsw.edu.au>, chak
Jose Pedro Magalhaes <jpm@cs.uu.nl>, jpm@cs.uu.nl
Sigbjorn Finne <sof@galois.com>, sof
Wolfgang Thaller <wolfgang.thaller@gmx.net>, wolfgang
Julian Seward <jseward@acm.org>, sewardj
Ian Lynagh <igloo@earth.li>, igloo
Roman Leshchinskiy <rl@cse.unsw.edu.au>, rl@cse.unsw.edu.au
John Dias <dias@cs.tufts.edu>, dias@eecs.tufts.edu, dias@eecs.harvard.edu
Norman Ramsey <nr@eecs.harvard.edu>, nr@eecs.harvard.edu
Andy Gill <andygill@ku.edu>, andy
Will Partain <partain@dcs.gla.ac.uk>, partain
Don Syme <dsyme@microsoft.com>, dsyme
Pepe Iborra <mnislaih@gmail.com>, pepe
Neil Mitchell <ndmitchell@gmail.com>, Neil Mitchell
Gabriele Keller <keller@cse.unsw.edu.au>, keller
Daan Leijen <daan@microsoft.com>, daan
Audrey Tang <audreyt@audreyt.org>, audreyt@audreyt.org
Hans-Wolfgang Loidl <hwloidl@macs.hw.ac.uk>, hwloidl
Bernie Pope <bjpop@csse.unimelb.edu.au>, bjpop@csse.unimelb.edu.au
#Top-level dirs:
^alex/
^common-rts/
^CONTRIB/
^dll/
^greencard/
^green-card/
^haddock/
^haggis/
^happy/
^hdirect/
^hood/
^hslibs/
^hws/
^hx/
^literate/
^mhms/
^mkworld/
^nofib(/|$)
^lib/
^misc/
^mkworld/
^runtime/
^testsuite(/|$)
# bindists
^ghc-
^bin-manifest-
#Packages:
^libraries/Cabal(/|$)
^libraries/ALUT(/|$)
^libraries/GLUT(/|$)
^libraries/HGL(/|$)
^libraries/HUnit(/|$)
^libraries/HaXml(/|$)
^libraries/Japi(/|$)
^libraries/OpenAL(/|$)
^libraries/OpenGL(/|$)
^libraries/QuickCheck(/|$)
^libraries/Win32(/|$)
^libraries/X11(/|$)
^libraries/array(/|$)
^libraries/arrows(/|$)
^libraries/base(/|$)
^libraries/base3-compat(/|$)
^libraries/binary(/|$)
^libraries/bytestring(/|$)
^libraries/cgi(/|$)
^libraries/concurrent(/|$)
^libraries/containers(/|$)
^libraries/directory(/|$)
^libraries/editline(/|$)
^libraries/fgl(/|$)
^libraries/filepath(/|$)
^libraries/getopt(/|$)
^libraries/ghc-prim(/|$)
^libraries/haskell-src(/|$)
^libraries/haskell98(/|$)
^libraries/hpc(/|$)
^libraries/html(/|$)
^libraries/integer-.*(/|$)
^libraries/old-locale(/|$)
^libraries/old-time(/|$)
^libraries/monads(/|$)
^libraries/mtl(/|$)
^libraries/ndp(/|$)
^libraries/network(/|$)
^libraries/packedstring(/|$)
^libraries/parsec(/|$)
^libraries/parallel(/|$)
^libraries/pretty(/|$)
^libraries/process(/|$)
^libraries/random(/|$)
^libraries/readline(/|$)
^libraries/regex-base(/|$)
^libraries/regex-compat(/|$)
^libraries/regex-posix(/|$)
^libraries/st(/|$)
^libraries/stm(/|$)
^libraries/syb(/|$)
^libraries/template-haskell(/|$)
^libraries/time(/|$)
^libraries/timeout(/|$)
^libraries/unique(/|$)
^libraries/unix(/|$)
^libraries/xhtml(/|$)
^libraries/dph(/|$)
^libraries/utf8-string(/|$)
^libraries/terminfo(/|$)
^libraries/haskeline(/|$)
^libraries/extensible-exceptions(/|$)
# Other library bits that get generated:
^libraries/bootstrapping/
^libraries/stamp/
^libraries/ifBuildable(/|$)
^libraries/installPackage(/|$)
^libraries/index.html
^libraries/doc-index.*\.html
^libraries/haddock-util.js
^libraries/haddock.css
^libraries/haskell_icon.gif
^libraries/minus.gif
^libraries/plus.gif
^libraries/libraries.txt
# It's often useful to have somewhere in the build tree to install to
^inst(/|$)
# Boring file regexps:
\.hi$
\.hi-boot$
\.o-boot$
\.p_o$
\.t_o$
\.debug_o$
\.thr_o$
\.thr_p_o$
\.thr_debug_o$
\.o$
\.a$
\.o\.cmd$
# *.ko files aren't boring by default because they might
# be Korean translations rather than kernel modules.
# \.ko$
\.ko\.cmd$
\.mod\.c$
(^|/)\.tmp_versions($|/)
(^|/)CVS($|/)
(^|/)RCS($|/)
~$
#(^|/)\.[^/]
(^|/)_darcs($|/)
\.bak$
\.BAK$
\.orig$
(^|/)vssver\.scc$
\.swp$
(^|/)MT($|/)
(^|/)\{arch\}($|/)
(^|/).arch-ids($|/)
(^|/),
\.class$
\.prof$
(^|/)\.DS_Store$
(^|/)BitKeeper($|/)
(^|/)ChangeSet($|/)
(^|/)\.svn($|/)
(^|/)\.git($|/)
\.git-ignore$
\.py[co]$
\#
\.cvsignore$
(^|/)Thumbs\.db$
\.depend$
\.depend-.*$
^compiler/primop-
^compiler/cmm/CmmLex.hs$
^compiler/cmm/CmmParse.hs$
^compiler/ghci/LibFFI.hs$
^compiler/ghci/LibFFI_hsc.c$
^compiler/main/Config.hs$
^compiler/main/ParsePkgConf.hs$
^compiler/parser/Parser.y$
^compiler/parser/Parser.hs$
^compiler/parser/Lexer.hs$
^compiler/parser/ParserCore.hs$
^compiler/parser/HaddockLex.hs
^compiler/parser/HaddockParse.hs
^compiler/prelude/primops.txt$
^compiler/stage1($|/)
^compiler/stage2($|/)
^compiler/stage3($|/)
^compiler/utils/Fingerprint.hs$
^compiler/utils/Fingerprint_hsc.c$
^mk/build.mk$
^mk/validate.mk$
^mk/are-validating.mk$
^mk/config.h.in$
^mk/config.h$
^mk/config.mk$
^mk/stamp-h$
^stage3.package.conf$
^inplace-datadir(/|$)
(^|/)autom4te.cache($|/)
^rts/AutoApply.*cmm$
^rts/sm/Evac_thr.c$
^rts/sm/Scav_thr.c$
package.conf.inplace$
package.conf.installed$
(^|/)config.log$
(^|/)config.status$
(^|/)configure$
^ghc.spec$
^docs/users_guide/ug-book.xml$
^docs/man/flags.xml$
^docs/man/flags.xsl$
^docs/man/ghc.1$
^extra-gcc-opts$
# ignore scripts like push-monk
^push-
^pull-
# Common log file names; testlog is made by validate
^testlog
^log
^utils/[a-zA-Z0-9-]+/dist-install(/|$)
^utils/[a-zA-Z0-9-]+/dist-inplace(/|$)
^utils/[a-zA-Z0-9-]+/install-inplace(/|$)
^compiler/Makefile-stage[1-3](/|$)
^compiler/dist-stage[1-3](/|$)
^ghc/dist-stage[1-3](/|$)
^ghc/stage[1-3]-inplace(/|$)
^utils/ext-core/Driver$
^utils/ext-core/PrimEnv.hs$
^utils/genapply/genapply$
^utils/genprimopcode/Lexer.hs$
^utils/genprimopcode/Parser.hs$
^utils/genprimopcode/genprimopcode$
^utils/ghc-pkg/Version.hs$
^utils/ghc-pkg/ghc-pkg-inplace$
^utils/ghc-pkg/ghc-pkg-inplace.bin$
^utils/ghc-pkg/ghc-pkg-inplace.hs$
^utils/ghc-pkg/ghc-pkg.bin$
^utils/hasktags/hasktags$
^utils/hasktags/hasktags-inplace$
^utils/hp2ps/hp2ps$
^utils/hpc/HpcParser.hs$
^utils/hsc2hs(/|$)
^utils/haddock(/|$)
^utils/lndir/lndir$
^utils/mkdependC/mkdependC$
^utils/mkdirhier/mkdirhier$
^utils/prof/cgprof/cgprof$
^utils/prof/ghcprof-inplace$
^utils/pwd/pwd$
^utils/pwd/pwd-inplace$
^utils/runghc/runghc$
^utils/runghc/runghc-inplace$
^utils/runghc/runhaskell$
^utils/runstdtest/runstdtest$
^utils/unlit/unlit$
^driver/ghci/ghc-pkg-inplace$
^driver/ghci/ghci-inplace$
^driver/mangler/ghc-asm$
^driver/mangler/ghc-asm.prl$
^driver/package.conf$
^driver/package.conf.inplace.old$
^driver/split/ghc-split$
^driver/split/ghc-split.prl$
^driver/stamp-pkg-conf-rts$
^includes/DerivedConstants.h$
^includes/GHCConstants.h$
^includes/ghcautoconf.h$
^includes/ghcplatform.h$
^includes/mkDerivedConstantsHdr$
^includes/mkGHCConstants$
^libffi/build($|/)
^libffi/ffi.h$
^libffi/stamp.ffi.static$
......@@ -363,12 +363,18 @@ AC_DEFUN([FP_SETTINGS],
[
if test "$windows" = YES
then
SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe'
if test "$HostArch" = "x86_64"
then
mingw_bin_prefix=x86_64-w64-mingw32-
else
mingw_bin_prefix=
fi
SettingsCCompilerCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}gcc.exe"
SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2 $CONF_GCC_LINKER_OPTS_STAGE2"
SettingsArCommand='$topdir/../mingw/bin/ar.exe'
SettingsArCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}ar.exe"
SettingsPerlCommand='$topdir/../perl/perl.exe'
SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe'
SettingsWindresCommand='$topdir/../mingw/bin/windres.exe'
SettingsDllWrapCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}dllwrap.exe"
SettingsWindresCommand="\$topdir/../mingw/bin/${mingw_bin_prefix}windres.exe"
SettingsTouchCommand='$topdir/touchy.exe'
else
SettingsCCompilerCommand="$WhatGccIsCalled"
......@@ -686,7 +692,8 @@ case $HostPlatform in
esac ;;
alpha-dec-osf*) fptools_cv_leading_underscore=no;;
*cygwin32) fptools_cv_leading_underscore=yes;;
*mingw32) fptools_cv_leading_underscore=yes;;
i386-unknown-mingw32) fptools_cv_leading_underscore=yes;;
x86_64-unknown-mingw32) fptools_cv_leading_underscore=no;;
# HACK: Apple doesn't seem to provide nlist in the 64-bit-libraries
x86_64-apple-darwin*) fptools_cv_leading_underscore=yes;;
......@@ -776,9 +783,9 @@ dnl
AC_DEFUN([FPTOOLS_HAPPY],
[AC_PATH_PROG(HappyCmd,happy,)
# Happy is passed to Cabal, so we need a native path
if test "x$HostPlatform" = "xi386-unknown-mingw32" && \
test "${OSTYPE}" != "msys" && \
test "${HappyCmd}" != ""
if test "$HostOS" = "mingw32" && \
test "${OSTYPE}" != "msys" && \
test "${HappyCmd}" != ""
then
# Canonicalise to <drive>:/path/to/gcc
HappyCmd=`cygpath -m "${HappyCmd}"`
......@@ -812,9 +819,9 @@ AC_DEFUN([FPTOOLS_ALEX],
[
AC_PATH_PROG(AlexCmd,alex,)
# Alex is passed to Cabal, so we need a native path
if test "x$HostPlatform" = "xi386-unknown-mingw32" && \
test "${OSTYPE}" != "msys" && \
test "${AlexCmd}" != ""
if test "$HostOS" = "mingw32" && \
test "${OSTYPE}" != "msys" && \
test "${AlexCmd}" != ""
then
# Canonicalise to <drive>:/path/to/gcc
AlexCmd=`cygpath -m "${AlexCmd}"`
......
......@@ -168,6 +168,9 @@ Wired-in thing => The thing (Id, TyCon) is fully known to the compiler,
All built-in syntax is for wired-in things.
\begin{code}
instance HasOccName Name where
occName = nameOccName
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
nameModule :: Name -> Module
......
......@@ -54,6 +54,7 @@ module OccName (
mkTupleOcc,
setOccNameSpace,
demoteOccName,
HasOccName(..),
-- ** Derived 'OccName's
isDerivedOccName,
......@@ -334,6 +335,11 @@ demoteOccName :: OccName -> Maybe OccName
demoteOccName (OccName space name) = do
space' <- demoteNameSpace space
return $ OccName space' name
{- | Other names in the compiler add aditional information to an OccName.
This class provides a consistent way to access the underlying OccName. -}
class HasOccName name where
occName :: name -> OccName
\end{code}
......@@ -492,7 +498,7 @@ isDataSymOcc _ = False
-- it is a data constructor or variable or whatever)
isSymOcc :: OccName -> Bool
isSymOcc (OccName DataName s) = isLexConSym s
isSymOcc (OccName TcClsName s) = isLexConSym s
isSymOcc (OccName TcClsName s) = isLexConSym s || isLexVarSym s
isSymOcc (OccName VarName s) = isLexSym s
isSymOcc (OccName TvName s) = isLexSym s
-- Pretty inefficient!
......
......@@ -130,6 +130,10 @@ data RdrName
%************************************************************************
\begin{code}
instance HasOccName RdrName where
occName = rdrNameOcc
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (Qual _ occ) = occ
rdrNameOcc (Unqual occ) = occ
......
-- Cmm representations using Hoopl's Graph CmmNode e x.
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#if __GLASGOW_HASKELL__ >= 703
-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
......
......@@ -1107,10 +1107,11 @@ pprHexVal w rep
-- times values are unsigned. This also helps eliminate occasional
-- warnings about integer overflow from gcc.
-- on 32-bit platforms, add "ULL" to 64-bit literals
repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL")
-- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL")
repsuffix W64
| cINT_SIZE == 8 = char 'U'
| cLONG_SIZE == 8 = ptext (sLit "UL")
| cLONG_LONG_SIZE == 8 = ptext (sLit "ULL")
| otherwise = panic "pprHexVal: Can't find a 64-bit type"
repsuffix _ = char 'U'
go 0 = empty
......
......@@ -1097,8 +1097,16 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumTyLit n -> show n
StrTyLit n -> show n
\end{code}
......@@ -864,11 +864,18 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
ForAllTy _ ty -> getTyDescription ty
LitTy n -> getTyLitDescription n
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumTyLit n -> show n
StrTyLit n -> show n
--------------------------------------
-- CmmInfoTable-related things
--------------------------------------
......
......@@ -190,6 +190,12 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
; checkL (not (isStrictId binder)
|| (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
(mkStrictMsg binder)
-- Check that if the binder is local, it is not marked as exported
; checkL (not (isExportedId binder) || isTopLevel top_lvl_flag)
(mkNonTopExportedMsg binder)
-- Check that if the binder is local, it does not have an external name
; checkL (not (isExternalName (Var.varName binder)) || isTopLevel top_lvl_flag)
(mkNonTopExternalNameMsg binder)
-- Check whether binder's specialisations contain any out-of-scope variables
; mapM_ (checkBndrIdInScope binder) bndr_vars
......@@ -673,6 +679,9 @@ lintType ty@(TyConApp tc tys)
lintType (ForAllTy tv ty)
= do { lintTyBndrKind tv
; addInScopeVar tv (lintType ty) }
lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
\end{code}
......@@ -711,6 +720,13 @@ lint_co_app ty k tys
= lint_app (ptext (sLit "coercion") <+> quotes (ppr ty)) k tys
----------------
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumTyLit n)
| n >= 0 = return ()
| otherwise = failWithL msg
where msg = ptext (sLit "Negative type literal:") <+> integer n
lintTyLit (StrTyLit _) = return ()
lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
-- (lint_app d fun_kind arg_tys)
-- We have an application (f arg_ty1 .. arg_tyn),
......@@ -1020,7 +1036,7 @@ lookupIdInScope id
Nothing -> do { addErrL out_of_scope
; return id } }
where
out_of_scope = ppr id <+> ptext (sLit "is out of scope")
out_of_scope = pprBndr LetBind id <+> ptext (sLit "is out of scope")
oneTupleDataConId :: Id -- Should not happen
......@@ -1040,7 +1056,7 @@ checkInScope :: SDoc -> Var -> LintM ()
checkInScope loc_msg var =
do { subst <- getTvSubst
; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst))
(hsep [ppr var, loc_msg]) }
(hsep [pprBndr LetBind var, loc_msg]) }
checkTys :: OutType -> OutType -> MsgDoc -> LintM ()
-- check ty2 is subtype of ty1 (ie, has same structure but usage
......@@ -1220,6 +1236,13 @@ mkStrictMsg binder
hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
]
mkNonTopExportedMsg :: Id -> MsgDoc
mkNonTopExportedMsg binder
= hsep [ptext (sLit "Non-top-level binder is marked as exported:"), ppr binder]
mkNonTopExternalNameMsg :: Id -> MsgDoc
mkNonTopExternalNameMsg binder
= hsep [ptext (sLit "Non-top-level binder has an external name:"), ppr binder]
mkKindErrMsg :: TyVar -> Type -> MsgDoc
mkKindErrMsg tyvar arg_ty
......
......@@ -870,10 +870,12 @@ get to a partial application:
\begin{code}
tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
tryEtaReducePrep bndrs expr@(App _ _)
| ok_to_eta_reduce f &&
n_remaining >= 0 &&
and (zipWith ok bndrs last_args) &&
not (any (`elemVarSet` fvs_remaining) bndrs)
| ok_to_eta_reduce f
, n_remaining >= 0
, and (zipWith ok bndrs last_args)
, not (any (`elemVarSet` fvs_remaining) bndrs)
, exprIsHNF remaining_expr -- Don't turn value into a non-value
-- else the behaviour with 'seq' changes
= Just remaining_expr
where
(f, args) = collectArgs expr
......@@ -885,9 +887,9 @@ tryEtaReducePrep bndrs expr@(App _ _)
ok bndr (Var arg) = bndr == arg
ok _ _ = False
-- we can't eta reduce something which must be saturated.
-- We can't eta reduce something which must be saturated.
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
ok_to_eta_reduce _ = False --safe. ToDo: generalise
ok_to_eta_reduce _ = False -- Safe. ToDo: generalise
tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
| not (any (`elemVarSet` fvs) bndrs)
......
......@@ -917,10 +917,10 @@ instance Outputable AltCon where
instance Show AltCon where
showsPrec p con = showsPrecSDoc p (ppr con)
cmpAlt :: Alt b -> Alt b -> Ordering
cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering
cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
ltAlt :: Alt b -> Alt b -> Bool
ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool
ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
cmpAltCon :: AltCon -> AltCon -> Ordering
......
......@@ -15,7 +15,8 @@ module CoreUtils (
mkAltExpr,
-- * Taking expressions apart
findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
findDefault, findAlt, isDefaultAlt,
mergeAlts, trimConArgs, filterAlts,
-- * Properties of expressions
exprType, coreAltType, coreAltsType,
......@@ -69,7 +70,7 @@ import Util
import Pair
import Data.Word
import Data.Bits
import Data.List ( mapAccumL )
import Data.List
\end{code}
......@@ -342,18 +343,18 @@ This makes it easy to find, though it makes matching marginally harder.
\begin{code}
-- | Extract the default case alternative
findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
findDefault alts = (alts, Nothing)
isDefaultAlt :: CoreAlt -> Bool
isDefaultAlt :: (AltCon, a, b) -> Bool
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt _ = False
-- | Find the case alternative corresponding to a particular
-- constructor: panics if no such constructor exists
findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
-- A "Nothing" result *is* legitmiate
-- See Note [Unreachable code]
findAlt con alts
......@@ -369,7 +370,7 @@ findAlt con alts
GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
---------------------------------
mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
mergeAlts [] as2 = as2
......@@ -396,6 +397,83 @@ trimConArgs (LitAlt _) args = ASSERT( null args ) []
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
\end{code}
\begin{code}
filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon
-> Type -- ^ Type of scrutinee (used to prune possibilities)
-> [AltCon] -- ^ Constructors known to be impossible due to the form of the scrutinee
-> [(AltCon, [Var], a)] -- ^ Alternatives
-> ([AltCon], Bool, [(AltCon, [Var], a)])
-- Returns:
-- 1. Constructors that will never be encountered by the *default* case (if any)
-- 2. Whether we managed to refine the default alternative into a specific constructor (for statistcs only)
-- 3. The new alternatives
--
-- NB: the final list of alternatives may be empty:
-- This is a tricky corner case. If the data type has no constructors,
-- which GHC allows, then the case expression will have at most a default
-- alternative.
--
-- If callers need to preserve the invariant that there is always at least one branch
-- in a "case" statement then they will need to manually add a dummy case branch that just
-- calls "error" or similar.
filterAlts us ty imposs_cons alts = (imposs_deflt_cons, refined_deflt, merged_alts)
where
(alts_wo_default, maybe_deflt) = findDefault alts
alt_cons = [con | (con,_,_) <- alts_wo_default]
imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
-- "imposs_deflt_cons" are handled