Commit ca53c383 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge master into the ghc-new-co branch

parents 4f8d7149 246183c6
......@@ -45,7 +45,7 @@ endif
include mk/custom-settings.mk
# No need to update makefiles for these targets:
REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS))
REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS))
# configure touches certain files even if they haven't changed. This
# can mean a lot of unnecessary recompilation after a re-configure, so
......@@ -102,12 +102,6 @@ framework-pkg:
$(MAKE) -C distrib/MacOS $@
endif
# install-docs is a historical target that isn't supported in GHC 6.12. See #3662.
install-docs:
@echo "The install-docs target is not supported in GHC 6.12.1 and later."
@echo "'make install' now installs everything, including documentation."
@exit 1
# If the user says 'make A B', then we don't want to invoke two
# instances of the rule above in parallel:
.NOTPARALLEL:
......
......@@ -1031,18 +1031,6 @@ AC_SUBST([FopCmd])
])# FP_PROG_FOP
# FP_PROG_HSTAGS
# ----------------
# Sets the output variable HstagsCmd to the full Haskell tags program path.
# HstagsCmd is empty if no such program could be found.
AC_DEFUN([FP_PROG_HSTAGS],
[AC_PATH_PROG([HstagsCmd], [hasktags])
if test -z "$HstagsCmd"; then
AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags])
fi
])# FP_PROG_HSTAGS
# FP_PROG_GHC_PKG
# ----------------
# Try to find a ghc-pkg matching the ghc mentioned in the environment variable
......
......@@ -101,7 +101,7 @@ module CLabel (
hasCAF,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
isMathFun, isCas,
isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
pprCLabel
......@@ -590,14 +590,6 @@ maybeAsmTemp (AsmTempLabel uq) = Just uq
maybeAsmTemp _ = Nothing
-- | Check whether a label corresponds to our cas function.
-- We #include the prototype for this, so we need to avoid
-- generating out own C prototypes.
isCas :: CLabel -> Bool
isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas"
isCas _ = False
-- | Check whether a label corresponds to a C function that has
-- a prototype in a system header somehere, or is built-in
-- to the C compiler. For these labels we avoid generating our
......@@ -858,8 +850,8 @@ instance Outputable CLabel where
pprCLabel :: CLabel -> SDoc
#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
| cGhcWithNativeCodeGen == "YES"
= getPprStyle $ \ sty ->
if asmStyle sty then
ptext asmTempLabelPrefix <> pprUnique u
......@@ -867,23 +859,22 @@ pprCLabel (AsmTempLabel u)
char '_' <> pprUnique u
pprCLabel (DynamicLinkerLabel info lbl)
| cGhcWithNativeCodeGen == "YES"
= pprDynamicLinkerAsmLabel info lbl
pprCLabel PicBaseLabel
| cGhcWithNativeCodeGen == "YES"
= ptext (sLit "1b")
pprCLabel (DeadStripPreventer lbl)
| cGhcWithNativeCodeGen == "YES"
= pprCLabel lbl <> ptext (sLit "_dsp")
#endif
pprCLabel lbl =
#if ! OMIT_NATIVE_CODEGEN
getPprStyle $ \ sty ->
if asmStyle sty then
maybe_underscore (pprAsmCLbl lbl)
else
#endif
pprCLbl lbl
pprCLabel lbl
= getPprStyle $ \ sty ->
if cGhcWithNativeCodeGen == "YES" && asmStyle sty
then maybe_underscore (pprAsmCLbl lbl)
else pprCLbl lbl
maybe_underscore doc
| underscorePrefix = pp_cSEP <> doc
......
......@@ -14,6 +14,7 @@
-----------------------------------------------------------------------------
module CmmOpt (
cmmEliminateDeadBlocks,
cmmMiniInline,
cmmMachOpFold,
cmmLoopifyForC,
......@@ -30,10 +31,69 @@ import UniqFM
import Unique
import FastTypes
import Outputable
import BlockId
import Data.Bits
import Data.Word
import Data.Int
import Data.Maybe
import Data.List
import Compiler.Hoopl hiding (Unique)
-- -----------------------------------------------------------------------------
-- Eliminates dead blocks
{-
We repeatedly expand the set of reachable blocks until we hit a
fixpoint, and then prune any blocks that were not in this set. This is
actually a required optimization, as dead blocks can cause problems
for invariants in the linear register allocator (and possibly other
places.)
-}
-- Deep fold over statements could probably be abstracted out, but it
-- might not be worth the effort since OldCmm is moribund
cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
cmmEliminateDeadBlocks [] = []
cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
let -- Calculate what's reachable from what block
reachableMap = foldl' f emptyUFM blocks -- lazy in values
where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
reachableFrom stmts = foldl stmt [] stmts
where
stmt m CmmNop = m
stmt m (CmmComment _) = m
stmt m (CmmAssign _ e) = expr m e
stmt m (CmmStore e1 e2) = expr (expr m e1) e2
stmt m (CmmCall c _ as _ _) = f (actuals m as) c
where f m (CmmCallee e _) = expr m e
f m (CmmPrim _) = m
stmt m (CmmBranch b) = b:m
stmt m (CmmCondBranch e b) = b:(expr m e)
stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
stmt m (CmmJump e as) = expr (actuals m as) e
stmt m (CmmReturn as) = actuals m as
actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
-- We have to do a deep fold into CmmExpr because
-- there may be a BlockId in the CmmBlock literal.
expr m (CmmLit l) = lit m l
expr m (CmmLoad e _) = expr m e
expr m (CmmReg _) = m
expr m (CmmMachOp _ es) = foldl' expr m es
expr m (CmmStackSlot _ _) = m
expr m (CmmRegOff _ _) = m
lit m (CmmBlock b) = b:m
lit m _ = m
-- go todo done
reachable = go [base_id] (setEmpty :: BlockSet)
where go [] m = m
go (x:xs) m
| setMember x m = go xs m
| otherwise = go (add ++ xs) (setInsert x m)
where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
(lookupUFM reachableMap x)
in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
-- The mini-inliner
......
......@@ -248,7 +248,7 @@ pprStmt stmt = case stmt of
| CmmNeverReturns <- ret ->
let myCall = pprCall (pprCLabel lbl) cconv results args safety
in (real_fun_proto lbl, myCall)
| not (isMathFun lbl || isCas lbl) ->
| not (isMathFun lbl) ->
let myCall = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
......
......@@ -111,7 +111,8 @@ check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])
-- if there are view patterns, just give up - don't know what the function is
check qs = (untidy_warns, shadowed_eqns)
where
(warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs)
tidy_qs = map tidy_eqn qs
(warns, used_nos) = check' ([1..] `zip` tidy_qs)
untidy_warns = map untidy_exhaustive warns
shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
not (i `elementOfUniqSet` used_nos)]
......@@ -670,8 +671,6 @@ tidy_pat (CoPat _ pat _) = tidy_pat pat
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
= pat { pat_args = tidy_con id ps }
......@@ -695,16 +694,18 @@ tidy_pat (TuplePat ps boxity ty)
where
arity = length ps
-- Unpack string patterns fully, so we can see when they overlap with
-- each other, or even explicit lists of Chars.
tidy_pat (LitPat lit)
tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
tidy_pat (LitPat lit) = tidy_lit_pat lit
tidy_lit_pat :: HsLit -> Pat Id
-- Unpack string patterns fully, so we can see when they
-- overlap with each other, or even explicit lists of Chars.
tidy_lit_pat lit
| HsString s <- lit
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy)
= unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
(mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
| otherwise
= tidyLitPat lit
where
mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
-----------------
tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
......
......@@ -301,10 +301,9 @@ addTickHsExpr (HsLet binds e) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
(stmts', last_exp') <- addTickLStmts' forQual stmts
(addTickLHsExpr last_exp)
return (HsDo cxt stmts' last_exp' srcloc)
addTickHsExpr (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt stmts' srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
......@@ -424,45 +423,50 @@ addTickLStmts isGuard stmts = do
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
= bindLocals binders $ do
lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
a <- res
return (lstmts', a)
where
binders = collectLStmtsBinders lstmts
= bindLocals (collectLStmtsBinders lstmts) $
do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
; a <- res
; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
addTickStmt _isGuard (LastStmt e ret) = do
liftM2 LastStmt
(addTickLHsExpr e)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
(addTickLHsExprAlways e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' ty) = do
liftM3 ExprStmt
addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
liftM4 ExprStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickStmt _isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs) = do
liftM ParStmt
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
liftM4 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
liftM4 TransformStmt
(addTickLStmts isGuard stmts)
(return ids)
(addTickLHsExprAlways usingExpr)
(addTickMaybeByLHsExpr maybeByExpr)
addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
liftM4 GroupStmt
(addTickLStmts isGuard stmts)
(return binderMap)
(fmapMaybeM addTickLHsExprAlways by)
(fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
(addTickSyntaxExpr hpcSrcSpan mzipExpr)
(addTickSyntaxExpr hpcSrcSpan bindExpr)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
, trS_by = by, trS_using = using
, trS_ret = returnExpr, trS_bind = bindExpr
, trS_fmap = liftMExpr }) = do
t_s <- addTickLStmts isGuard stmts
t_y <- fmapMaybeM addTickLHsExprAlways by
t_u <- addTickLHsExprAlways using
t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
, trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
......@@ -483,12 +487,6 @@ addTickStmtAndBinders isGuard (stmts, ids) =
(addTickLStmts isGuard stmts)
(return ids)
addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
addTickMaybeByLHsExpr maybeByExpr =
case maybeByExpr of
Nothing -> return Nothing
Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
......@@ -569,9 +567,9 @@ addTickHsCmd (HsLet binds c) =
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
(stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
return (HsDo cxt stmts' last_exp' srcloc)
addTickHsCmd (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsDo cxt stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
......@@ -635,10 +633,15 @@ addTickCmdStmt (BindStmt pat c bind fail) = do
(addTickLHsCmd c)
(return bind)
(return fail)
addTickCmdStmt (ExprStmt c bind' ty) = do
liftM3 ExprStmt
addTickCmdStmt (LastStmt c ret) = do
liftM2 LastStmt
(addTickLHsCmd c)
(addTickSyntaxExpr hpcSrcSpan ret)
addTickCmdStmt (ExprStmt c bind' guard' ty) = do
liftM4 ExprStmt
(addTickLHsCmd c)
(return bind')
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickCmdStmt (LetStmt binds) = do
liftM LetStmt
......
......@@ -541,8 +541,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
= dsCmdDo ids local_vars env_ids res_ty stmts body
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
= dsCmdDo ids local_vars env_ids res_ty stmts
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
......@@ -618,7 +618,6 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
-> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
......@@ -626,15 +625,17 @@ dsCmdDo :: DsCmdEnv -- arrow combinators
-- --------------------------
-- A | xs |- do { c } :: [] t
dsCmdDo ids local_vars env_ids res_ty [] body
dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
= dsLCmd ids local_vars env_ids [] res_ty body
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
let
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
(core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids
......@@ -674,7 +675,7 @@ dsCmdStmt
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do
dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
core_mux <- matchEnvStack env_ids []
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
......
This diff is collapsed.
......@@ -106,11 +106,11 @@ matchGuards [] _ rhs _
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty
matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do
matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
......
This diff is collapsed.
......@@ -721,23 +721,19 @@ repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
repE e@(HsDo ctxt sts body _)
repE e@(HsDo ctxt sts _)
| case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
body' <- addBinds ss $ repLE body;
ret <- repNoBindSt body';
e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
e' <- repDoE (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| ListComp <- ctxt
= do { (ss,zs) <- repLSts sts;
body' <- addBinds ss $ repLE body;
ret <- repNoBindSt body';
e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
e' <- repComp (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| otherwise
= notHandled "mdo and [: :]" (ppr e)
= notHandled "mdo, monad comprehension and [: :]" (ppr e)
repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
......@@ -817,7 +813,7 @@ repGuards other
wrapGenSyms (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
= do { x <- repLNormalGE e1 e2;
return ([], x) }
process (L _ (GRHS ss rhs))
......@@ -876,7 +872,7 @@ repSts (LetStmt bs : ss) =
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
repSts (ExprStmt e _ _ : ss) =
repSts (ExprStmt e _ _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
......
......@@ -523,7 +523,7 @@ tidy1 _ (LitPat lit)
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat lit mb_neg eq)
= return (idDsWrapper, tidyNPat lit mb_neg eq)
= return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
-- BangPatterns: Pattern matching is already strict in constructors,
-- tuples etc, so the last case strips off the bang for thoses patterns.
......
......@@ -152,8 +152,14 @@ tidyLitPat (HsString s)
tidyLitPat lit = LitPat lit
----------------
tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
tidyNPat (OverLit val False _ ty) mb_neg _
tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
-- We need this argument because tidyNPat is called
-- both by Match and by Check, but they tidy LitPats
-- slightly differently; and we must desugar
-- literals consistently (see Trac #5117)
-> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
-> Pat Id
tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
......@@ -169,7 +175,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
| isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
| isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
| isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
| isStringTy ty, Just str_lit <- mb_str_lit = tidyLitPat (HsString str_lit)
| isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
......@@ -193,7 +199,7 @@ tidyNPat (OverLit val False _ ty) mb_neg _
(Nothing, HsIsString s) -> Just s
_ -> Nothing
tidyNPat over_lit mb_neg eq
tidyNPat _ over_lit mb_neg eq
= NPat over_lit mb_neg eq
\end{code}
......
......@@ -36,11 +36,6 @@ Flag ghci
Default: False
Manual: True
Flag ncg
Description: Build the NCG.
Default: False
Manual: True
Flag stage1
Description: Is this stage 1?
Default: False
......@@ -88,9 +83,6 @@ Library
CPP-Options: -DGHCI
Include-Dirs: ../libffi/build/include
if !flag(ncg)
CPP-Options: -DOMIT_NATIVE_CODEGEN
Build-Depends: bin-package-db
Build-Depends: hoopl
......@@ -492,10 +484,7 @@ Library
Vectorise.Exp
Vectorise
-- We only need to expose more modules as some of the ncg code is used
-- by the LLVM backend so its always included
if flag(ncg)
Exposed-Modules:
Exposed-Modules:
AsmCodeGen
TargetReg
NCGMonad
......@@ -505,10 +494,6 @@ Library
RegClass
PIC
Platform
Alpha.Regs
Alpha.RegInfo
Alpha.Instr
Alpha.CodeGen
X86.Regs
X86.RegInfo
X86.Instr
......
......@@ -96,6 +96,58 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
@echo '#error Unknown target arch' >> $@
@echo '#endif' >> $@
@echo >> $@
# Sync this with checkOS in configure.ac
@echo 'cTargetOS :: OS' >> $@
@echo '#if linux_TARGET_OS' >> $@
@echo 'cTargetOS = Linux' >> $@
@echo '#elif freebsd_TARGET_OS' >> $@
@echo 'cTargetOS = FreeBSD' >> $@
@echo '#elif netbsd_TARGET_OS' >> $@
@echo 'cTargetOS = NetBSD' >> $@
@echo '#elif openbsd_TARGET_OS' >> $@
@echo 'cTargetOS = OpenBSD' >> $@
@echo '#elif dragonfly_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "dragonfly"' >> $@
@echo '#elif osf1_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "osf"' >> $@
@echo '#elif osf3_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "osf"' >> $@
@echo '#elif hpux_TARGET_OS' >> $@
@echo 'cTargetOS = HPUX' >> $@
@echo '#elif linuxaout_TARGET_OS' >> $@
@echo 'cTargetOS = Linux' >> $@
@echo '#elif kfreebsdgnu_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "kfreebsdgnu"' >> $@
@echo '#elif freebsd2_TARGET_OS' >> $@
@echo 'cTargetOS = FreeBSD' >> $@
@echo '#elif solaris2_TARGET_OS' >> $@
@echo 'cTargetOS = Solaris' >> $@
@echo '#elif cygwin32_TARGET_OS' >> $@
@echo 'cTargetOS = Windows' >> $@
@echo '#elif mingw32_TARGET_OS' >> $@
@echo 'cTargetOS = Windows' >> $@
@echo '#elif darwin_TARGET_OS' >> $@
@echo 'cTargetOS = OSX' >> $@
@echo '#elif gnu_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "gnu"' >> $@
@echo '#elif nextstep2_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "nextstep"' >> $@
@echo '#elif nextstep3_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "nextstep"' >> $@
@echo '#elif sunos4_TARGET_OS' >> $@
@echo 'cTargetOS = Solaris' >> $@
@echo '#elif ultrix_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "ultrix"' >> $@
@echo '#elif irix_TARGET_OS' >> $@
@echo 'cTargetOS = IRIX' >> $@
@echo '#elif aix_TARGET_OS' >> $@
@echo 'cTargetOS = AIX' >> $@
@echo '#elif haiku_TARGET_OS' >> $@
@echo 'cTargetOS = OtherOS "haiku"' >> $@
@echo '#else' >> $@
@echo '#error Unknown target OS' >> $@
@echo '#endif' >> $@
@echo >> $@
@echo 'cProjectName :: String' >> $@
@echo 'cProjectName = "$(ProjectName)"' >> $@
@echo 'cProjectVersion :: String' >> $@
......@@ -371,12 +423,6 @@ endif
endif
ifeq "$(GhcWithNativeCodeGen)" "NO"
# XXX This should logically be a CPP option, but there doesn't seem to
# be a flag for that
compiler_CONFIGURE_OPTS += --ghc-option=-DOMIT_NATIVE_CODEGEN
endif
ifeq "$(TargetOS_CPP)" "openbsd"
compiler_CONFIGURE_OPTS += --ld-options=-E
endif
......
......@@ -31,6 +31,7 @@ import Constants
import FastString
import SMRep
import Outputable
import Config
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
......@@ -44,6 +45,7 @@ import Data.Char ( ord )
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Distribution.System
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
......@@ -395,12 +397,11 @@ mkBits findLabel st proto_insns
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
#ifdef mingw32_TARGET_OS
literal st (MachLabel fs (Just sz) _)
| cTargetOS == Windows
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
#endif
literal st (MachLabel fs _ _) = litlabel st fs
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
......
......@@ -522,12 +522,15 @@ cvtHsDo do_or_lc stmts
| null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
| otherwise
= do { stmts' <- cvtStmts stmts
; body <- case last stmts' of
L _ (ExprStmt body _ _) -> return body
stmt' -> failWith (bad_last stmt')
; return $ HsDo do_or_lc (init stmts') body void }
; let Just (stmts'', last') = snocView stmts'
; last'' <- case last' of
L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
where
bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
, ptext (sLit "(It should be an expression.)") ]
......@@ -539,7 +542,7 @@ cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
; returnL $ LetStmt ds' }
cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
......
This diff is collapsed.
......@@ -63,8 +63,7 @@ instance Eq HsLit where
data HsOverLit id -- An overloaded literal
= OverLit {
ol_val :: OverLitVal,
ol_rebindable :: Bool, -- True <=> rebindable syntax
-- False <=> standard syntax
ol_rebindable :: Bool, -- Note [ol_rebindable]
ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses]
ol_type :: PostTcType }
deriving (Data, Typeable)
......@@ -79,6 +78,19 @@ overLitType :: HsOverLit a -> Type