import DsUtils
import DsMonad
-import HsSyn
+import HsSyn hiding (collectPatBinders, collectPatsBinders )
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
import CoreSyn
import CoreFVs
import CoreUtils
+import MkCore
-import Id
import Name
+import Var
+import Id
import PrelInfo
import DataCon
import TysWiredIn
import BasicTypes
import PrelNames
-import Util
-
-import HsUtils
+import Outputable
+import Bag
import VarSet
import SrcLoc
+
+import Data.List
\end{code}
\begin{code}
}
mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv
-mkCmdEnv ids
- = dsSyntaxTable ids `thenDs` \ (meth_binds, ds_meths) ->
+mkCmdEnv ids = do
+ (meth_binds, ds_meths) <- dsSyntaxTable ids
return $ DsCmdEnv {
- meth_binds = meth_binds,
- arr_id = Var (lookupEvidence ds_meths arrAName),
- compose_id = Var (lookupEvidence ds_meths composeAName),
- first_id = Var (lookupEvidence ds_meths firstAName),
- app_id = Var (lookupEvidence ds_meths appAName),
- choice_id = Var (lookupEvidence ds_meths choiceAName),
- loop_id = Var (lookupEvidence ds_meths loopAName)
- }
+ meth_binds = meth_binds,
+ arr_id = Var (lookupEvidence ds_meths arrAName),
+ compose_id = Var (lookupEvidence ds_meths composeAName),
+ first_id = Var (lookupEvidence ds_meths firstAName),
+ app_id = Var (lookupEvidence ds_meths appAName),
+ choice_id = Var (lookupEvidence ds_meths choiceAName),
+ loop_id = Var (lookupEvidence ds_meths loopAName)
+ }
bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr
bindCmdEnv ids body = foldr Let body (meth_binds ids)
do_map_arrow :: DsCmdEnv -> Type -> Type -> Type ->
CoreExpr -> CoreExpr -> CoreExpr
do_map_arrow ids b_ty c_ty d_ty f c
- = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
+ = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c
mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
mkFailExpr ctxt ty
-- 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 (Lam pair_var
- (coreCasePair pair_var a_var b_var (Var b_var)))
+mkSndExpr a_ty b_ty = do
+ a_var <- newSysLocalDs a_ty
+ b_var <- newSysLocalDs b_ty
+ pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+ return (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,
\begin{code}
mkCorePairTy :: Type -> Type -> Type
-mkCorePairTy t1 t2 = mkCoreTupTy [t1, t2]
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
The input is divided into a local environment, which is a flat tuple
(unless it's too big), and a stack, each element of which is paired
-with the stack in turn. In general, the input has the form
+with the environment in turn. In general, the input has the form
(...((x1,...,xn),s1),...sk)
\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
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
-> [Id] -- s1..sk
-> CoreExpr -- e
-> DsM CoreExpr
-matchEnvStack env_ids stack_ids body
- = newUniqueSupply `thenDs` \ uniqs ->
- newSysLocalDs (mkTupleType env_ids) `thenDs` \ tup_var ->
- matchVarStack tup_var stack_ids
- (coreCaseTuple uniqs tup_var env_ids body)
+matchEnvStack env_ids stack_ids body = do
+ uniqs <- newUniqueSupply
+ tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+ matchVarStack tup_var stack_ids
+ (coreCaseTuple uniqs tup_var env_ids body)
----------------------------------------------
-> CoreExpr -- e
-> DsM CoreExpr
matchVarStack env_id [] body
- = returnDs (Lam env_id body)
-matchVarStack env_id (stack_id:stack_ids) body
- = newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id))
- `thenDs` \ pair_id ->
- matchVarStack pair_id stack_ids
- (coreCasePair pair_id env_id stack_id body)
+ = return (Lam env_id body)
+matchVarStack env_id (stack_id:stack_ids) body = do
+ pair_id <- newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id))
+ matchVarStack pair_id stack_ids
+ (coreCasePair pair_id env_id stack_id body)
\end{code}
\begin{code}
-mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id
-mkHsTupleExpr [e] = e
-mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed
-
-mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id
-mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2]
-
-mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id
+mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id
mkHsEnvStackExpr env_ids stack_ids
- = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids)
+ = foldl (\a b -> mkLHsTupleExpr [a,b])
+ (mkLHsVarTuple env_ids)
+ (map nlHsVar stack_ids)
\end{code}
Translation of arrow abstraction
:: LPat Id
-> LHsCmdTop Id
-> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids))
- = mkCmdEnv ids `thenDs` \ meth_ids ->
- let
- locals = mkVarSet (collectPatBinders pat)
- in
- dsfixCmd meth_ids locals [] cmd_ty cmd
- `thenDs` \ (core_cmd, free_vars, env_ids) ->
- let
- env_ty = mkTupleType env_ids
- in
- mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr ->
- selectSimpleMatchVarL pat `thenDs` \ var ->
- matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr
- `thenDs` \ match_code ->
- let
- pat_ty = hsLPatType pat
- proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
- (Lam var match_code)
- core_cmd
- in
- returnDs (bindCmdEnv meth_ids proc_code)
+dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) = do
+ meth_ids <- mkCmdEnv ids
+ let locals = mkVarSet (collectPatBinders pat)
+ (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd
+ let env_ty = mkBigCoreVarTupTy env_ids
+ fail_expr <- mkFailExpr ProcExpr env_ty
+ var <- selectSimpleMatchVarL pat
+ match_code <- matchSimply (Var var) ProcExpr pat (mkBigCoreVarTup env_ids) fail_expr
+ let pat_ty = hsLPatType pat
+ proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty
+ (Lam var match_code)
+ core_cmd
+ return (bindCmdEnv meth_ids proc_code)
+dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c)
\end{code}
Translation of command judgements of the form
A | xs |- c :: [ts] t
\begin{code}
+dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id
+ -> DsM (CoreExpr, IdSet)
dsLCmd ids local_vars env_ids stack res_ty cmd
= dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
-- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
dsCmd ids local_vars env_ids stack res_ty
- (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
- = let
- (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+ (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)= do
+ let
+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- env_ty = mkTupleType env_ids
- in
- dsLExpr arrow `thenDs` \ core_arrow ->
- dsLExpr arg `thenDs` \ core_arg ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
- matchEnvStack env_ids stack_ids
- (foldl mkCorePairExpr core_arg (map Var stack_ids))
- `thenDs` \ core_make_arg ->
- returnDs (do_map_arrow ids
- (envStackType env_ids stack)
- arg_ty
- res_ty
- core_make_arg
- core_arrow,
- exprFreeVars core_arg `intersectVarSet` local_vars)
+ core_arrow <- dsLExpr arrow
+ core_arg <- dsLExpr arg
+ stack_ids <- mapM newSysLocalDs stack
+ core_make_arg <- matchEnvStack env_ids stack_ids
+ (foldl mkCorePairExpr core_arg (map Var stack_ids))
+ return (do_map_arrow ids
+ (envStackType env_ids stack)
+ arg_ty
+ res_ty
+ core_make_arg
+ core_arrow,
+ exprFreeVars core_arg `intersectVarSet` local_vars)
-- A, xs |- f :: a (t*ts) t'
-- A, xs |- arg :: t
-- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
dsCmd ids local_vars env_ids stack res_ty
- (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
- = let
- (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+ (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = do
+ let
+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
(_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
- env_ty = mkTupleType env_ids
- in
- dsLExpr arrow `thenDs` \ core_arrow ->
- dsLExpr arg `thenDs` \ core_arg ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
- matchEnvStack env_ids stack_ids
- (mkCorePairExpr core_arrow
- (foldl mkCorePairExpr core_arg (map Var stack_ids)))
- `thenDs` \ core_make_pair ->
- returnDs (do_map_arrow ids
- (envStackType env_ids stack)
- (mkCorePairTy arrow_ty arg_ty)
- res_ty
- core_make_pair
- (do_app ids arg_ty res_ty),
- (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
- `intersectVarSet` local_vars)
+
+ core_arrow <- dsLExpr arrow
+ core_arg <- dsLExpr arg
+ stack_ids <- mapM newSysLocalDs stack
+ core_make_pair <- matchEnvStack env_ids stack_ids
+ (mkCorePairExpr core_arrow
+ (foldl mkCorePairExpr core_arg (map Var stack_ids)))
+
+ return (do_map_arrow ids
+ (envStackType env_ids stack)
+ (mkCorePairTy arrow_ty arg_ty)
+ res_ty
+ core_make_pair
+ (do_app ids arg_ty res_ty),
+ (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
+ `intersectVarSet` local_vars)
-- A | ys |- c :: [t:ts] t'
-- A, xs |- e :: t
--
-- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
-dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg)
- = dsLExpr arg `thenDs` \ core_arg ->
+dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
+ core_arg <- dsLExpr 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') ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
- newSysLocalDs arg_ty `thenDs` \ arg_id ->
+ arg_ty = exprType core_arg
+ stack' = arg_ty:stack
+ (core_cmd, free_vars, env_ids')
+ <- dsfixCmd ids local_vars stack' res_ty cmd
+ stack_ids <- mapM newSysLocalDs stack
+ arg_id <- newSysLocalDs arg_ty
-- push the argument expression onto the stack
let
- core_body = bindNonRec arg_id core_arg
- (buildEnvStack env_ids' (arg_id:stack_ids))
- in
+ core_body = bindNonRec arg_id core_arg
+ (buildEnvStack env_ids' (arg_id:stack_ids))
-- 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)
+ core_map <- matchEnvStack env_ids stack_ids core_body
+ return (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'
-- -----------------------------------------------
-- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
dsCmd ids local_vars env_ids stack res_ty
- (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
- = let
- pat_vars = mkVarSet (collectPatsBinders pats)
- local_vars' = local_vars `unionVarSet` pat_vars
- stack' = drop (length pats) stack
- in
- dsfixCmd ids local_vars' stack' res_ty body
- `thenDs` \ (core_body, free_vars, env_ids') ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+ (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = do
+ let
+ pat_vars = mkVarSet (collectPatsBinders pats)
+ local_vars' = local_vars `unionVarSet` pat_vars
+ stack' = drop (length pats) stack
+ (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body
+ stack_ids <- mapM newSysLocalDs stack
-- the expression is built from the inside out, so the actions
-- are presented in reverse order
let
(actual_ids, stack_ids') = splitAt (length pats) stack_ids
- -- build a new environment, plus what's left of the stack
- core_expr = buildEnvStack env_ids' stack_ids'
- in_ty = envStackType env_ids stack
- in_ty' = envStackType env_ids' stack'
- in
- mkFailExpr LambdaExpr in_ty' `thenDs` \ fail_expr ->
+ -- build a new environment, plus what's left of the stack
+ core_expr = buildEnvStack env_ids' stack_ids'
+ in_ty = envStackType env_ids stack
+ in_ty' = envStackType env_ids' stack'
+
+ fail_expr <- mkFailExpr LambdaExpr in_ty'
-- match the patterns against the top of the old stack
- matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
- `thenDs` \ match_code ->
+ match_code <- matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr
-- match the old environment and stack against the input
- matchEnvStack env_ids stack_ids match_code
- `thenDs` \ select_code ->
- returnDs (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
- free_vars `minusVarSet` pat_vars)
+ select_code <- matchEnvStack env_ids stack_ids match_code
+ return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
+ free_vars `minusVarSet` pat_vars)
dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
= dsLCmd ids local_vars env_ids stack res_ty cmd
-- 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)
- = dsLExpr 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) ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
- dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
- dsLookupDataCon leftDataConName `thenDs` \ left_con ->
- dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) = do
+ core_cond <- dsLExpr cond
+ (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
+ (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd
+ stack_ids <- mapM newSysLocalDs stack
+ either_con <- dsLookupTyCon eitherTyConName
+ left_con <- dsLookupDataCon leftDataConName
+ right_con <- dsLookupDataCon rightDataConName
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)
+ 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
+
+ core_if <- 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)))
+ return (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
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
+To build all this, we use triples describing 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
+ * 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
+ * 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
+ * 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 (MatchGroup matches match_ty))
- = dsLExpr exp `thenDs` \ core_exp ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do
+ stack_ids <- mapM newSysLocalDs stack
-- Extract and desugar the leaf commands in the case, building tuple
-- expressions that will (after tagging) replace these leaves
let
leaves = concatMap leavesMatch matches
- make_branch (leaf, bound_vars)
- = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
- `thenDs` \ (core_leaf, fvs, leaf_ids) ->
- returnDs (fvs `minusVarSet` bound_vars,
- [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids],
- envStackType leaf_ids stack,
- core_leaf)
- in
- mappM make_branch leaves `thenDs` \ branches ->
- dsLookupTyCon eitherTyConName `thenDs` \ either_con ->
- dsLookupDataCon leftDataConName `thenDs` \ left_con ->
- dsLookupDataCon rightDataConName `thenDs` \ right_con ->
+ make_branch (leaf, bound_vars) = do
+ (core_leaf, _fvs, leaf_ids) <-
+ dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+ return ([mkHsEnvStackExpr leaf_ids stack_ids],
+ envStackType leaf_ids stack,
+ core_leaf)
+
+ branches <- mapM make_branch leaves
+ either_con <- dsLookupTyCon eitherTyConName
+ left_con <- dsLookupDataCon leftDataConName
+ right_con <- dsLookupDataCon rightDataConName
let
- left_id = HsVar (dataConWrapId left_con)
- right_id = HsVar (dataConWrapId right_con)
- left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
- right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-
- -- Prefix each tuple with a distinct series of Left's and Right's,
- -- in a balanced way, keeping track of the types.
-
- merge_branches (fvs1, builds1, in_ty1, core_exp1)
- (fvs2, builds2, in_ty2, core_exp2)
- = (fvs1 `unionVarSet` fvs2,
- map (left_expr in_ty1 in_ty2) builds1 ++
- 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_alts, leaves', sum_ty, core_choices)
- = foldb merge_branches branches
-
- -- Replace the commands in the case with these tagged tuples,
- -- yielding a HsExpr Id 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
-
- pat_ty = funArgTy match_ty
- match_ty' = mkFunTy pat_ty sum_ty
- -- Note that we replace the HsCase result type by sum_ty,
- -- which is the type of matches'
- in
- dsExpr (HsCase exp (MatchGroup matches' match_ty')) `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,
- fvs_exp `unionVarSet` fvs_alts)
+ left_id = HsVar (dataConWrapId left_con)
+ right_id = HsVar (dataConWrapId right_con)
+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+
+ -- Prefix each tuple with a distinct series of Left's and Right's,
+ -- in a balanced way, keeping track of the types.
+
+ merge_branches (builds1, in_ty1, core_exp1)
+ (builds2, in_ty2, core_exp2)
+ = (map (left_expr in_ty1 in_ty2) builds1 ++
+ 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)
+ (leaves', sum_ty, core_choices) = foldb merge_branches branches
+
+ -- Replace the commands in the case with these tagged tuples,
+ -- yielding a HsExpr Id we can feed to dsExpr.
+
+ (_, 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
+ -- 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_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
+ exprFreeVars core_body `intersectVarSet` local_vars)
-- A | ys |- c :: [ts] t
-- ----------------------------------
--
-- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
-dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
- = let
- defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
- local_vars' = local_vars `unionVarSet` defined_vars
- in
- dsfixCmd ids local_vars' stack res_ty body
- `thenDs` \ (core_body, free_vars, env_ids') ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
+dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
+ let
+ defined_vars = mkVarSet (collectLocalBinders binds)
+ local_vars' = local_vars `unionVarSet` defined_vars
+
+ (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
+ stack_ids <- mapM newSysLocalDs stack
-- build a new environment, plus the stack, using the let bindings
- dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
- `thenDs` \ core_binds ->
+ core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
-- match the old environment and stack against the input
- matchEnvStack env_ids stack_ids core_binds
- `thenDs` \ core_map ->
- returnDs (do_map_arrow ids
- (envStackType env_ids stack)
- (envStackType env_ids' stack)
- res_ty
- core_map
- core_body,
- exprFreeVars core_binds `intersectVarSet` local_vars)
+ core_map <- matchEnvStack env_ids stack_ids core_binds
+ return (do_map_arrow ids
+ (envStackType env_ids stack)
+ (envStackType env_ids' stack)
+ res_ty
+ core_map
+ core_body,
+ exprFreeVars core_binds `intersectVarSet` local_vars)
dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
= dsCmdDo ids local_vars env_ids res_ty stmts body
-- -----------------------------------
-- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn
-dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args)
- = let
- env_ty = mkTupleType env_ids
- in
- dsLExpr op `thenDs` \ core_op ->
- mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args
- `thenDs` \ (core_args, fv_sets) ->
- returnDs (mkApps (App core_op (Type env_ty)) core_args,
- unionVarSets fv_sets)
+dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = do
+ let env_ty = mkBigCoreVarTupTy env_ids
+ core_op <- dsLExpr op
+ (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
+ return (mkApps (App core_op (Type env_ty)) core_args,
+ unionVarSets fv_sets)
-dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr)
- = dsLCmd ids local_vars env_ids stack res_ty expr `thenDs` \ (expr1,id_set) ->
- mkTickBox ix vars expr1 `thenDs` \ expr2 ->
+dsCmd ids local_vars env_ids stack res_ty (HsTick ix vars expr) = do
+ (expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr
+ expr2 <- mkTickBox ix vars expr1
return (expr2,id_set)
+dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
+
-- A | ys |- c :: [ts] t (ys <= xs)
-- ---------------------
-- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> c
-> LHsCmdTop Id -- command argument to desugar
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids))
- = mkCmdEnv ids `thenDs` \ meth_ids ->
- dsfixCmd meth_ids local_vars stack cmd_ty cmd
- `thenDs` \ (core_cmd, free_vars, env_ids') ->
- mappM newSysLocalDs stack `thenDs` \ stack_ids ->
- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
- `thenDs` \ trim_code ->
+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
+ meth_ids <- mkCmdEnv ids
+ (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd
+ stack_ids <- mapM newSysLocalDs stack
+ trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids)
let
- in_ty = envStackType env_ids stack
- in_ty' = envStackType env_ids' stack
- arg_code = if env_ids' == env_ids then core_cmd else
- do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
- in
- returnDs (bindCmdEnv meth_ids arg_code, free_vars)
+ in_ty = envStackType env_ids stack
+ in_ty' = envStackType env_ids' stack
+ arg_code = if env_ids' == env_ids then core_cmd else
+ do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+ return (bindCmdEnv meth_ids arg_code, free_vars)
-- Given A | xs |- c :: [ts] t, builds c with xs fed back.
-- Typically needs to be prefixed with arr (\p -> ((xs)*ts))
IdSet, -- set of local vars that occur free
[Id]) -- set as a list, fed back
dsfixCmd ids local_vars stack cmd_ty cmd
- = fixDs (\ ~(_,_,env_ids') ->
- dsLCmd ids local_vars env_ids' stack cmd_ty cmd
- `thenDs` \ (core_cmd, free_vars) ->
- returnDs (core_cmd, free_vars, varSetElems free_vars))
+ = fixDs (\ ~(_,_,env_ids') -> do
+ (core_cmd, free_vars) <- dsLCmd ids local_vars env_ids' stack cmd_ty cmd
+ return (core_cmd, free_vars, varSetElems free_vars))
\end{code}
dsCmdDo ids local_vars env_ids res_ty [] body
= dsLCmd ids local_vars env_ids [] res_ty body
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body
- = let
- bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
- local_vars' = local_vars `unionVarSet` bound_vars
- in
- fixDs (\ ~(_,_,env_ids') ->
- dsCmdDo ids local_vars' env_ids' res_ty stmts body
- `thenDs` \ (core_stmts, fv_stmts) ->
- returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
- `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
- dsCmdLStmt ids local_vars env_ids env_ids' stmt
- `thenDs` \ (core_stmt, fv_stmt) ->
- returnDs (do_compose ids
- (mkTupleType env_ids)
- (mkTupleType env_ids')
- res_ty
- core_stmt
- core_stmts,
- fv_stmt)
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+ let
+ bound_vars = mkVarSet (collectLStmtBinders stmt)
+ local_vars' = local_vars `unionVarSet` bound_vars
+ (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
+ (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+ return (core_stmts, fv_stmts, varSetElems fv_stmts))
+ (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
+ return (do_compose ids
+ (mkBigCoreVarTupTy env_ids)
+ (mkBigCoreVarTupTy 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}
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id
+ -> DsM (CoreExpr, IdSet)
dsCmdLStmt ids local_vars env_ids out_ids cmd
= dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-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))
- `thenDs` \ core_mux ->
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do
+ (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
+ core_mux <- matchEnvStack env_ids []
+ (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
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
- mkSndExpr c_ty out_ty `thenDs` \ snd_fn ->
- returnDs (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
+ snd_fn <- mkSndExpr c_ty out_ty
+ return (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
do_compose ids before_c_ty after_c_ty out_ty
(do_first ids in_ty1 c_ty out_ty core_cmd) $
do_arr ids after_c_ty out_ty snd_fn,
-- 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 _ _)
- = dsfixCmd ids local_vars [] (hsLPatType pat) cmd
- `thenDs` \ (core_cmd, fv_cmd, env_ids1) ->
+dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do
+ (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd
let
pat_ty = hsLPatType pat
pat_vars = mkVarSet (collectPatBinders pat)
env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)
- env_ty2 = mkTupleType env_ids2
- in
+ env_ty2 = mkBigCoreVarTupTy env_ids2
-- multiplexing function
-- \ (xs) -> ((xs1),(xs2))
- matchEnvStack env_ids []
- (mkCorePairExpr (mkTupleExpr env_ids1) (mkTupleExpr env_ids2))
- `thenDs` \ core_mux ->
+ core_mux <- matchEnvStack env_ids []
+ (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup env_ids2))
-- projection function
-- \ (p, (xs2)) -> (zs)
- newSysLocalDs env_ty2 `thenDs` \ env_id ->
- newUniqueSupply `thenDs` \ uniqs ->
+ env_id <- newSysLocalDs env_ty2
+ uniqs <- newUniqueSupply
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)
- in
- mkFailExpr (StmtCtxt DoExpr) out_ty `thenDs` \ fail_expr ->
- selectSimpleMatchVarL pat `thenDs` \ pat_id ->
- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
- `thenDs` \ match_code ->
- newSysLocalDs after_c_ty `thenDs` \ pair_id ->
+ out_ty = mkBigCoreVarTupTy out_ids
+ body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+
+ fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
+ pat_id <- selectSimpleMatchVarL pat
+ match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+ pair_id <- newSysLocalDs after_c_ty
let
proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
- in
-- 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 $
+ return (do_map_arrow ids in_ty before_c_ty out_ty core_mux $
do_compose ids before_c_ty after_c_ty out_ty
(do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
do_arr ids after_c_ty out_ty proj_expr,
--
-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
+dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
-- build a new environment using the let bindings
- = dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
+ core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-- 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)
+ core_map <- matchEnvStack env_ids [] core_binds
+ return (do_arr ids
+ (mkBigCoreVarTupTy env_ids)
+ (mkBigCoreVarTupTy 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 binds)
- = 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
- in
+dsCmdStmt ids local_vars env_ids out_ids
+ (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
+ , recS_rec_rets = rhss, recS_dicts = _binds }) = do
+ 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 = mkBigCoreVarTupTy env2_ids
-- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
- newUniqueSupply `thenDs` \ uniqs ->
- newSysLocalDs env2_ty `thenDs` \ env2_id ->
+ uniqs <- newUniqueSupply
+ env2_id <- newSysLocalDs env2_ty
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 ->
+ later_ty = mkBigCoreVarTupTy later_ids
+ post_pair_ty = mkCorePairTy later_ty env2_ty
+ post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
+
+ post_loop_fn <- matchEnvStack later_ids [env2_id] post_loop_body
--- loop (...)
- dsRecCmd ids local_vars stmts later_ids rec_ids rhss
- `thenDs` \ (core_loop, env1_id_set, env1_ids) ->
+ (core_loop, env1_id_set, env1_ids)
+ <- dsRecCmd ids local_vars stmts later_ids rec_ids rhss
-- 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)
+ env1_ty = mkBigCoreVarTupTy env1_ids
+ pre_pair_ty = mkCorePairTy env1_ty env2_ty
+ pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
+ (mkBigCoreVarTup env2_ids)
- in
- matchEnvStack env_ids [] pre_loop_body
- `thenDs` \ pre_loop_fn ->
+ pre_loop_fn <- matchEnvStack env_ids [] pre_loop_body
-- 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)
+ 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
+ (do_first ids env1_ty later_ty env2_ty
+ core_loop)
+ (do_arr ids post_pair_ty out_ty
+ post_loop_fn))
+
+ return (core_body, env1_id_set `unionVarSet` env2_id_set)
+
+dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
-- 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 = mkTupleType out_ids
- local_vars' = local_vars `unionVarSet` rec_id_set
- in
+dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id]
+ -> DsM (CoreExpr, VarSet, [Var])
+dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do
+ let
+ rec_id_set = mkVarSet rec_ids
+ out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
+ out_ty = mkBigCoreVarTupTy out_ids
+ local_vars' = local_vars `unionVarSet` rec_id_set
-- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
- mappM dsExpr rhss `thenDs` \ core_rhss ->
+ core_rhss <- mapM dsExpr rhss
let
- later_tuple = mkTupleExpr later_ids
- 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 ->
+ later_tuple = mkBigCoreVarTup later_ids
+ later_ty = mkBigCoreVarTupTy later_ids
+ rec_tuple = mkBigCoreTup core_rhss
+ rec_ty = mkBigCoreVarTupTy rec_ids
+ out_pair = mkCorePairExpr later_tuple rec_tuple
+ out_pair_ty = mkCorePairTy later_ty rec_ty
+
+ mk_pair_fn <- matchEnvStack out_ids [] out_pair
-- ss
- dsfixCmdStmts ids local_vars' out_ids stmts
- `thenDs` \ (core_stmts, fv_stmts, env_ids) ->
+ (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
-- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
- newSysLocalDs rec_ty `thenDs` \ rec_id ->
+ rec_id <- newSysLocalDs rec_ty
let
- env1_id_set = fv_stmts `minusVarSet` rec_id_set
- env1_ids = varSetElems env1_id_set
- 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
- = mkTupleSelector rec_ids v rec_id (Var rec_id)
- | otherwise = Var v
- in
- matchEnvStack env1_ids [rec_id] core_body
- `thenDs` \ squash_pair_fn ->
+ env1_id_set = fv_stmts `minusVarSet` rec_id_set
+ env1_ids = varSetElems env1_id_set
+ env1_ty = mkBigCoreVarTupTy 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
+ = mkTupleSelector rec_ids v rec_id (Var rec_id)
+ | otherwise = Var v
+
+ squash_pair_fn <- matchEnvStack env1_ids [rec_id] core_body
-- loop (arr squash_pair_fn >>> ss >>> arr mk_pair_fn)
let
- 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
- squash_pair_fn
- (do_compose ids env_ty out_ty out_pair_ty
- core_stmts
- (do_arr ids out_ty out_pair_ty mk_pair_fn)))
- in
- returnDs (core_loop, env1_id_set, env1_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
+ (do_compose ids env_ty out_ty out_pair_ty
+ core_stmts
+ (do_arr ids out_ty out_pair_ty mk_pair_fn)))
+
+ return (core_loop, env1_id_set, env1_ids)
\end{code}
A sequence of statements (as in a rec) is desugared to an arrow between
[Id]) -- input vars
dsfixCmdStmts ids local_vars out_ids stmts
- = fixDs (\ ~(_,_,env_ids) ->
- dsCmdStmts ids local_vars env_ids out_ids stmts
- `thenDs` \ (core_stmts, fv_stmts) ->
- returnDs (core_stmts, fv_stmts, varSetElems fv_stmts))
+ = fixDs (\ ~(_,_,env_ids) -> do
+ (core_stmts, fv_stmts) <- dsCmdStmts ids local_vars env_ids out_ids stmts
+ return (core_stmts, fv_stmts, varSetElems fv_stmts))
dsCmdStmts
:: DsCmdEnv -- arrow combinators
dsCmdStmts ids local_vars env_ids out_ids [stmt]
= dsCmdLStmt ids local_vars env_ids out_ids stmt
-dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts)
- = let
- bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt))
- local_vars' = local_vars `unionVarSet` bound_vars
- in
- dsfixCmdStmts ids local_vars' out_ids stmts
- `thenDs` \ (core_stmts, fv_stmts, env_ids') ->
- 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)
- core_stmt
- core_stmts,
- fv_stmt)
+dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
+ let
+ bound_vars = mkVarSet (collectLStmtBinders stmt)
+ local_vars' = local_vars `unionVarSet` bound_vars
+ (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
+ (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
+ return (do_compose ids
+ (mkBigCoreVarTupTy env_ids)
+ (mkBigCoreVarTupTy env_ids')
+ (mkBigCoreVarTupTy out_ids)
+ core_stmt
+ core_stmts,
+ fv_stmt)
+
+dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []"
\end{code}
-> 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 (exp:exps) ctxt (pat:pats) result_expr fail_expr
- = matchSimplys exps ctxt pats result_expr fail_expr
- `thenDs` \ match_code ->
+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
+ match_code <- matchSimplys exps ctxt pats result_expr fail_expr
matchSimply exp ctxt pat match_code fail_expr
+matchSimplys _ _ _ _ _ = panic "matchSimplys"
\end{code}
List of leaf expressions, with set of variables bound in each
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
- mkVarSet (map unLoc (collectLocalBinders binds))
+ mkVarSet (collectLocalBinders binds)
in
[(expr,
- mkVarSet (map unLoc (collectLStmtsBinders stmts))
+ mkVarSet (collectLStmtsBinders stmts)
`unionVarSet` defined_vars)
| L _ (GRHS stmts expr) <- grhss]
\end{code}
-> LMatch Id -- the matches of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LMatch Id) -- updated match
-replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
+replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds)))
= let
(leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
in
-> LGRHS Id -- rhss of a case command
-> ([LHsExpr Id],-- remaining leaf expressions
LGRHS Id) -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts rhs))
+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))
= (leaves, L loc (GRHS stmts leaf))
+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
\end{code}
Balanced fold of a non-empty list.
fold_pairs [x] = [x]
fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
\end{code}
+
+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The following functions to collect value variables from patterns are
+copied from HsUtils, with one change: we also collect the dictionary
+bindings (pat_binds) from ConPatOut. We need them for cases like
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+ GT -> returnA -< z+x
+
+The type checker turns the case into
+
+ case compare x y of
+ GT { p77 = plusInt } -> returnA -< p77 z x
+
+Here p77 is a local binding for the (+) operation.
+
+See comments in HsUtils for why the other version does not include
+these bindings.
+
+\begin{code}
+collectPatBinders :: LPat Id -> [Id]
+collectPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat Id] -> [Id]
+collectPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl :: LPat Id -> [Id] -> [Id]
+-- See Note [Dictionary binders in ConPatOut]
+collectl (L _ pat) bndrs
+ = go pat
+ where
+ go (VarPat var) = var : bndrs
+ go (VarPatOut var bs) = var : collectEvBinders bs
+ ++ bndrs
+ go (WildPat _) = bndrs
+ go (LazyPat pat) = collectl pat bndrs
+ go (BangPat pat) = collectl pat bndrs
+ go (AsPat (L _ a) pat) = a : collectl pat bndrs
+ go (ParPat pat) = collectl pat bndrs
+
+ go (ListPat pats _) = foldr collectl bndrs pats
+ go (PArrPat pats _) = foldr collectl bndrs pats
+ go (TuplePat pats _ _) = foldr collectl bndrs pats
+
+ go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)
+ go (ConPatOut {pat_args=ps, pat_binds=ds}) =
+ collectEvBinders ds
+ ++ foldr collectl bndrs (hsConPatArgs ps)
+ go (LitPat _) = bndrs
+ go (NPat _ _ _) = bndrs
+ go (NPlusKPat (L _ n) _ _ _) = n : bndrs
+
+ go (SigPatIn pat _) = collectl pat bndrs
+ go (SigPatOut pat _) = collectl pat bndrs
+ go (TypePat _) = bndrs
+ go (CoPat _ pat _) = collectl (noLoc pat) bndrs
+ go (ViewPat _ pat _) = collectl pat bndrs
+ go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
+
+collectEvBinders :: TcEvBinds -> [Id]
+collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs
+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
+
+add_ev_bndr :: EvBind -> [Id] -> [Id]
+add_ev_bndr (EvBind b _) bs | isId b = b:bs
+ | otherwise = bs
+ -- A worry: what about coercion variable binders??
+\end{code}
projects / ghc-hetmet.git / blobdiff