Commit 67cb4091 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Implement generalised list comprehensions

  This patch implements generalised list comprehensions, as described in 
  the paper "Comprehensive comprehensions" (Peyton Jones & Wadler, Haskell
  Workshop 2007).  If you don't use the new comprehensions, nothing
  should change.
  
  The syntax is not exactly as in the paper; see the user manual entry 
  for details.
  
  You need an accompanying patch to the base library for this stuff 
  to work.
  
  The patch is the work of Max Bolingbroke [batterseapower@hotmail.com], 
  with some advice from Simon PJ.
  
  The related GHC Wiki page is 
    http://hackage.haskell.org/trac/ghc/wiki/SQLLikeComprehensions 
parent fe784e7d
......@@ -65,7 +65,7 @@ addCoverageTicksToBinds
:: DynFlags
-> Module
-> ModLocation -- of the current module
-> [TyCon] -- type constructor in this module
-> [TyCon] -- type constructor in this module
-> LHsBinds Id
-> IO (LHsBinds Id, HpcInfo, ModBreaks)
......@@ -442,23 +442,34 @@ addTickStmt isGuard (BindStmt pat e bind fail) = do
(addTickSyntaxExpr hpcSrcSpan fail)
addTickStmt isGuard (ExprStmt e bind' ty) = do
liftM3 ExprStmt
(addTick e)
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
(return ty)
where
addTick e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprAlways e
addTickStmt isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs) = do
liftM ParStmt (mapM process pairs)
where
process (stmts,ids) =
liftM2 (,)
(addTickLStmts isGuard stmts)
(return ids)
liftM ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
addTickStmt isGuard (TransformStmt (stmts, ids) usingExpr maybeByExpr) = do
liftM3 TransformStmt
(addTickStmtAndBinders isGuard (stmts, ids))
(addTickLHsExprAlways usingExpr)
(addTickMaybeByLHsExpr maybeByExpr)
addTickStmt isGuard (GroupStmt (stmts, binderMap) groupByClause) = do
liftM2 GroupStmt
(addTickStmtAndBinders isGuard (stmts, binderMap))
(case groupByClause of
GroupByNothing usingExpr -> addTickLHsExprAlways usingExpr >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
eitherUsingExpr' <- mapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) eitherUsingExpr
byExpr' <- addTickLHsExprAlways byExpr
return $ GroupBySomething eitherUsingExpr' byExpr')
where
mapEitherM f g x = do
case x of
Left a -> f a >>= (return . Left)
Right b -> g b >>= (return . Right)
addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
liftM5 RecStmt
(addTickLStmts isGuard stmts)
......@@ -467,6 +478,20 @@ addTickStmt isGuard (RecStmt stmts ids1 ids2 tys dictbinds) = do
(return tys)
(addTickDictBinds dictbinds)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
| otherwise = addTickLHsExprAlways e
addTickStmtAndBinders isGuard (stmts, ids) =
liftM2 (,)
(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
......
......@@ -164,7 +164,7 @@ with s1 being the "top", the first one to be matched with a lambda.
\begin{code}
envStackType :: [Id] -> [Type] -> Type
envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
envStackType ids stack_tys = foldl mkCorePairTy (mkBigCoreVarTupTy ids) stack_tys
----------------------------------------------
-- buildEnvStack
......@@ -173,7 +173,7 @@ envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
buildEnvStack :: [Id] -> [Id] -> CoreExpr
buildEnvStack env_ids stack_ids
= foldl mkCorePairExpr (mkTupleExpr env_ids) (map Var stack_ids)
= foldl mkCorePairExpr (mkBigCoreVarTup env_ids) (map Var stack_ids)
----------------------------------------------
-- matchEnvStack
......@@ -193,7 +193,7 @@ matchEnvStack :: [Id] -- x1..xn
-> DsM CoreExpr
matchEnvStack env_ids stack_ids body
= newUniqueSupply `thenDs` \ uniqs ->
newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
newSysLocalDs (mkBigCoreVarTupTy env_ids) `thenDs` \ tup_var ->
matchVarStack tup_var stack_ids
(coreCaseTuple uniqs tup_var env_ids body)
......@@ -257,11 +257,11 @@ dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
dsfixCmd meth_ids locals [] cmd_ty cmd
`thenDs` \ (core_cmd, free_vars, env_ids) ->
let
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
selectSimpleMatchVarL pat `thenDs` \ var ->
matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
matchSimply (Var var) ProcExpr pat (mkBigCoreVarTup env_ids) fail_expr
`thenDs` \ match_code ->
let
pat_ty = hsLPatType pat
......@@ -303,7 +303,7 @@ dsCmd ids local_vars env_ids stack res_ty
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
......@@ -331,7 +331,7 @@ dsCmd ids local_vars env_ids stack res_ty
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
dsLExpr arrow `thenDs` \ core_arrow ->
dsLExpr arg `thenDs` \ core_arg ->
......@@ -587,7 +587,7 @@ dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
= let
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
in
dsLExpr op `thenDs` \ core_op ->
mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
......@@ -683,8 +683,8 @@ dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
dsCmdLStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
(mkTupleType env_ids)
(mkTupleType env_ids')
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids')
res_ty
core_stmt
core_stmts,
......@@ -721,12 +721,12 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty)
= dsfixCmd ids local_vars [] c_ty cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
matchEnvStack env_ids []
(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
`thenDs` \ core_mux ->
let
in_ty = mkTupleType env_ids
in_ty1 = mkTupleType env_ids1
out_ty = mkTupleType out_ids
in_ty = mkBigCoreVarTupTy env_ids
in_ty1 = mkBigCoreVarTupTy env_ids1
out_ty = mkBigCoreVarTupTy out_ids
before_c_ty = mkCorePairTy in_ty1 out_ty
after_c_ty = mkCorePairTy c_ty out_ty
in
......@@ -756,14 +756,14 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
pat_ty = hsLPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
env_ty2 = mkTupleType env_ids2
env_ty2 = mkBigCoreVarTupTy env_ids2
in
-- multiplexing function
-- \ (xs) -> ((xs1),(xs2))
matchEnvStack env_ids []
(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup env_ids2))
`thenDs` \ core_mux ->
-- projection function
......@@ -773,8 +773,8 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
newUniqueSupply `thenDs` \ uniqs ->
let
after_c_ty = mkCorePairTy pat_ty env_ty2
out_ty = mkTupleType out_ids
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
out_ty = mkBigCoreVarTupTy out_ids
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
in
mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
selectSimpleMatchVarL pat `thenDs` \ pat_id ->
......@@ -787,9 +787,9 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
-- put it all together
let
in_ty = mkTupleType env_ids
in_ty1 = mkTupleType env_ids1
in_ty2 = mkTupleType env_ids2
in_ty = mkBigCoreVarTupTy env_ids
in_ty1 = mkBigCoreVarTupTy env_ids1
in_ty2 = mkBigCoreVarTupTy env_ids2
before_c_ty = mkCorePairTy in_ty1 in_ty2
in
returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
......@@ -806,12 +806,12 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
-- build a new environment using the let bindings
= dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
= dsLocalBinds binds (mkBigCoreVarTup out_ids) `thenDs` \ core_binds ->
-- match the old environment against the input
matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
returnDs (do_arr ids
(mkTupleType env_ids)
(mkTupleType out_ids)
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy out_ids)
core_map,
exprFreeVars core_binds `intersectVarSet` local_vars)
......@@ -833,7 +833,7 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
= let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
env2_ty = mkTupleType env2_ids
env2_ty = mkBigCoreVarTupTy env2_ids
in
-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
......@@ -841,9 +841,9 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
newUniqueSupply `thenDs` \ uniqs ->
newSysLocalDs env2_ty `thenDs` \ env2_id ->
let
later_ty = mkTupleType later_ids
later_ty = mkBigCoreVarTupTy later_ids
post_pair_ty = mkCorePairTy later_ty env2_ty
post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
in
matchEnvStack later_ids [env2_id] post_loop_body
`thenDs` \ post_loop_fn ->
......@@ -856,10 +856,10 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
-- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
let
env1_ty = mkTupleType env1_ids
env1_ty = mkBigCoreVarTupTy env1_ids
pre_pair_ty = mkCorePairTy env1_ty env2_ty
pre_loop_body = mkCorePairExpr (mkTupleExpr env1_ids)
(mkTupleExpr env2_ids)
pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
(mkBigCoreVarTup env2_ids)
in
matchEnvStack env_ids [] pre_loop_body
......@@ -868,8 +868,8 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss b
-- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
let
env_ty = mkTupleType env_ids
out_ty = mkTupleType out_ids
env_ty = mkBigCoreVarTupTy env_ids
out_ty = mkBigCoreVarTupTy out_ids
core_body = do_map_arrow ids env_ty pre_pair_ty out_ty
pre_loop_fn
(do_compose ids pre_pair_ty post_pair_ty out_ty
......@@ -888,7 +888,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
= let
rec_id_set = mkVarSet rec_ids
out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
out_ty = mkTupleType out_ids
out_ty = mkBigCoreVarTupTy out_ids
local_vars' = local_vars `unionVarSet` rec_id_set
in
......@@ -896,10 +896,10 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
mappM dsExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
later_ty = mkTupleType later_ids
later_tuple = mkBigCoreVarTup later_ids
later_ty = mkBigCoreVarTupTy later_ids
rec_tuple = mkBigCoreTup core_rhss
rec_ty = mkTupleType rec_ids
rec_ty = mkBigCoreVarTupTy rec_ids
out_pair = mkCorePairExpr later_tuple rec_tuple
out_pair_ty = mkCorePairTy later_ty rec_ty
in
......@@ -917,7 +917,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
let
env1_id_set = fv_stmts `minusVarSet` rec_id_set
env1_ids = varSetElems env1_id_set
env1_ty = mkTupleType env1_ids
env1_ty = mkBigCoreVarTupTy env1_ids
in_pair_ty = mkCorePairTy env1_ty rec_ty
core_body = mkBigCoreTup (map selectVar env_ids)
where
......@@ -932,7 +932,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
-- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
let
env_ty = mkTupleType env_ids
env_ty = mkBigCoreVarTupTy env_ids
core_loop = do_loop ids env1_ty later_ty rec_ty
(do_map_arrow ids in_pair_ty env_ty out_pair_ty
squash_pair_fn
......@@ -984,9 +984,9 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
dsCmdLStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
(mkTupleType env_ids)
(mkTupleType env_ids')
(mkTupleType out_ids)
(mkBigCoreVarTupTy env_ids)
(mkBigCoreVarTupTy env_ids')
(mkBigCoreVarTupTy out_ids)
core_stmt
core_stmts,
fv_stmt)
......
......@@ -175,7 +175,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
-- Rec because of mixed-up dictionary bindings
core_bind = Rec (map do_one core_prs)
tup_expr = mkTupleExpr locals
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
Let core_bind tup_expr
......
This diff is collapsed.
......@@ -8,12 +8,6 @@ Utilities for desugaring
This module exports some utility functions of no great interest.
\begin{code}
{-# OPTIONS -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module DsUtils (
EquationInfo(..),
......@@ -34,9 +28,19 @@ module DsUtils (
mkIntExpr, mkCharExpr,
mkStringExpr, mkStringExprFS, mkIntegerExpr,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkTupleType, mkTupleCase, mkBigCoreTup,
mkCoreTup, mkCoreTupTy, seqVar,
seqVar,
-- Core tuples
mkCoreVarTup, mkCoreTup, mkCoreVarTupTy, mkCoreTupTy,
mkBigCoreVarTup, mkBigCoreTup, mkBigCoreVarTupTy, mkBigCoreTupTy,
-- LHs tuples
mkLHsVarTup, mkLHsTup, mkLHsVarPatTup, mkLHsPatTup,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
-- Tuple bindings
mkSelectorBinds, mkTupleSelector,
mkSmallTupleCase, mkTupleCase,
dsSyntaxTable, lookupEvidence,
......@@ -151,17 +155,18 @@ mkDsApps :: CoreExpr -> [CoreExpr] -> CoreExpr
mkDsApps fun args
= go fun (exprType fun) args
where
go fun fun_ty [] = fun
go fun _ [] = fun
go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
go fun fun_ty (arg : args) = go (mk_val_app fun arg arg_ty res_ty) res_ty args
where
(arg_ty, res_ty) = splitFunTy fun_ty
-----------
mk_val_app fun arg arg_ty res_ty -- See Note [CoreSyn let/app invariant]
mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant]
| not (isUnLiftedType arg_ty) || exprOkForSpeculation arg
= App fun arg -- The vastly common case
mk_val_app (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 _ res_ty
mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty
| f == seqId -- Note [Desugaring seq]
= Case arg1 (mkWildId ty1) res_ty [(DEFAULT,[],arg2)]
......@@ -227,11 +232,12 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
selectMatchVars :: [Pat Id] -> DsM [Id]
selectMatchVars ps = mapM selectMatchVar ps
selectMatchVar :: Pat Id -> DsM Id
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (VarPat var) = return var
selectMatchVar (AsPat var pat) = return (unLoc var)
selectMatchVar (AsPat var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
-- OK, better make up one...
\end{code}
......@@ -267,10 +273,10 @@ alwaysFailMatchResult :: MatchResult
alwaysFailMatchResult = MatchResult CanFail (\fail -> returnDs fail)
cantFailMatchResult :: CoreExpr -> MatchResult
cantFailMatchResult expr = MatchResult CantFail (\ ignore -> returnDs expr)
cantFailMatchResult expr = MatchResult CantFail (\_ -> returnDs expr)
extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
extractMatchResult (MatchResult CantFail match_fn) fail_expr
extractMatchResult (MatchResult CantFail match_fn) _
= match_fn (error "It can't fail!")
extractMatchResult (MatchResult CanFail match_fn) fail_expr
......@@ -289,7 +295,7 @@ combineMatchResults (MatchResult CanFail body_fn1)
body_fn1 duplicatable_expr `thenDs` \ body1 ->
returnDs (Let fail_bind body1)
combineMatchResults match_result1@(MatchResult CantFail body_fn1) match_result2
combineMatchResults match_result1@(MatchResult CantFail _) _
= match_result1
adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
......@@ -330,7 +336,7 @@ mkEvalMatchResult var ty
= adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
mkGuardedMatchResult pred_expr (MatchResult can_it_fail body_fn)
mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
= MatchResult CanFail (\fail -> body_fn fail `thenDs` \ body ->
returnDs (mkIfThenElse pred_expr body fail))
......@@ -430,8 +436,8 @@ mkCoAlgCaseMatchResult var ty match_alts
case (isPArrFakeCon dcon, isPArrFakeAlts alts) of
(True , True ) -> True
(False, False) -> False
_ ->
panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns"
_ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
--
mk_parrCase fail =
dsLookupGlobalId lengthPName `thenDs` \lengthP ->
......@@ -540,6 +546,7 @@ mkIntegerExpr i
in
returnDs (horner tARGET_MAX_INT i)
mkSmallIntegerLit :: DataCon -> Integer -> CoreExpr
mkSmallIntegerLit small_integer_data_con i = mkConApp small_integer_data_con [mkIntLit i]
mkStringExpr str = mkStringExprFS (mkFastString str)
......@@ -643,7 +650,7 @@ mkSelectorBinds pat val_expr
returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
where
binders = collectPatBinders pat
local_tuple = mkTupleExpr binders
local_tuple = mkBigCoreVarTup binders
tuple_ty = exprType local_tuple
mk_bind scrut_var err_var bndr_var
......@@ -662,44 +669,28 @@ mkSelectorBinds pat val_expr
is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
is_simple_pat (VarPat _) = True
is_simple_pat (ParPat p) = is_simple_lpat p
is_simple_pat other = False
is_simple_pat (ParPat p) = is_simple_lpat p
is_simple_pat _ = False
is_triv_lpat p = is_triv_pat (unLoc p)
is_triv_pat (VarPat v) = True
is_triv_pat (VarPat _) = True
is_triv_pat (WildPat _) = True
is_triv_pat (ParPat p) = is_triv_lpat p
is_triv_pat other = False
is_triv_pat _ = False
\end{code}
%************************************************************************
%* *
Tuples
Big Tuples
%* *
%************************************************************************
@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@.
* If it has only one element, it is the identity function.
* If there are more elements than a big tuple can have, it nests
the tuples.
Nesting policy. Better a 2-tuple of 10-tuples (3 objects) than
a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big.
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
mkTupleExpr ids = mkBigCoreTup (map Var ids)
-- corresponding type
mkTupleType :: [Id] -> Type
mkTupleType ids = mkBigTuple mkCoreTupTy (map idType ids)
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = mkBigTuple mkCoreTup
mkBigTuple :: ([a] -> a) -> [a] -> a
mkBigTuple small_tuple as = mk_big_tuple (chunkify as)
......@@ -713,11 +704,99 @@ chunkify :: [a] -> [[a]]
-- But there may be more than mAX_TUPLE_SIZE sub-lists
chunkify xs
| n_xs <= mAX_TUPLE_SIZE = {- pprTrace "Small" (ppr n_xs) -} [xs]
| otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
| otherwise = {- pprTrace "Big" (ppr n_xs) -} (split xs)
where
n_xs = length xs
split [] = []
split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
\end{code}
Creating tuples and their types for Core expressions
@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@.
* If it has only one element, it is the identity function.
* If there are more elements than a big tuple can have, it nests
the tuples.
\begin{code}
-- Small tuples: build exactly the specified tuple
mkCoreVarTup :: [Id] -> CoreExpr
mkCoreVarTup ids = mkCoreTup (map Var ids)
mkCoreVarTupTy :: [Id] -> Type
mkCoreVarTupTy ids = mkCoreTupTy (map idType ids)
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup [] = Var unitDataConId
mkCoreTup [c] = c
mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
(map (Type . exprType) cs ++ cs)
mkCoreTupTy :: [Type] -> Type
mkCoreTupTy [ty] = ty
mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
-- Big tuples
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = mkBigTuple mkCoreTup
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = mkBigTuple mkCoreTupTy
\end{code}
Creating tuples and their types for full Haskell expressions
\begin{code}
-- Smart constructors for source tuple expressions
mkLHsVarTup :: [Id] -> LHsExpr Id
mkLHsVarTup ids = mkLHsTup (map nlHsVar ids)
mkLHsTup :: [LHsExpr Id] -> LHsExpr Id
mkLHsTup [] = nlHsVar unitDataConId
mkLHsTup [lexp] = lexp
mkLHsTup lexps = noLoc $ ExplicitTuple lexps Boxed
-- Smart constructors for source tuple patterns
mkLHsVarPatTup :: [Id] -> LPat Id
mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)
mkLHsPatTup :: [LPat Id] -> LPat Id
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = noLoc $ mkVanillaTuplePat lpats Boxed -- Handles the case where lpats = [] gracefully
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTup :: [Id] -> LHsExpr Id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id
mkBigLHsTup = mkBigTuple mkLHsTup
-- The Big equivalents for the source tuple patterns
mkBigLHsVarPatTup :: [Id] -> LPat Id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsPatTup :: [LPat Id] -> LPat Id
mkBigLHsPatTup = mkBigTuple mkLHsPatTup
\end{code}
......@@ -790,20 +869,21 @@ mkTupleCase
mkTupleCase uniqs vars body scrut_var scrut
= mk_tuple_case uniqs (chunkify vars) body
where
mk_tuple_case us [vars] body
-- This is the case where don't need any nesting
mk_tuple_case _ [vars] body
= mkSmallTupleCase vars body scrut_var scrut
-- This is the case where we must make nest tuples at least once
mk_tuple_case us vars_s body
= let
(us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
in
mk_tuple_case us' (chunkify vars') body'
= let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s
in mk_tuple_case us' (chunkify vars') body'
one_tuple_case chunk_vars (us, vs, body)
= let
(us1, us2) = splitUniqSupply us
scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
(mkCoreTupTy (map idType chunk_vars))
body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
in (us2, scrut_var:vs, body')
= let (us1, us2) = splitUniqSupply us
scrut_var = mkSysLocal FSLIT("ds") (uniqFromSupply us1)
(mkCoreTupTy (map idType chunk_vars))
body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)
in (us2, scrut_var:vs, body')
\end{code}
The same, but with a tuple small enough not to need nesting.
......@@ -841,33 +921,21 @@ mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
mkListExpr :: Type -> [CoreExpr] -> CoreExpr
mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs
-- The next three functions make tuple types, constructors and selectors,
-- with the rule that a 1-tuple is represented by the thing itselg
mkCoreTupTy :: [Type] -> Type
mkCoreTupTy [ty] = ty
mkCoreTupTy tys = mkTupleTy Boxed (length tys) tys
mkCoreTup :: [CoreExpr] -> CoreExpr
-- Builds exactly the specified tuple.
-- No fancy business for big tuples
mkCoreTup [] = Var unitDataConId
mkCoreTup [c] = c
mkCoreTup cs = mkConApp (tupleCon Boxed (length cs))
(map (Type . exprType) cs ++ cs)
mkCoreSel :: [Id] -- The tuple args
-> Id -- The selected one
-> Id -- A variable of the same type as the scrutinee
-> Id -- The selected one
-> Id -- A variable of the same type as the scrutinee
-> CoreExpr -- Scrutinee
-> CoreExpr
-- mkCoreSel [x,y,z] x v e
-- ===> case e of v { (x,y,z) -> x
mkCoreSel [var] should_be_the_same_var scrut_var scrut
-- mkCoreSel [x] x v e
-- ===> e
mkCoreSel [var] should_be_the_same_var _ scrut
= ASSERT(var == should_be_the_same_var)
scrut