import Match ( matchSimply )
import DsUtils ( mkErrorAppDs,
mkCoreTupTy, mkCoreTup, selectMatchVar,
+ mkTupleCase, mkBigCoreTup, mkTupleType,
mkTupleExpr, mkTupleSelector,
dsReboundNames, lookupReboundName )
import DsMonad
-import HsSyn ( HsExpr(..), Pat(..),
+import HsSyn ( HsExpr(..),
Stmt(..), HsMatchContext(..), HsStmtContext(..),
Match(..), GRHSs(..), GRHS(..),
HsCmdTop(..), HsArrAppType(..),
matchContextErrString
)
import TcHsSyn ( TypecheckedHsCmd, TypecheckedHsCmdTop,
- TypecheckedHsExpr, TypecheckedHsBinds,
- TypecheckedPat,
- TypecheckedMatch, TypecheckedGRHSs, TypecheckedGRHS,
+ TypecheckedHsExpr, TypecheckedPat,
+ TypecheckedMatch, TypecheckedGRHS,
TypecheckedStmt, hsPatType,
TypecheckedMatchContext )
import Type ( mkTyConApp )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
+import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Id ( Id, idType )
import PrelInfo ( pAT_ERROR_ID )
-import DataCon ( DataCon, dataConWrapId )
-import TysWiredIn ( tupleCon, mkTupleTy )
+import DataCon ( dataConWrapId )
+import TysWiredIn ( tupleCon )
import BasicTypes ( Boxity(..) )
import PrelNames ( eitherTyConName, leftDataConName, rightDataConName,
arrAName, composeAName, firstAName,
import Outputable
import HsPat ( collectPatBinders, collectPatsBinders )
-import VarSet ( IdSet, emptyVarSet, mkVarSet, varSetElems,
+import VarSet ( IdSet, mkVarSet, varSetElems,
intersectVarSet, minusVarSet,
unionVarSet, unionVarSets, elemVarSet )
import SrcLoc ( SrcLoc )
-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
mkSndExpr :: Type -> Type -> DsM CoreExpr
mkSndExpr a_ty b_ty
- = newSysLocalDs a_ty `thenDs` \a_var ->
- newSysLocalDs b_ty `thenDs` \b_var ->
- newSysLocalDs (mkCorePairTy a_ty b_ty) `thenDs` \pair_var ->
- returnDs (coreCaseSmallTuple pair_var [a_var, b_var] (Var b_var))
+ = newSysLocalDs a_ty `thenDs` \ a_var ->
+ newSysLocalDs b_ty `thenDs` \ b_var ->
+ newSysLocalDs (mkCorePairTy a_ty b_ty) `thenDs` \ pair_var ->
+ returnDs (Lam pair_var
+ (coreCasePair pair_var a_var b_var (Var b_var)))
\end{code}
Build case analysis of a tuple. This cannot be done in the DsM monad,
-- But the matching may be nested if the tuple is very big
coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
-coreCaseTuple uniqs = coreCaseSmallTuple -- TODO: do this right
+coreCaseTuple uniqs scrut_var vars body
+ = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
--- same, but with a tuple small enough not to need nesting
-
-coreCaseSmallTuple :: Id -> [Id] -> CoreExpr -> CoreExpr
-coreCaseSmallTuple scrut_var [var] body
- = bindNonRec var (Var scrut_var) body
-coreCaseSmallTuple scrut_var vars body
+coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
+coreCasePair scrut_var var1 var2 body
= Case (Var scrut_var) scrut_var
- [(DataAlt (tupleCon Boxed (length vars)), vars, body)]
+ [(DataAlt (tupleCon Boxed 2), [var1, var2], body)]
\end{code}
\begin{code}
--- Not right: doesn't handle nested tuples
-tupleType :: [Id] -> Type
-tupleType vars = mkCoreTupTy (map idType vars)
-
mkCorePairTy :: Type -> Type -> Type
mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
\begin{code}
envStackType :: [Id] -> [Type] -> Type
-envStackType ids stack_tys = foldl mkCorePairTy (tupleType ids) stack_tys
+envStackType ids stack_tys = foldl mkCorePairTy (mkTupleType ids) stack_tys
----------------------------------------------
-- buildEnvStack
--
--- (...((x1,...,xn),s1),...sn)
+-- (...((x1,...,xn),s1),...sk)
buildEnvStack :: [Id] -> [Id] -> CoreExpr
buildEnvStack env_ids stack_ids
- = envStackExpr (mkTupleExpr env_ids) (map Var stack_ids)
-
-envStackExpr :: CoreExpr -> [CoreExpr] -> CoreExpr
-envStackExpr core_ids core_exprs = foldl mkCorePairExpr core_ids core_exprs
+ = foldl mkCorePairExpr (mkTupleExpr env_ids) (map Var stack_ids)
----------------------------------------------
-- matchEnvStack
--
--- \ (...((x1,...,xm),s1),...sn) -> e
+-- \ (...((x1,...,xn),s1),...sk) -> e
-- =>
--- \ zn ->
--- case zn of (zn-1,sn) ->
+-- \ zk ->
+-- case zk of (zk-1,sk) ->
-- ...
-- case z1 of (z0,s1) ->
--- case z0 of (x1,...,xm) ->
+-- case z0 of (x1,...,xn) ->
-- e
-matchEnvStack :: [Id] -- x1..xm
- -> [Id] -- s1..sn
+matchEnvStack :: [Id] -- x1..xn
+ -> [Id] -- s1..sk
-> CoreExpr -- e
-> DsM CoreExpr
matchEnvStack env_ids stack_ids body
= getUniqSupplyDs `thenDs` \ uniqs ->
- newSysLocalDs (tupleType env_ids) `thenDs` \ tup_var ->
+ newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
matchVarStack tup_var stack_ids
(coreCaseTuple uniqs tup_var env_ids body)
----------------------------------------------
-- matchVarStack
--
--- \ (...(z0,s1),...sn) -> e
+-- \ (...(z0,s1),...sk) -> e
-- =>
--- \ zn ->
--- case zn of (zn-1,sn) ->
+-- \ zk ->
+-- case zk of (zk-1,sk) ->
-- ...
-- case z1 of (z0,s1) ->
-- e
matchVarStack :: Id -- z0
- -> [Id] -- s1..sn
+ -> [Id] -- s1..sk
-> CoreExpr -- e
-> DsM CoreExpr
matchVarStack env_id [] body
= returnDs (Lam env_id body)
matchVarStack env_id (stack_id:stack_ids) body
- = let
- pair_ids = [env_id, stack_id]
- in
- newSysLocalDs (tupleType pair_ids) `thenDs` \ pair_id ->
+ = newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id))
+ `thenDs` \ pair_id ->
matchVarStack pair_id stack_ids
- (coreCaseSmallTuple pair_id pair_ids body)
+ (coreCasePair pair_id env_id stack_id body)
\end{code}
\begin{code}
mkHsTupleExpr :: [TypecheckedHsExpr] -> TypecheckedHsExpr
mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple es Unboxed
+mkHsTupleExpr es = ExplicitTuple es Boxed
mkHsPairExpr :: TypecheckedHsExpr -> TypecheckedHsExpr -> TypecheckedHsExpr
mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
dsfixCmd meth_ids locals [] cmd_ty cmd
`thenDs` \ (core_cmd, free_vars, env_ids) ->
let
- env_ty = tupleType env_ids
+ env_ty = mkTupleType env_ids
in
mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
selectMatchVar pat `thenDs` \ var ->
(HsArrApp arrow arg arrow_ty HsFirstOrderApp _ _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
- (a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- env_ty = tupleType env_ids
+ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+ env_ty = mkTupleType env_ids
in
dsExpr arrow `thenDs` \ core_arrow ->
dsExpr arg `thenDs` \ core_arg ->
(HsArrApp arrow arg arrow_ty HsHigherOrderApp _ _)
= let
(a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
- (a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- env_ty = tupleType env_ids
+ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+ env_ty = mkTupleType env_ids
in
dsExpr arrow `thenDs` \ core_arrow ->
dsExpr arg `thenDs` \ core_arg ->
- matchEnvStack env_ids [] (mkCoreTup [core_arrow, core_arg])
+ matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg)
`thenDs` \ core_make_pair ->
returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty
core_make_pair
(exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
`intersectVarSet` local_vars)
+-- A | ys |- c :: [t:ts] t'
+-- A, xs |- e :: t
+-- ------------------------
+-- A | xs |- c e :: [ts] t'
+--
+-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
+
+dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
+ = dsExpr arg `thenDs` \ core_arg ->
+ let
+ arg_ty = exprType core_arg
+ stack' = arg_ty:stack
+ in
+ dsfixCmd ids local_vars stack' res_ty cmd
+ `thenDs` \ (core_cmd, free_vars, env_ids') ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ newSysLocalDs arg_ty `thenDs` \ arg_id ->
+ -- push the argument expression onto the stack
+ let
+ core_body = bindNonRec arg_id core_arg
+ (buildEnvStack env_ids' (arg_id:stack_ids))
+ in
+ -- match the environment and stack against the input
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_map ->
+ returnDs (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack')
+ res_ty
+ core_map
+ core_cmd,
+ (exprFreeVars core_arg `intersectVarSet` local_vars)
+ `unionVarSet` free_vars)
+
-- A | ys |- c :: [ts] t'
-- -----------------------------------------------
-- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t'
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
- (HsLam (Match pats _ (GRHSs [GRHS [ResultStmt body _] loc] _ _cmd_ty)))
+ (HsLam (Match pats _ (GRHSs [GRHS [ResultStmt body _] _loc] _ _cmd_ty)))
= let
pat_vars = mkVarSet (collectPatsBinders pats)
local_vars' = local_vars `unionVarSet` pat_vars
dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
= dsCmd ids local_vars env_ids stack res_ty cmd
+-- A, xs |- e :: Bool
+-- A | xs1 |- c1 :: [ts] t
+-- A | xs2 |- c2 :: [ts] t
+-- ----------------------------------------
+-- A | xs |- if e then c1 else c2 :: [ts] t
+--
+-- ---> arr (\ ((xs)*ts) ->
+-- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
+-- c1 ||| c2
+
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc)
+ = dsExpr cond `thenDs` \ core_cond ->
+ dsfixCmd ids local_vars stack res_ty then_cmd
+ `thenDs` \ (core_then, fvs_then, then_ids) ->
+ dsfixCmd ids local_vars stack res_ty else_cmd
+ `thenDs` \ (core_else, fvs_else, else_ids) ->
+ mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
+ dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
+ dsLookupDataCon leftDataConName `thenDs` \ left_con ->
+ dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ let
+ left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
+ right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
+
+ in_ty = envStackType env_ids stack
+ then_ty = envStackType then_ids stack
+ else_ty = envStackType else_ids stack
+ sum_ty = mkTyConApp either_con [then_ty, else_ty]
+ fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
+ in
+ matchEnvStack env_ids stack_ids
+ (mkIfThenElse core_cond
+ (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
+ (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
+ `thenDs` \ core_if ->
+ returnDs(do_map_arrow ids in_ty sum_ty res_ty
+ core_if
+ (do_choice ids then_ty else_ty res_ty core_then core_else),
+ fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+\end{code}
+
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives. For example
+
+ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+ arr (\ ((xs)*ts) -> case e of
+ p1 -> (Left (Left (xs1)*ts))
+ p2 -> Left ((Right (xs2)*ts))
+ p3 -> Right ((xs3)*ts)) >>>
+ (c1 ||| c2) ||| c3
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use quadruples decribing segments of the list of
+case bodies, containing the following fields:
+1. an IdSet containing the environment variables free in the case bodies
+2. a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+ into the case replacing the commands
+3. a sum type that is the common type of these expressions, and also the
+ input type of the arrow
+4. a CoreExpr for an arrow built by combining the translated command
+ bodies with |||.
+
+\begin{code}
dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc)
= dsExpr exp `thenDs` \ core_exp ->
mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
map (right_expr in_ty1 in_ty2) builds2,
mkTyConApp either_con [in_ty1, in_ty2],
do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
- (fvs, leaves', sum_ty, core_choices) = foldb merge_branches branches
+ (fvs_alts, leaves', sum_ty, core_choices)
+ = foldb merge_branches branches
-- Replace the commands in the case with these tagged tuples,
-- yielding a TypecheckedHsExpr we can feed to dsExpr.
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack
+ fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars
in
- dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_matches ->
+ dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_body ->
+ matchEnvStack env_ids stack_ids core_body
+ `thenDs` \ core_matches ->
returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
- exprFreeVars core_exp `unionVarSet` fvs)
-
--- A, xs |- e :: Bool
--- A | xs1 |- c1 :: [ts] t
--- A | xs2 |- c2 :: [ts] t
--- ----------------------------------------
--- A | xs |- if e then c1 else c2 :: [ts] t
---
--- ---> arr (\ ((xs)*ts) ->
--- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
--- c1 ||| c2
-
-dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd src_loc)
- = dsExpr cond `thenDs` \ core_cond ->
- dsfixCmd ids local_vars stack res_ty then_cmd
- `thenDs` \ (core_then, fvs_then, then_ids) ->
- dsfixCmd ids local_vars stack res_ty else_cmd
- `thenDs` \ (core_else, fvs_else, else_ids) ->
- mapDs newSysLocalDs stack `thenDs` \ stack_ids ->
- dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
- dsLookupDataCon leftDataConName `thenDs` \ left_con ->
- dsLookupDataCon rightDataConName `thenDs` \ right_con ->
- let
- left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]
- right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]
-
- in_ty = envStackType env_ids stack
- then_ty = envStackType then_ids stack
- else_ty = envStackType else_ids stack
- sum_ty = mkTyConApp either_con [then_ty, else_ty]
- in
- matchEnvStack env_ids stack_ids
- (mkIfThenElse core_cond
- (left_expr then_ty else_ty (buildEnvStack then_ids stack_ids))
- (right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)))
- `thenDs` \ core_if ->
- returnDs(do_map_arrow ids in_ty sum_ty res_ty
- core_if
- (do_choice ids then_ty else_ty res_ty core_then core_else),
- exprFreeVars core_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)
+ fvs_exp `unionVarSet` fvs_alts)
-- A | ys |- c :: [ts] t
-- ----------------------------------
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo ctxt stmts _ _ src_loc)
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc)
= 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
-- -----------------------------------
--- A | xs |- (|e|) c1 ... cn :: [ts] t ---> e [t_xs] c1 ... cn
+-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
-dsCmd ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _)
+dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _)
= let
- env_ty = tupleType env_ids
+ env_ty = mkTupleType env_ids
in
dsExpr op `thenDs` \ core_op ->
mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
dsCmdStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
- (tupleType env_ids)
- (tupleType env_ids')
+ (mkTupleType env_ids)
+ (mkTupleType env_ids')
res_ty
core_stmt
core_stmts,
fv_stmt)
+\end{code}
+A statement maps one local environment to another, and is represented
+as an arrow from one tuple type to another. A statement sequence is
+translated to a composition of such arrows.
+\begin{code}
+
dsCmdStmt
:: DsCmdEnv -- arrow combinators
-> IdSet -- set of local vars available to this statement
IdSet) -- set of local vars that occur free
-- A | xs1 |- c :: [] t
--- A | xs' |- do { ss } :: [] t
+-- A | xs' |- do { ss } :: [] t'
-- ------------------------------
--- A | xs |- do { c; ss } :: [] t
+-- A | xs |- do { c; ss } :: [] t'
--
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty locn)
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc)
= dsfixCmd ids local_vars [] c_ty cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
matchEnvStack env_ids []
(mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr out_ids))
`thenDs` \ core_mux ->
let
- in_ty = tupleType env_ids
- in_ty1 = tupleType env_ids1
- out_ty = tupleType out_ids
+ in_ty = mkTupleType env_ids
+ in_ty1 = mkTupleType env_ids1
+ out_ty = mkTupleType out_ids
before_c_ty = mkCorePairTy in_ty1 out_ty
after_c_ty = mkCorePairTy c_ty out_ty
in
where
-- A | xs1 |- c :: [] t
--- A | xs' |- do { ss } :: [] t xs2 = xs' - defs(p)
+-- A | xs' |- do { ss } :: [] t' xs2 = xs' - defs(p)
-- -----------------------------------
--- A | xs |- do { p <- c; ss } :: [] t
+-- A | xs |- do { p <- c; ss } :: [] t'
--
-- ---> arr (\ (xs) -> ((xs1),(xs2))) >>> first c >>>
-- arr (\ (p, (xs2)) -> (xs')) >>> ss
-- It would be simpler and more consistent to do this using second,
-- but that's likely to be defined in terms of first.
-dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd locn)
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc)
= dsfixCmd ids local_vars [] (hsPatType pat) cmd
`thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
let
+ pat_ty = hsPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
+ env_ty2 = mkTupleType env_ids2
in
-- multiplexing function
-- \ (p, (xs2)) -> (zs)
selectMatchVar pat `thenDs` \ pat_id ->
- newSysLocalDs (tupleType env_ids2) `thenDs` \ env_id ->
+ newSysLocalDs env_ty2 `thenDs` \ env_id ->
getUniqSupplyDs `thenDs` \ uniqs ->
let
- pair_ids = [pat_id, env_id]
- after_c_ty = tupleType pair_ids
- out_ty = tupleType out_ids
+ after_c_ty = mkCorePairTy pat_ty env_ty2
+ out_ty = mkTupleType out_ids
body_expr = coreCaseTuple uniqs env_id env_ids2 (mkTupleExpr out_ids)
in
mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
`thenDs` \ match_code ->
newSysLocalDs after_c_ty `thenDs` \ pair_id ->
let
- proj_expr = Lam pair_id (coreCaseSmallTuple pair_id pair_ids match_code)
+ proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
in
- -- put it all togther
+ -- put it all together
let
- pat_ty = hsPatType pat
- in_ty = tupleType env_ids
- in_ty1 = tupleType env_ids1
- in_ty2 = tupleType env_ids2
+ in_ty = mkTupleType env_ids
+ in_ty1 = mkTupleType env_ids1
+ in_ty2 = mkTupleType 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 $
-- match the old environment against the input
matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
returnDs (do_arr ids
- (tupleType env_ids)
- (tupleType out_ids)
+ (mkTupleType env_ids)
+ (mkTupleType out_ids)
core_map,
exprFreeVars core_binds `intersectVarSet` local_vars)
-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'
-dsCmdStmt ids local_vars env_ids out_ids' (RecStmt stmts later_ids rec_ids rhss)
+dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss)
+ = let
+ env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
+ env2_ids = varSetElems env2_id_set
+ env2_ty = mkTupleType env2_ids
+ in
+
+ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+ getUniqSupplyDs `thenDs` \ uniqs ->
+ newSysLocalDs env2_ty `thenDs` \ env2_id ->
+ let
+ later_ty = mkTupleType later_ids
+ post_pair_ty = mkCorePairTy later_ty env2_ty
+ post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids)
+ in
+ matchEnvStack later_ids [env2_id] post_loop_body
+ `thenDs` \ post_loop_fn ->
+
+ --- loop (...)
+
+ dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+ `thenDs` \ (core_loop, env1_id_set, env1_ids) ->
+
+ -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+ let
+ env1_ty = mkTupleType env1_ids
+ pre_pair_ty = mkCorePairTy env1_ty env2_ty
+ pre_loop_body = mkCorePairExpr (mkTupleExpr env1_ids)
+ (mkTupleExpr env2_ids)
+
+ in
+ matchEnvStack env_ids [] pre_loop_body
+ `thenDs` \ pre_loop_fn ->
+
+ -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+ let
+ env_ty = mkTupleType env_ids
+ out_ty = mkTupleType 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
+ (do_first ids env1_ty later_ty env2_ty
+ core_loop)
+ (do_arr ids post_pair_ty out_ty
+ post_loop_fn))
+ in
+ returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
+
+-- loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
+-- ss >>>
+-- arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
+
+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 = tupleType out_ids
+ out_ty = mkTupleType out_ids
local_vars' = local_vars `unionVarSet` rec_id_set
in
mapDs dsExpr rhss `thenDs` \ core_rhss ->
let
later_tuple = mkTupleExpr later_ids
- later_ty = tupleType later_ids
- rec_tuple = mkCoreTup core_rhss
- rec_ty = tupleType rec_ids
- out_pair = mkCoreTup [later_tuple, rec_tuple]
- out_pair_ty = mkCoreTupTy [later_ty, rec_ty]
+ later_ty = mkTupleType later_ids
+ rec_tuple = mkBigCoreTup core_rhss
+ rec_ty = mkTupleType rec_ids
+ out_pair = mkCorePairExpr later_tuple rec_tuple
+ out_pair_ty = mkCorePairTy later_ty rec_ty
in
matchEnvStack out_ids [] out_pair
`thenDs` \ mk_pair_fn ->
+ -- ss
+
dsfixCmdStmts ids local_vars' out_ids stmts
- `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
+ `thenDs` \ (core_stmts, fv_stmts, env_ids) ->
- -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids')
+ -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
newSysLocalDs rec_ty `thenDs` \ rec_id ->
let
env1_id_set = fv_stmts `minusVarSet` rec_id_set
env1_ids = varSetElems env1_id_set
- env1_ty = tupleType env1_ids
- in_pair_ty = mkCoreTupTy [env1_ty, rec_ty]
- core_body = mkCoreTup (map selectVar env_ids')
+ env1_ty = mkTupleType env1_ids
+ in_pair_ty = mkCorePairTy env1_ty rec_ty
+ core_body = mkBigCoreTup (map selectVar env_ids)
where
selectVar v
| v `elemVarSet` rec_id_set
-- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
let
- env_ty' = tupleType env_ids'
+ env_ty = mkTupleType 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
+ (do_map_arrow ids in_pair_ty env_ty out_pair_ty
squash_pair_fn
- (do_compose ids env_ty' out_ty out_pair_ty
+ (do_compose ids env_ty out_ty out_pair_ty
core_stmts
(do_arr ids out_ty out_pair_ty mk_pair_fn)))
in
-
- -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
-
- let
- env_ty = tupleType env_ids
- env2_id_set = mkVarSet out_ids' `minusVarSet` mkVarSet later_ids
- env2_ids = varSetElems env2_id_set
- env2_ty = tupleType env2_ids
- pre_pair_ty = mkCoreTupTy [env1_ty, env2_ty]
- pre_loop_body = mkCoreTup [mkTupleExpr env1_ids, mkTupleExpr env2_ids]
-
- in
- matchEnvStack env_ids [] pre_loop_body
- `thenDs` \ pre_loop_fn ->
-
- -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids')
-
- getUniqSupplyDs `thenDs` \ uniqs ->
- newSysLocalDs env2_ty `thenDs` \ env2_id ->
- let
- out_ty' = tupleType out_ids'
- post_pair_ty = mkCoreTupTy [later_ty, env2_ty]
- post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkTupleExpr out_ids')
- in
- matchEnvStack later_ids [env2_id] post_loop_body
- `thenDs` \ post_loop_fn ->
-
- -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
-
- let
- 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'
- (do_first ids env1_ty later_ty env2_ty
- core_loop)
- (do_arr ids post_pair_ty out_ty'
- post_loop_fn))
- in
- returnDs (core_body, env1_id_set `unionVarSet` env2_id_set)
+ returnDs (core_loop, env1_id_set, env1_ids)
\end{code}
-A sequence of statements (as is a rec) is desugared to an arrow between
+A sequence of statements (as in a rec) is desugared to an arrow between
two environments
\begin{code}
dsCmdStmt ids local_vars env_ids env_ids' stmt
`thenDs` \ (core_stmt, fv_stmt) ->
returnDs (do_compose ids
- (tupleType env_ids)
- (tupleType env_ids')
- (tupleType out_ids)
+ (mkTupleType env_ids)
+ (mkTupleType env_ids')
+ (mkTupleType out_ids)
core_stmt
core_stmts,
fv_stmt)
-> CoreExpr -- Return this if they all match
-> CoreExpr -- Return this if they don't
-> DsM CoreExpr
-matchSimplys [] _ctxt [] result_expr fail_expr = returnDs result_expr
+matchSimplys [] _ctxt [] result_expr _fail_expr = returnDs result_expr
matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr
= matchSimplys exps ctxt pats result_expr fail_expr
`thenDs` \ match_code ->
matchSimply exp ctxt pat match_code fail_expr
\end{code}
-\begin{code}
+List of leaf expressions, with set of variables bound in each
--- list of leaf expressions, with set of variables bound in each
+\begin{code}
leavesMatch :: TypecheckedMatch -> [(TypecheckedHsExpr, IdSet)]
leavesMatch (Match pats _ (GRHSs grhss binds _ty))
= let
[(expr, mkVarSet (collectStmtsBinders stmts) `unionVarSet` defined_vars) |
GRHS stmts _locn <- grhss,
let ResultStmt expr _ = last stmts]
+\end{code}
--- Replace the leaf commands in a match
+Replace the leaf commands in a match
+\begin{code}
replaceLeavesMatch
:: Type -- new result type
-> [TypecheckedHsExpr] -- replacement leaf expressions of that type
TypecheckedMatch) -- updated match
replaceLeavesMatch res_ty leaves (Match pat mt (GRHSs grhss binds _ty))
= let
- (leaves', grhss') = mapAccumL (replaceLeavesGRHS res_ty) leaves grhss
+ (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
(leaves', Match pat mt (GRHSs grhss' binds res_ty))
replaceLeavesGRHS
- :: Type -- new result type
- -> [TypecheckedHsExpr] -- replacement leaf expressions of that type
+ :: [TypecheckedHsExpr] -- replacement leaf expressions of that type
-> TypecheckedGRHS -- rhss of a case command
-> ([TypecheckedHsExpr],-- remaining leaf expressions
TypecheckedGRHS) -- updated GRHS
-replaceLeavesGRHS res_ty (leaf:leaves) (GRHS stmts srcloc)
+replaceLeavesGRHS (leaf:leaves) (GRHS stmts srcloc)
= (leaves, GRHS (init stmts ++ [ResultStmt leaf srcloc]) srcloc)
-
\end{code}
Balanced fold of a non-empty list.
\begin{code}
foldb :: (a -> a -> a) -> [a] -> a
-foldb f [] = error "foldb of empty list"
-foldb f [x] = x
+foldb _ [] = error "foldb of empty list"
+foldb _ [x] = x
foldb f xs = foldb f (fold_pairs xs)
where
fold_pairs [] = []
projects / ghc-hetmet.git / blobdiff