Commit 7dffc188 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge remote branch 'origin/master'

parents 97db0edc 03d360f2
......@@ -271,7 +271,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
-- See Note [inline sccs]
if inline && gopt Opt_SccProfilingOn dflags then return (L pos funBind) else do
(fvs, (MatchGroup matches' ty)) <-
(fvs, mg@(MG { mg_alts = matches' })) <-
getFreeVars $
addPathEntry name $
addTickMatchGroup False (fun_matches funBind)
......@@ -293,7 +293,7 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do
else
return Nothing
return $ L pos $ funBind { fun_matches = MatchGroup matches' ty
return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }
, fun_tick = tick }
where
......@@ -586,10 +586,10 @@ addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') }
addTickTupArg (Missing ty) = return (Missing ty)
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam (MatchGroup matches ty) = do
addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ MatchGroup matches' ty
return $ mg { mg_alts = matches' }
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match pats opSig gRHSs) =
......@@ -799,9 +799,9 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) =
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup (MatchGroup matches ty) = do
addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ MatchGroup matches' ty
return $ mg { mg_alts = matches' }
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match pats opSig gRHSs) =
......
......@@ -33,7 +33,6 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
import TcType
import TcEvidence
import Type
import CoreSyn
import CoreFVs
import CoreUtils
......@@ -382,7 +381,7 @@ dsCmd ids local_vars stack res_ty (HsCmdApp cmd arg) env_ids = do
-- ---> premap (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) c
dsCmd ids local_vars stack res_ty
(HsCmdLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
(HsCmdLam (MG { mg_alts = [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] }))
env_ids = do
let
pat_vars = mkVarSet (collectPatsBinders pats)
......@@ -483,8 +482,9 @@ case bodies, containing the following fields:
bodies with |||.
\begin{code}
dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
env_ids = do
dsCmd ids local_vars stack res_ty
(HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys }))
env_ids = do
stack_ids <- mapM newSysLocalDs stack
-- Extract and desugar the leaf commands in the case, building tuple
......@@ -526,12 +526,11 @@ dsCmd ids local_vars stack res_ty (HsCmdCase exp (MatchGroup matches match_ty))
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack
pat_ty = funArgTy match_ty
match_ty' = mkFunTy pat_ty sum_ty
core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys
, mg_res_ty = sum_ty }))
-- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches'
core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
core_matches <- matchEnvStack env_ids stack_ids core_body
return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
exprFreeIds core_body `intersectVarSet` local_vars)
......
......@@ -205,11 +205,7 @@ dsExpr (NegApp expr neg_expr)
dsExpr (HsLam a_Match)
= uncurry mkLams <$> matchWrapper LambdaExpr a_Match
dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
= -- So desugar empty HsLamCase to error call
mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case"))
| otherwise
dsExpr (HsLamCase arg matches)
= do { arg_var <- newSysLocalDs arg
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
......@@ -305,12 +301,7 @@ dsExpr (HsSCC cc expr@(L loc _)) = do
dsExpr (HsCoreAnn _ expr)
= dsLExpr expr
dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty))
| isEmptyMatchGroup matches -- A Core 'case' is always non-empty
= -- So desugar empty HsCase to error call
mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case"))
| otherwise
dsExpr (HsCase discrim matches)
= do { core_discrim <- dsLExpr discrim
; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
; return (bindNonRec discrim_var core_discrim matching_code) }
......@@ -499,7 +490,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- constructor aguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code)
<- matchWrapper RecUpd (MatchGroup alts in_out_ty)
<- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty })
; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) }
......@@ -521,7 +512,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- from instance type to family type
tycon = dataConTyCon (head cons_to_upd)
in_ty = mkTyConApp tycon in_inst_tys
in_out_ty = mkFunTy in_ty (mkFamilyTyConApp tycon out_inst_tys)
out_ty = mkFamilyTyConApp tycon out_inst_tys
mk_alt upd_fld_env con
= do { let (univ_tvs, ex_tvs, eq_spec,
......@@ -770,8 +761,8 @@ dsDo stmts
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
......
......@@ -25,6 +25,7 @@ import TysWiredIn
import PrelNames
import Module
import Name
import Util
import SrcLoc
import Outputable
\end{code}
......@@ -56,16 +57,15 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon
-> GRHSs Id (LHsExpr Id) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do
match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
let
match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs
dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty
= ASSERT( notNull grhss )
do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
; let match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs
(\e -> dsLocalBinds binds e)
match_result1
-- NB: nested dsLet inside matchResult
--
return match_result2
; return match_result2 }
dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult
dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))
......
......@@ -917,8 +917,8 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MatchGroup [m] _)) = repLambda m
repE (HsLamCase _ (MatchGroup ms _))
repE (HsLam (MG { mg_alts = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = ms }))
= do { ms' <- mapM repMatchTup ms
; repLamCase (nonEmptyCoreList ms') }
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
......@@ -935,7 +935,7 @@ repE (NegApp x _) = do
repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase e (MatchGroup ms _))
repE (HsCase e (MG { mg_alts = ms }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; repCaseE arg (nonEmptyCoreList ms2) }
......@@ -1166,7 +1166,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
rep_bind (L loc (FunBind { fun_id = fn,
fun_matches = MatchGroup [L _ (Match [] _ (GRHSs guards wheres))] _ }))
fun_matches = MG { mg_alts = [L _ (Match [] _ (GRHSs guards wheres))] } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
......@@ -1175,7 +1175,7 @@ rep_bind (L loc (FunBind { fun_id = fn,
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
......
......@@ -307,7 +307,7 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
match_results = [match_result | (_,_,match_result) <- match_alts]
fail_flag | exhaustive_case
= foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
= foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
| otherwise
= CanFail
......
......@@ -291,9 +291,8 @@ match [] ty eqns
eqn_rhs eqn
| eqn <- eqns ]
match vars@(v:_) ty eqns
= ASSERT( not (null eqns ) )
do { dflags <- getDynFlags
match vars@(v:_) ty eqns -- Eqns *can* be empty
= do { dflags <- getDynFlags
; -- Tidy the first pattern, generating
-- auxiliary bindings if necessary
(aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
......@@ -304,13 +303,18 @@ match vars@(v:_) ty eqns
-- print the view patterns that are commoned up to help debug
; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
; match_results <- mapM match_group grouped
; return (adjustMatchResult (foldr1 (.) aux_binds) $
; match_results <- match_groups grouped
; return (adjustMatchResult (foldr (.) id aux_binds) $
foldr1 combineMatchResults match_results) }
where
dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
dropGroup = map snd
match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
-- Result list of [MatchResult] is always non-empty
match_groups [] = matchEmpty v ty
match_groups gs = mapM match_group gs
match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
match_group [] = panic "match_group"
match_group eqns@((group,_) : _)
......@@ -339,6 +343,14 @@ match vars@(v:_) ty eqns
maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
(filter (not . null) gs))
matchEmpty :: Id -> Type -> DsM [MatchResult]
-- See Note [Empty case expressions]
matchEmpty var res_ty
= return [MatchResult CanFail mk_seq]
where
mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
[(DEFAULT, [], fail)]
matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
-- Real true variables, just like in matchVar, SLPJ p 94
-- No binding to do: they'll all be wildcards by now (done in tidy)
......@@ -394,6 +406,24 @@ getViewPat (ViewPat _ pat _) = unLoc pat
getViewPat _ = panic "getBangPat"
\end{code}
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The list of EquationInfo can be empty, arising from
case x of {} or \case {}
In that situation we desugar to
case x of { _ -> error "pattern match failure" }
The *desugarer* isn't certain whether there really should be no
alternatives, so it adds a default case, as it always does. A later
pass may remove it if it's inaccessible. (See also Note [Empty case
alternatives] in CoreSyn.)
We do *not* deugar simply to
error "empty case"
or some such, because 'x' might be bound to (error "hello"), in which
case we want to see that "hello" exception, not (error "empty case").
See also Note [Case elimination: lifted case] in Simplify.
%************************************************************************
%* *
Tidying patterns
......@@ -693,17 +723,16 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
\begin{code}
matchWrapper ctxt (MatchGroup matches match_ty)
= ASSERT( notNull matches )
do { eqns_info <- mapM mk_eqn_info matches
; new_vars <- selectMatchVars arg_pats
matchWrapper ctxt (MG { mg_alts = matches
, mg_arg_tys = arg_tys
, mg_res_ty = rhs_ty })
= do { eqns_info <- mapM mk_eqn_info matches
; new_vars <- case matches of
[] -> mapM newSysLocalDs arg_tys
(m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
where
arg_pats = map unLoc (hsLMatchPats (head matches))
n_pats = length arg_pats
(_, rhs_ty) = splitFunTysN n_pats match_ty
mk_eqn_info (L _ (Match pats _ grhss))
= do { let upats = map unLoc pats
; match_result <- dsGRHSs ctxt upats grhss rhs_ty
......
......@@ -134,7 +134,8 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
= do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
= ASSERT( notNull arg_eqn_prs )
do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
......
......@@ -236,7 +236,7 @@ matchLiterals :: [Id]
-> DsM MatchResult
matchLiterals (var:vars) ty sub_groups
= ASSERT( all notNull sub_groups )
= ASSERT( notNull sub_groups && all notNull sub_groups )
do { -- Deal with each group
; alts <- mapM match_group sub_groups
......
......@@ -52,7 +52,8 @@ Library
array >= 0.1 && < 0.5,
filepath >= 1 && < 1.4,
Cabal,
hpc
hpc,
transformers
if flag(stage1) && impl(ghc < 7.5)
Build-Depends: old-time >= 1 && < 1.2
......
......@@ -831,11 +831,12 @@ patterns in each equation.
\begin{code}
data MatchGroup id body
= MatchGroup
[LMatch id body] -- The alternatives
PostTcType -- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
= MG { mg_alts :: [LMatch id body] -- The alternatives
, mg_arg_tys :: [PostTcType] -- Types of the arguments, t1..tn
, mg_res_ty :: PostTcType } -- Type of the result, tr
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
deriving (Data, Typeable)
type LMatch id body = Located (Match id body)
......@@ -849,17 +850,14 @@ data Match id body
deriving (Data, Typeable)
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MatchGroup ms _) = null ms
isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
matchGroupArity :: MatchGroup id body -> Arity
matchGroupArity (MatchGroup [] _)
= panic "matchGroupArity" -- Precondition: MatchGroup is non-empty
matchGroupArity (MatchGroup (match:matches) _)
= ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
-- Assertion just checks that all the matches have the same number of pats
n_pats
where
n_pats = length (hsLMatchPats match)
-- Precondition: MatchGroup is non-empty
-- This is called before type checking, when mg_arg_tys is not set
matchGroupArity (MG { mg_alts = alts })
| (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
hsLMatchPats :: LMatch id body -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats
......@@ -884,7 +882,7 @@ We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> MatchGroup idR body -> SDoc
pprMatches ctxt (MatchGroup matches _)
pprMatches ctxt (MG { mg_alts = matches })
= vcat (map (pprMatch ctxt) (map unLoc matches))
-- Don't print the type; it's only a place-holder before typechecking
......
......@@ -128,7 +128,7 @@ unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
mkMatchGroup matches = MatchGroup matches placeHolderType
mkMatchGroup matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType }
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
......
......@@ -559,7 +559,8 @@ tc_iface_decl _ _ (IfaceAxiom {ifName = ax_occ, ifTyCon = tc, ifAxBranches = bra
= bindIfaceTyVars tv_bndrs $ \ tvs -> do
{ tc_lhs <- mapM tcIfaceType lhs
; tc_rhs <- tcIfaceType rhs
; let branch = CoAxBranch { cab_tvs = tvs
; let branch = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = tvs
, cab_lhs = tc_lhs
, cab_rhs = tc_rhs }
; return branch }
......
......@@ -189,11 +189,15 @@ genCall env (PrimTarget MO_Touch) _ _
genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
ty = cmmToLlvmType $ localRegType dst
width = widthToLlvmFloat w
castV <- mkLocalVar ty
(env2, ve, stmts2, top2) <- exprToVar env1 e
let stmt = Assignment dstV $ Cast LM_Uitofp ve width
stmts = stmts1 `appOL` stmts2 `snocOL` stmt
let stmt3 = Assignment castV $ Cast LM_Uitofp ve width
stmt4 = Store castV dstV
stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4
return (env2, stmts, top1 ++ top2)
genCall _ (PrimTarget (MO_UF_Conv _)) [_] args =
panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
"Can only handle 1, given" ++ show (length args) ++ "."
......
......@@ -530,6 +530,7 @@ data ExtensionFlag
| Opt_LambdaCase
| Opt_MultiWayIf
| Opt_TypeHoles
| Opt_EmptyCase
deriving (Eq, Enum, Show)
-- | Contains not only a collection of 'GeneralFlag's but also a plethora of
......@@ -2610,7 +2611,8 @@ xFlags = [
( "UndecidableInstances", Opt_UndecidableInstances, nop ),
( "IncoherentInstances", Opt_IncoherentInstances, nop ),
( "PackageImports", Opt_PackageImports, nop ),
( "TypeHoles", Opt_TypeHoles, nop )
( "TypeHoles", Opt_TypeHoles, nop ),
( "EmptyCase", Opt_EmptyCase, nop )
]
defaultFlags :: Settings -> [GeneralFlag]
......
......@@ -147,7 +147,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr,
ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
}
......@@ -238,7 +238,7 @@ sparcNcgImpl dflags
-- default to the panic below. To support allocating extra stack on
-- more platforms provide a definition of ncgAllocMoreStack.
--
noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr
noAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr)
noAllocMoreStack amount _
= panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
++ " If you are trying to compile SHA1.hs from the crypto library then this\n"
......@@ -518,9 +518,9 @@ cmmNativeGen dflags ncgImpl us cmm count
Linear.regAlloc dflags proc
case maybe_more_stack of
Nothing -> return ( alloced, ra_stats )
Just amount ->
return ( ncgAllocMoreStack ncgImpl amount alloced
, ra_stats )
Just amount -> do
alloced' <- ncgAllocMoreStack ncgImpl amount alloced
return (alloced', ra_stats )
let ((alloced, regAllocStats), usAlloc)
= {-# SCC "RegAlloc" #-}
......
......@@ -36,6 +36,7 @@ import CLabel
import Outputable
import Platform
import FastBool
import UniqSupply
--------------------------------------------------------------------------------
-- Size of a PPC memory address, in bytes.
......@@ -80,11 +81,11 @@ allocMoreStack
:: Platform
-> Int
-> NatCmmDecl statics PPC.Instr.Instr
-> NatCmmDecl statics PPC.Instr.Instr
-> UniqSM (NatCmmDecl statics PPC.Instr.Instr)
allocMoreStack _ _ top@(CmmData _ _) = top
allocMoreStack _ _ top@(CmmData _ _) = return top
allocMoreStack platform amount (CmmProc info lbl live (ListGraph code)) =
CmmProc info lbl live (ListGraph (map insert_stack_insns code))
return (CmmProc info lbl live (ListGraph (map insert_stack_insns code)))
where
alloc = mkStackAllocInstr platform amount
dealloc = mkStackDeallocInstr platform amount
......
......@@ -36,6 +36,9 @@ import CLabel
import DynFlags
import UniqSet
import Unique
import UniqSupply
import Control.Monad
-- Size of an x86/x86_64 memory address, in bytes.
--
......@@ -622,7 +625,7 @@ x86_mkSpillInstr
-> Instr
x86_mkSpillInstr dflags reg delta slot
= let off = spillSlotToOffset dflags slot - delta
= let off = spillSlotToOffset platform slot - delta
in
case targetClassOfReg platform reg of
RcInteger -> MOV (archWordSize is32Bit)
......@@ -642,7 +645,7 @@ x86_mkLoadInstr
-> Instr
x86_mkLoadInstr dflags reg delta slot
= let off = spillSlotToOffset dflags slot - delta
= let off = spillSlotToOffset platform slot - delta
in
case targetClassOfReg platform reg of
RcInteger -> MOV (archWordSize is32Bit)
......@@ -653,20 +656,25 @@ x86_mkLoadInstr dflags reg delta slot
where platform = targetPlatform dflags
is32Bit = target32Bit platform
spillSlotSize :: DynFlags -> Int
spillSlotSize :: Platform -> Int
spillSlotSize dflags = if is32Bit then 12 else 8
where is32Bit = target32Bit (targetPlatform dflags)
where is32Bit = target32Bit dflags
maxSpillSlots :: DynFlags -> Int
maxSpillSlots dflags
= ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize dflags) - 1
= ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1
-- = 0 -- useful for testing allocMoreStack
-- number of bytes that the stack pointer should be aligned to
stackAlign :: Int
stackAlign = 16
-- convert a spill slot number to a *byte* offset, with no sign:
-- decide on a per arch basis whether you are spilling above or below
-- the C stack pointer.
spillSlotToOffset :: DynFlags -> Int -> Int
spillSlotToOffset dflags slot
= 64 + spillSlotSize dflags * slot
spillSlotToOffset :: Platform -> Int -> Int
spillSlotToOffset platform slot
= 64 + spillSlotSize platform * slot
--------------------------------------------------------------------------------
......@@ -772,6 +780,16 @@ i386_insert_ffrees blocks
insertGFREEs (BasicBlock id insns)
= BasicBlock id (insertBeforeNonlocalTransfers GFREE insns)
insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]
insertBeforeNonlocalTransfers insert insns
= foldr p [] insns
where p insn r = case insn of
CALL _ _ -> insert : insn : r
JMP _ _ -> insert : insn : r
JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"
_ -> insn : r
-- if you ever add a new FP insn to the fake x86 FP insn set,
-- you must update this too
is_G_instr :: Instr -> Bool
......@@ -821,36 +839,74 @@ is_G_instr instr
-- - rename the virtual regs, so that we re-use vreg names and hence
-- stack slots for non-overlapping vregs.
--
-- Note that when a block is both a non-local entry point (with an
-- info table) and a local branch target, we have to split it into
-- two, like so:
--
-- <info table>
-- L:
-- <code>
--
-- becomes
--
-- <info table>
-- L:
-- subl $rsp, N
-- jmp Lnew
-- Lnew:
-- <code>
--
-- and all branches pointing to L are retargetted to point to Lnew.
-- Otherwise, we would repeat the $rsp adjustment for each branch to
-- L.
--
allocMoreStack
:: Platform
-> Int
-> NatCmmDecl statics X86.Instr.Instr
-> NatCmmDecl statics X86.Instr.Instr
allocMoreStack _ _ top@(CmmData _ _) = top
allocMoreStack platform amount (CmmProc info lbl live (ListGraph code)) =
CmmProc info lbl live (ListGraph (map insert_stack_insns code))
where
alloc = mkStackAllocInstr platform amount
dealloc = mkStackDeallocInstr platform amount
is_entry_point id = id `mapMember` info