Commit 1e07bd74 authored by Me at work's avatar Me at work

Merge remote-tracking branch 'laptop/newcg' into newcg

parents 8fb67a2a 5cf9c019
......@@ -125,6 +125,8 @@ _darcs/
/docs/users_guide/ug-book.xml
/docs/users_guide/ug-ent.xml
/docs/users_guide/users_guide.xml
/docs/users_guide/users_guide.pdf
/docs/users_guide/users_guide.ps
/docs/users_guide/users_guide/
/docs/users_guide/what_glasgow_exts_does.gen.xml
/driver/ghc/dist/
......@@ -182,6 +184,7 @@ _darcs/
/libraries/time/
/libraries/*/dist-boot/
/libraries/*/dist-install/
/libraries/dist-haddock/
/mk/are-validating.mk
/mk/build.mk
/mk/config.h
......@@ -237,3 +240,5 @@ _darcs/
/extra-gcc-opts
.tm_properties
......@@ -158,7 +158,6 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
test -z "[$]2" || eval "[$]2=ArchX86"
;;
x86_64)
GET_ARM_ISA()
test -z "[$]2" || eval "[$]2=ArchX86_64"
;;
powerpc)
......@@ -174,16 +173,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 +211,19 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
freebsd)
test -z "[$]2" || eval "[$]2=OSFreeBSD"
;;
dragonfly)
test -z "[$]2" || eval "[$]2=OSDragonFly"
;;
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)
dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku)
test -z "[$]2" || eval "[$]2=OSUnknown"
;;
*)
......@@ -366,6 +362,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'
......@@ -373,17 +370,33 @@ 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"
SettingsTouchCommand='touch'
if test -z "$LlcCmd"
then
SettingsLlcCommand="llc"
else
SettingsLlcCommand="$LlcCmd"
fi
if test -z "$OptCmd"
then
SettingsOptCommand="opt"
else
SettingsOptCommand="$OptCmd"
fi
fi
AC_SUBST(SettingsCCompilerCommand)
AC_SUBST(SettingsCCompilerFlags)
AC_SUBST(SettingsArCommand)
AC_SUBST(SettingsPerlCommand)
AC_SUBST(SettingsDllWrapCommand)
AC_SUBST(SettingsWindresCommand)
AC_SUBST(SettingsTouchCommand)
AC_SUBST(SettingsLlcCommand)
AC_SUBST(SettingsOptCommand)
])
......@@ -516,7 +529,8 @@ AC_DEFUN([FP_EVAL_STDERR],
# XXX
#
# $1 = the variable to set
# $2 = the command to look for
# $2 = the with option name
# $3 = the command to look for
#
AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG],
[
......@@ -534,10 +548,14 @@ AC_ARG_WITH($2,
[
if test "$HostOS" != "mingw32"
then
AC_PATH_PROG([$1], [$2])
if test "$target_alias" = "" ; then
AC_PATH_PROG([$1], [$3])
else
AC_PATH_PROG([$1], [$target_alias-$3])
fi
if test -z "$$1"
then
AC_MSG_ERROR([cannot find $2 in your PATH, no idea how to link])
AC_MSG_ERROR([cannot find $3 in your PATH])
fi
fi
]
......@@ -545,6 +563,35 @@ AC_ARG_WITH($2,
]) # FP_ARG_WITH_PATH_GNU_PROG
# FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL
# --------------------
# XXX
#
# $1 = the variable to set
# $2 = the command to look for
#
AC_DEFUN([FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL],
[
AC_ARG_WITH($2,
[AC_HELP_STRING([--with-$2=ARG],
[Use ARG as the path to $2 [default=autodetect]])],
[
if test "$HostOS" = "mingw32"
then
AC_MSG_WARN([Request to use $withval will be ignored])
else
$1=$withval
fi
],
[
if test "$HostOS" != "mingw32"
then
AC_PATH_PROG([$1], [$2])
fi
]
)
]) # FP_ARG_WITH_PATH_GNU_PROG_OPTIONAL
# FP_PROG_CONTEXT_DIFF
# --------------------
# Figure out how to do context diffs. Sets the output variable ContextDiffCmd.
......@@ -596,7 +643,7 @@ AC_CHECK_TYPE([$1], [], [], [$3])[]dnl
m4_pushdef([fp_Cache], [AS_TR_SH([fp_cv_alignment_$1])])[]dnl
AC_CACHE_CHECK([alignment of $1], [fp_Cache],
[if test "$AS_TR_SH([ac_cv_type_$1])" = yes; then
FP_COMPUTE_INT([(long) (&((struct { char c; $1 ty; } *)0)->ty)],
FP_COMPUTE_INT([offsetof(struct { char c; $1 ty; },ty)],
[fp_Cache],
[AC_INCLUDES_DEFAULT([$3])],
[AC_MSG_ERROR([cannot compute alignment ($1)
......@@ -1536,6 +1583,7 @@ AC_SUBST([ProjectPatchLevel])
# timer_create() in certain versions of Linux (see bug #1933).
#
AC_DEFUN([FP_CHECK_TIMER_CREATE],
if test "$cross_compiling" = "no" ; then
[AC_CACHE_CHECK([for a working timer_create(CLOCK_REALTIME)],
[fptools_cv_timer_create_works],
[AC_TRY_RUN([
......@@ -1659,6 +1707,7 @@ case $fptools_cv_timer_create_works in
yes) AC_DEFINE([USE_TIMER_CREATE], 1,
[Define to 1 if we can use timer_create(CLOCK_PROCESS_CPUTIME_ID,...)]);;
esac
fi
])
# FP_ICONV
......@@ -1886,7 +1935,9 @@ case "$1" in
freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku)
$2="$1"
;;
freebsd8) # like i686-gentoo-freebsd8
freebsd*) # like i686-gentoo-freebsd7
# i686-gentoo-freebsd8
# i686-gentoo-freebsd8.2
$2="freebsd"
;;
*)
......@@ -1905,6 +1956,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
......@@ -1951,19 +2008,26 @@ AC_DEFUN([XCODE_VERSION],[
# FIND_GCC()
# --------------------------------
# Finds where gcc is
#
# $1 = the variable to set
# $2 = the with option name
# $3 = the command to look for
AC_DEFUN([FIND_GCC],[
if test "$TargetOS_CPP" = "darwin" &&
test "$XCodeVersion1" -ge 4
test "$XCodeVersion1" -eq 4 &&
test "$XCodeVersion2" -lt 2
then
# 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([$1], [gcc-4.2], [gcc-4.2])
elif test "$windows" = YES
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])
$1="$CC"
else
FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc])
FP_ARG_WITH_PATH_GNU_PROG([$1], [$2], [$3])
fi
export CC
WhatGccIsCalled="$CC"
AC_SUBST(WhatGccIsCalled)
AC_SUBST($1)
])
# LocalWords: fi
......@@ -42,12 +42,18 @@ module DataCon (
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
deepSplitProductType_maybe
deepSplitProductType_maybe,
-- ** Promotion related functions
promoteType, isPromotableType, isPromotableTyCon,
buildPromotedTyCon, buildPromotedDataCon,
) where
#include "HsVersions.h"
import Type
import TypeRep( Type(..) ) -- Used in promoteType
import Kind
import Unify
import Coercion
import TyCon
......@@ -61,6 +67,7 @@ import Util
import BasicTypes
import FastString
import Module
import VarEnv
import qualified Data.Data as Data
import qualified Data.Typeable
......@@ -959,4 +966,86 @@ computeRep stricts tys
where
(_tycon, _tycon_args, arg_dc, arg_tys)
= deepSplitProductType "unbox_strict_arg_ty" ty
\end{code}
\ No newline at end of file
\end{code}
%************************************************************************
%* *
Promoting of data types to the kind level
%* *
%************************************************************************
These two 'buildPromoted..' functions are here because
* They belong together
* 'buildPromotedTyCon' is used by promoteType
* 'buildPromotedTyCon' depends on DataCon stuff
\begin{code}
buildPromotedTyCon :: TyCon -> TyCon
buildPromotedTyCon tc
= mkPromotedTyCon tc tySuperKind
buildPromotedDataCon :: DataCon -> TyCon
buildPromotedDataCon dc
= ASSERT ( isPromotableType ty )
mkPromotedDataTyCon dc (getName dc) (getUnique dc) kind arity
where
ty = dataConUserType dc
kind = promoteType ty
arity = dataConSourceArity dc
\end{code}
Note [Promoting a Type to a Kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppsoe we have a data constructor D
D :: forall (a:*). Maybe a -> T a
We promote this to be a type constructor 'D:
'D :: forall (k:BOX). 'Maybe k -> 'T k
The transformation from type to kind is done by promoteType
* Convert forall (a:*) to forall (k:BOX), and substitute
* Ensure all foralls are at the top (no higher rank stuff)
* Ensure that all type constructors mentioned (Maybe and T
in the example) are promotable; that is, they have kind
* -> ... -> * -> *
\begin{code}
isPromotableType :: Type -> Bool
isPromotableType ty
= all (isLiftedTypeKind . tyVarKind) tvs
&& go rho
where
(tvs, rho) = splitForAllTys ty
go (TyConApp tc tys) | Just n <- isPromotableTyCon tc
= tys `lengthIs` n && all go tys
go (FunTy arg res) = go arg && go res
go (TyVarTy tvar) = tvar `elem` tvs
go _ = False
-- If tc's kind is [ *^n -> * ] returns [ Just n ], else returns [ Nothing ]
isPromotableTyCon :: TyCon -> Maybe Int
isPromotableTyCon tc
| all isLiftedTypeKind (res:args) = Just $ length args
| otherwise = Nothing
where
(args, res) = splitKindFunTys (tyConKind tc)
-- | Promotes a type to a kind.
-- Assumes the argument satisfies 'isPromotableType'
promoteType :: Type -> Kind
promoteType ty
= mkForAllTys kvs (go rho)
where
(tvs, rho) = splitForAllTys ty
kvs = [ mkKindVar (tyVarName tv) tySuperKind | tv <- tvs ]
env = zipVarEnv tvs kvs
go (TyConApp tc tys) = mkTyConApp (buildPromotedTyCon tc) (map go tys)
go (FunTy arg res) = mkArrowKind (go arg) (go res)
go (TyVarTy tv) | Just kv <- lookupVarEnv env tv
= TyVarTy kv
go _ = panic "promoteType" -- Argument did not satisfy isPromotableType
\end{code}
......@@ -26,6 +26,7 @@ module MkId (
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody, unwrapFamInstScrut,
wrapTypeFamInstBody, unwrapTypeFamInstScrut,
mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
......@@ -227,7 +228,7 @@ mkDataConIds wrap_name wkr_name data_con
= DCIds Nothing nt_work_id
| any isBanged all_strict_marks -- Algebraic, needs wrapper
|| not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs
|| not (null eq_spec) -- NB: LoadIface.ifaceDeclImplicitBndrs
|| isFamInstTyCon tycon -- depends on this test
= DCIds (Just alg_wrap_id) wrk_id
......@@ -709,12 +710,22 @@ wrapFamInstBody tycon args body
| otherwise
= body
-- Same as `wrapFamInstBody`, but for type family instances, which are
-- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom args body
= mkCast body (mkSymCo (mkAxInstCo axiom args))
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast scrut (mkAxInstCo co_con args)
| otherwise
= scrut
unwrapTypeFamInstScrut :: CoAxiom -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom args scrut
= mkCast scrut (mkAxInstCo axiom args)
\end{code}
......
......@@ -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})
......
......@@ -209,7 +209,7 @@ pprNameSpaceBrief TcClsName = ptext (sLit "tc")
-- demoteNameSpace lowers the NameSpace if possible. We can not know
-- in advance, since a TvName can appear in an HsTyVar.
-- see Note [Demotion]
-- See Note [Demotion] in RnEnv
demoteNameSpace :: NameSpace -> Maybe NameSpace
demoteNameSpace VarName = Nothing
demoteNameSpace DataName = Nothing
......@@ -217,24 +217,6 @@ demoteNameSpace TvName = Nothing
demoteNameSpace TcClsName = Just DataName
\end{code}
Note [Demotion]
~~~~~~~~~~~~~~~
When the user writes:
data Nat = Zero | Succ Nat
foo :: f Zero -> Int
'Zero' in the type signature of 'foo' is parsed as:
HsTyVar ("Zero", TcClsName)
When the renamer hits this occurence of 'Zero' it's going to realise
that it's not in scope. But because it is renaming a type, it knows
that 'Zero' might be a promoted data constructor, so it will demote
its namespace to DataName and do a second lookup.
The final result (after the renamer) will be:
HsTyVar ("Zero", DataName)
%************************************************************************
%* *
......@@ -371,7 +353,7 @@ sequentially starting at 0.
So we can make a Unique using
mkUnique ns key :: Unique
where 'ns' is a Char reprsenting the name space. This in turn makes it
where 'ns' is a Char representing the name space. This in turn makes it
easy to build an OccEnv.
\begin{code}
......
......@@ -273,6 +273,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)
......@@ -503,6 +506,7 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
-- ^ Take a list of GREs which have the right OccName
-- Pick those GREs that are suitable for this RdrName
-- And for those, keep only only the Provenances that are suitable
-- Only used for Qual and Unqual, not Orig or Exact
--
-- Consider:
--
......@@ -519,7 +523,8 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt]
-- the locally-defined @f@, and a GRE for the imported @f@, with a /single/
-- provenance, namely the one for @Baz(f)@.
pickGREs rdr_name gres
= mapCatMaybes pick gres
= ASSERT2( isSrcRdrName rdr_name, ppr rdr_name )
mapCatMaybes pick gres
where
rdr_is_unqual = isUnqual rdr_name
rdr_is_qual = isQual_maybe rdr_name
......
......@@ -85,7 +85,7 @@ import FastTypes
import FastString
import Outputable
import StaticFlags ( opt_SuppressVarKinds )
-- import StaticFlags ( opt_SuppressVarKinds )
import Data.Data
\end{code}
......@@ -211,9 +211,11 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
\begin{code}
instance Outputable Var where
ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
<+> if (not opt_SuppressVarKinds) then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
else empty
ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
-- Printing the type on every occurrence is too much!
-- <+> if (not opt_SuppressVarKinds)
-- then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
-- else empty
ppr_debug :: Var -> SDoc
ppr_debug (TyVar {}) = ptext (sLit "tv")
......
......@@ -24,17 +24,13 @@ cmmOfZgraph tops = map mapTop tops
data ValueDirection = Arguments | Results
add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
add_hints :: ForeignTarget -> ValueDirection -> [a] -> [Old.CmmHinted a]
add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
get_hints :: Convention -> ValueDirection -> [ForeignHint]
get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
get_hints _other_conv _vd = repeat NoHint
get_conv :: ForeignTarget -> Convention
get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
get_conv (ForeignTarget _ fc) = Foreign fc
get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint]
get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints
get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results = hints
get_hints (PrimTarget _) _vd = repeat NoHint
cmm_target :: ForeignTarget -> Old.CmmCallTarget
cmm_target (PrimTarget op) = Old.CmmPrim op
......@@ -89,8 +85,8 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
CmmUnsafeForeignCall target ress args ->
Old.CmmCall (cmm_target target)
(add_hints (get_conv target) Results ress)
(add_hints (get_conv target) Arguments args)
(add_hints target Results ress)
(add_hints target Arguments args)
Old.CmmMayReturn
last :: CmmNode O C -> () -> [Old.CmmStmt]
......@@ -105,8 +101,10 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
, Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
CmmCall e _ _ _ _ -> [Old.CmmJump e []]
-- ToDo: STG Live
CmmCall e _ _ _ _ -> [Old.CmmJump e Nothing]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts
where Just block = mapLookup bid $ toBlockMap g
......@@ -194,7 +194,7 @@ checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond expr
= cmmLintErr (\platform -> hang (text "expression is not a conditional:") 2
(pprPlatform platform expr))
(pprPlatform platform expr))