Commit 1cec00db authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org//ghc

parents 980372f3 4c550307
......@@ -74,6 +74,7 @@ _darcs/
/libraries/stm/
/libraries/template-haskell/
/libraries/terminfo/
/libraries/transformers
/libraries/unix/
/libraries/utf8-string/
/libraries/vector/
......
......@@ -203,9 +203,6 @@ pprStmt platform stmt = case stmt of
pprCFunType (pprCLabel platform lbl) cconv results args <>
noreturn_attr <> semi
fun_proto lbl = ptext (sLit ";EF_(") <>
pprCLabel platform lbl <> char ')' <> semi
noreturn_attr = case ret of
CmmNeverReturns -> text "__attribute__ ((noreturn))"
CmmMayReturn -> empty
......@@ -226,12 +223,7 @@ pprStmt platform stmt = case stmt of
let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
in (real_fun_proto lbl, myCall)
| not (isMathFun lbl) ->
let myCall = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
$$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
)
in (fun_proto lbl, myCall)
pprForeignCall platform (pprCLabel platform lbl) cconv results args
_ ->
(empty {- no proto -},
pprCall platform cast_fn cconv results args <> semi)
......@@ -241,19 +233,36 @@ pprStmt platform stmt = case stmt of
vcat $ map (pprStmt platform) stmts
CmmCall (CmmPrim op _) results args _ret ->
pprCall platform ppr_fn CCallConv results args'
where
ppr_fn = pprCallishMachOp_for_C op
-- The mem primops carry an extra alignment arg, must drop it.
-- We could maybe emit an alignment directive using this info.
args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args
| otherwise = args
proto $$ fn_call
where
cconv = CCallConv
fn = pprCallishMachOp_for_C op
(proto, fn_call)
-- The mem primops carry an extra alignment arg, must drop it.
-- We could maybe emit an alignment directive using this info.
-- We also need to cast mem primops to prevent conflicts with GCC
-- builtins (see bug #5967).
| op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
= pprForeignCall platform fn cconv results (init args)
| otherwise
= (empty, pprCall platform fn cconv results args)
CmmBranch ident -> pprBranch ident
CmmCondBranch expr ident -> pprCondBranch platform expr ident
CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi
CmmSwitch arg ids -> pprSwitch platform arg ids
pprForeignCall :: Platform -> SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc)
pprForeignCall platform fn cconv results args = (proto, fn_call)
where
fn_call = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
$$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
)
cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
pprCFunType ppr_fn cconv ress args
= res_type ress <+>
......
......@@ -663,7 +663,7 @@ arityType env (App fun arg )
-- The difference is observable using 'seq'
--
arityType env (Case scrut _ _ alts)
| exprIsBottom scrut
| exprIsBottom scrut || null alts
= ABot 0 -- Do not eta expand
-- See Note [Dealing with bottom (1)]
| otherwise
......@@ -829,14 +829,18 @@ etaInfoApp subst (Cast e co1) eis
where
co' = CoreSubst.substCo subst co1
etaInfoApp subst (Case e b _ alts) eis
= Case (subst_expr subst e) b1 (coreAltsType alts') alts'
etaInfoApp subst (Case e b ty alts) eis
= Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'
where
(subst1, b1) = substBndr subst b
alts' = map subst_alt alts
subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis)
where
(subst2,bs') = substBndrs subst1 bs
mk_alts_ty ty [] = ty
mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis
mk_alts_ty _ (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis
etaInfoApp subst (Let b e) eis
= Let b' (etaInfoApp subst' e eis)
......
......@@ -486,7 +486,7 @@ freeVars (Case scrut bndr ty alts)
scrut2 = freeVars scrut
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = foldr1 unionFVs alts_fvs_s
alts_fvs = foldr unionFVs noFVs alts_fvs_s
fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
(con, args, rhs2))
......
......@@ -498,9 +498,6 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
-- the simplifer correctly eliminates case that can't
-- possibly match.
checkCaseAlts e _ []
= addErrL (mkNullAltsMsg e)
checkCaseAlts e ty alts =
do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
......@@ -1116,11 +1113,6 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
------------------------------------------------------
-- Messages for case expressions
mkNullAltsMsg :: CoreExpr -> MsgDoc
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
mkDefaultArgsMsg :: [Var] -> MsgDoc
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
......
......@@ -221,7 +221,8 @@ These data types are the heart of the compiler
-- This is one of the more complicated elements of the Core language,
-- and comes with a number of restrictions:
--
-- 1. The list of alternatives is non-empty
-- 1. The list of alternatives may be empty;
-- See Note [Empty case alternatives]
--
-- 2. The 'DEFAULT' case alternative must be first in the list,
-- if it occurs at all.
......@@ -338,11 +339,59 @@ Note [CoreSyn let goal]
application, its arguments are trivial, so that the constructor can be
inlined vigorously.
Note [Type let]
~~~~~~~~~~~~~~~
See #type_let#
Note [Empty case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The alternatives of a case expression should be exhaustive. A case expression
can have empty alternatives if (and only if) the scrutinee is bound to raise
an exception or diverge. So:
Case (error Int "Hello") b Bool []
is fine, and has type Bool. This is one reason we need a type on
the case expression: if the alternatives are empty we can't get the type
from the alternatives! I'll write this
case (error Int "Hello") of Bool {}
with the return type just before the alterantives.
Here's another example:
data T
f :: T -> Bool
f = \(x:t). case x of Bool {}
Since T has no data constructors, the case alterantives are of course
empty. However note that 'x' is not bound to a visbily-bottom value;
it's the *type* that tells us it's going to diverge. Its a bit of a
degnerate situation but we do NOT want to replace
case x of Bool {} --> error Bool "Inaccessible case"
because x might raise an exception, and *that*'s what we want to see!
(Trac #6067 is an example.) To preserve semantics we'd have to say
x `seq` error Bool "Inaccessible case"
but the 'seq' is just a case, so we are back to square 1. Or I suppose
we could say
x |> UnsafeCoerce T Bool
but that loses all trace of the fact that this originated with an empty
set of alternatives.
We can use the empty-alternative construct to coerce error values from
one type to another. For example
f :: Int -> Int
f n = error "urk"
g :: Int -> (# Char, Bool #)
g x = case f x of { 0 -> ..., n -> ... }
Then if we inline f in g's RHS we get
case (error Int "urk") of (# Char, Bool #) { ... }
and we can discard the alternatives since the scrutinee is bottom to give
case (error Int "urk") of (# Char, Bool #) {}
This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
if for no other reason that we don't need to instantiate the (~) at an
unboxed type.
%************************************************************************
%* *
Ticks
......
......@@ -392,8 +392,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr
size_up (Case (Var v) _ _ alts)
| v `elem` top_args -- We are scrutinising an argument variable
= alts_size (foldr1 addAltSize alt_sizes)
(foldr1 maxSize alt_sizes)
= alts_size (foldr addAltSize sizeZero alt_sizes)
(foldr maxSize sizeZero alt_sizes)
-- Good to inline if an arg is scrutinised, because
-- that may eliminate allocation in the caller
-- And it eliminates the case itself
......
......@@ -187,15 +187,7 @@ mkCast (Coercion e_co) co
-- The guard here checks that g has a (~#) on both sides,
-- otherwise decomposeCo fails. Can in principle happen
-- with unsafeCoerce
= Coercion new_co
where
-- g :: (s1 ~# s2) ~# (t1 ~# t2)
-- g1 :: s1 ~# t1
-- g2 :: s2 ~# t2
new_co = mkSymCo g1 `mkTransCo` e_co `mkTransCo` g2
[_reflk, g1, g2] = decomposeCo 3 co
-- Remember, (~#) :: forall k. k -> k -> *
-- so it takes *three* arguments, not two
= Coercion (mkCoCast e_co co)
mkCast (Cast expr co2) co
= ASSERT(let { Pair from_ty _to_ty = coercionKind co;
......
......@@ -13,7 +13,7 @@ module MkCore (
mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkWildCase, mkIfThenElse,
mkWildValBinder, mkWildEvBinder,
sortQuantVars,
sortQuantVars, castBottomExpr,
-- * Constructing boxed literals
mkWordExpr, mkWordExprWord,
......@@ -209,6 +209,16 @@ mkIfThenElse guard then_expr else_expr
= mkWildCase guard boolTy (exprType then_expr)
[ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag!
(DataAlt trueDataCon, [], then_expr) ]
castBottomExpr :: CoreExpr -> Type -> CoreExpr
-- (castBottomExpr e ty), assuming that 'e' diverges,
-- return an expression of type 'ty'
-- See Note [Empty case alternatives] in CoreSyn
castBottomExpr e res_ty
| e_ty `eqType` res_ty = e
| otherwise = Case e (mkWildValBinder e_ty) res_ty []
where
e_ty = exprType e
\end{code}
The functions from this point don't really do anything cleverer than
......
......@@ -620,12 +620,11 @@ addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
addTickStmt _isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
liftM4 ParStmt
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
liftM3 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
(addTickSyntaxExpr hpcSrcSpan mzipExpr)
(addTickSyntaxExpr hpcSrcSpan bindExpr)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
, trS_by = by, trS_using = using
......@@ -652,12 +651,13 @@ addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprRHS e
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a)
-> TM ([LStmt Id], a)
addTickStmtAndBinders isGuard (stmts, ids) =
liftM2 (,)
addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
-> TM (ParStmtBlock Id Id)
addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =
liftM3 ParStmtBlock
(addTickLStmts isGuard stmts)
(return ids)
(addTickSyntaxExpr hpcSrcSpan returnExpr)
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
......
......@@ -1124,8 +1124,8 @@ collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (ExprStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
$ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
......
......@@ -18,7 +18,7 @@ lower levels it is preserved with @let@/@letrec@s).
-- for details
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
dsHsWrapper, dsTcEvBinds, dsEvBinds
) where
#include "HsVersions.h"
......@@ -32,7 +32,6 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import HscTypes ( MonadThings )
import Literal ( Literal(MachStr) )
import CoreSubst
import MkCore
......@@ -40,6 +39,8 @@ import CoreUtils
import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import UniqSupply
import Unique( Unique )
import Digraph
......@@ -52,7 +53,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon )
import Id
import Class
import DataCon ( dataConWorkId )
import Name ( Name, localiseName )
import Name
import MkId ( seqId )
import Var
import VarSet
......@@ -662,7 +663,7 @@ but it seems better to reject the program because it's almost certainly
a mistake. That's what the isDeadBinder call detects.
Note [Constant rule dicts]
~~~~~~~~~~~~~~~~~~~~~~~
~~~~~~~~~~~~~~~~~~~~~~~~~~
When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
which is presumably in scope at the function definition site, we can quantify
over it too. *Any* dict with that type will do.
......@@ -695,23 +696,23 @@ as the old one, but with an Internal name and no IdInfo.
\begin{code}
dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr
dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
dsHsWrapper WpHole e = return e
dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
dsHsWrapper (WpCast co) e = return $ dsTcCoercion co (mkCast e)
dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
--------------------------------------
dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind]
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind]
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
where
ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
......@@ -726,39 +727,51 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
edges = foldrBag ((:) . mk_node) [] bs
mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term)
mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
---------------------------------------
dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast v co)
= return $ dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCast tm' }
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
= return $ dsTcCoercion co $ (\_ -> Var v)
= do { v' <- dsEvTerm v
; dsTcCoercion co $ (\_ -> v') }
dsEvTerm (EvDFunApp df tys vars) = return (Var df `mkTyApps` tys `mkVarApps` vars)
dsEvTerm (EvCoercion co) = return $ dsTcCoercion co mkEqBox
dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= ASSERT( isTupleTyCon tc )
return $
Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
where
(tc, tys) = splitTyConApp (evVarPred v)
Just [dc] = tyConDataCons_maybe tc
v' = v `setVarType` ty_want
xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
(tys_before, ty_want:tys_after) = splitAt n tys
dsEvTerm (EvTupleMk vs) = return $ Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
where dc = tupleCon ConstraintTuple (length vs)
tys = map varType vs
= do { tm' <- dsEvTerm v
; let scrut_ty = exprType tm'
(tc, tys) = splitTyConApp scrut_ty
Just [dc] = tyConDataCons_maybe tc
xs = mkTemplateLocals tys
the_x = xs !! n
; ASSERT( isTupleTyCon tc )
return $
Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
dsEvTerm (EvTupleMk tms)
= do { tms' <- mapM dsEvTerm tms
; let tys = map exprType tms'
; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
where
dc = tupleCon ConstraintTuple (length tms)
dsEvTerm (EvSuperClass d n)
= return $ Var sc_sel_id `mkTyApps` tys `App` Var d
= do { d' <- dsEvTerm d
; let (cls, tys) = getClassPredTys (exprType d')
sc_sel_id = classSCSelId cls n -- Zero-indexed
; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
where
errorId = rUNTIME_ERROR_ID
......@@ -770,7 +783,7 @@ dsEvTerm (EvLit l) =
EvStr s -> mkStringExprFS s
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
......@@ -778,22 +791,28 @@ dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
-- case g2 of EqBox g2# ->
-- k (trans g1# g2#)
dsTcCoercion co thing_inside
= foldr wrap_in_case result_expr eqvs_covs
where
result_expr = thing_inside (ds_tc_coercion subst co)
result_ty = exprType result_expr
= do { us <- newUniqueSupply
; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us)
-- We use the same uniques for the EqVars and the CoVars, and just change
-- the type. So the CoVars shadow the EqVars
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
result_expr = thing_inside (ds_tc_coercion subst co)
result_ty = exprType result_expr
eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
| eqv <- varSetElems (coVarsOfTcCo co)
, let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
wrap_in_case (eqv, cov) body
; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
where
mk_co_var :: Id -> Unique -> (Id, Id)
mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
where
eq_nm = idName eqv
occ = nameOccName eq_nm
loc = nameSrcSpan eq_nm
ty = mkCoercionType ty1 ty2
(ty1, ty2) = getEqPredTys (evVarPred eqv)
wrap_in_case result_ty (eqv, cov) body
= Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
......@@ -816,6 +835,7 @@ ds_tc_coercion subst tc_co
go (TcNthCo n co) = mkNthCo n (go co)
go (TcInstCo co ty) = mkInstCo (go co) ty
go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
go (TcCoVarCo v) = ds_ev_id subst v
ds_co_binds :: TcEvBinds -> CvSubst
......
......@@ -19,7 +19,6 @@ import TcHsSyn
import CoreSyn
import MkCore
import TcEvidence
import DsMonad -- the monadery used in the desugarer
import DsUtils
......@@ -71,15 +70,15 @@ dsListComp lquals res_ty = do
-- mix of possibly a single element in length, so we do this to leave the possibility open
isParallelComp = any isParallelStmt
isParallelStmt (ParStmt _ _ _ _) = True
isParallelStmt _ = False
isParallelStmt (ParStmt {}) = True
isParallelStmt _ = False
-- This function lets you desugar a inner list comprehension and a list of the binders
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
dsInnerListComp (stmts, bndrs)
dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)
dsInnerListComp (ParStmtBlock stmts bndrs _)
= do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
(mkListTy bndrs_tuple_type)
; return (expr, bndrs_tuple_type) }
......@@ -98,7 +97,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
(expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs)
(expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
......@@ -233,7 +232,7 @@ deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
core_list1 <- dsLExpr list1
deBindComp pat core_list1 quals core_list2
deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list
= do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
; let (exps, qual_tys) = unzip exps_and_qual_tys
......@@ -243,7 +242,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
quals list }
where
bndrs_s = map snd stmtss_w_bndrs
bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = mkBigLHsPatTup pats
......@@ -473,7 +472,7 @@ dsPArrComp :: [Stmt Id]
-> DsM CoreExpr
-- Special case for parallel comprehension
dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
......@@ -590,7 +589,7 @@ dePArrComp (LetStmt ds : qs) pa cea = do
-- singeltons qualifier lists, which we already special case in the caller.
-- So, encountering one here is a bug.
--
dePArrComp (ParStmt _ _ _ _ : _) _ _ =
dePArrComp (ParStmt {} : _) _ _ =
panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
......@@ -601,7 +600,7 @@ dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
-- where
-- {x_1, ..., x_n} = DV (qs)
--
dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
dePArrParComp :: [ParStmtBlock Id Id] -> [Stmt Id] -> DsM CoreExpr
dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
dePArrComp quals pQss ceQss
......@@ -609,13 +608,13 @@ dePArrParComp qss quals = do
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = do -- first statement
deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
---
parStmts [] pa cea = return (pa, cea)
parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed)
parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed)
zipP <- dsDPHBuiltin zipPVar
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
......@@ -763,12 +762,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
-- mzip :: forall a b. m a -> m b -> m (a,b)
-- NB: we need a polymorphic mzip because we call it several times
dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
= do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty)
dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest
= do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)
; mzip_op' <- dsExpr mzip_op
; let -- The pattern variables
pats = map (mkBigLHsVarPatTup . snd) pairs
pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks]
-- Pattern with tuples of variables
-- [v1,v2,v3] => (v1, (v2, v3))
pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
......@@ -779,11 +778,9 @@ dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
where
ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op
; return (exp, tup_ty) }
where
mono_ret_op = HsWrap (WpTyApp tup_ty) return_op
tup_ty = mkBigCoreVarTupTy bndrs
ds_inner (ParStmtBlock stmts bndrs return_op)
= do { exp <- dsInnerMonadComp stmts bndrs return_op
; return (exp, mkBigCoreVarTupTy bndrs) }
dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)