From 5ac88b392b71f7d9c71584df76b461bda19f91f4 Mon Sep 17 00:00:00 2001 From: ross Date: Tue, 15 Jul 2003 13:33:25 +0000 Subject: [PATCH] [project @ 2003-07-15 13:33:24 by ross] Add extra functions operating on outsized tuples (used by the translation of arrow notation). --- ghc/compiler/deSugar/DsArrows.lhs | 154 +++++++++++++++++-------------------- ghc/compiler/deSugar/DsUtils.lhs | 83 ++++++++++++++++++-- 2 files changed, 147 insertions(+), 90 deletions(-) diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index ea0e42b..c25dfda 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -11,6 +11,7 @@ module DsArrows ( dsProcExpr ) where import Match ( matchSimply ) import DsUtils ( mkErrorAppDs, mkCoreTupTy, mkCoreTup, selectMatchVar, + mkTupleCase, mkBigCoreTup, mkTupleType, mkTupleExpr, mkTupleSelector, dsReboundNames, lookupReboundName ) import DsMonad @@ -132,7 +133,7 @@ mkSndExpr a_ty b_ty newSysLocalDs b_ty `thenDs` \ b_var -> newSysLocalDs (mkCorePairTy a_ty b_ty) `thenDs` \ pair_var -> returnDs (Lam pair_var - (coreCaseSmallTuple pair_var [a_var, b_var] (Var b_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, @@ -144,23 +145,16 @@ because the list of variables is typically not yet defined. -- 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] @@ -179,39 +173,36 @@ 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 (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) @@ -219,27 +210,25 @@ matchEnvStack env_ids stack_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} @@ -279,7 +268,7 @@ dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn 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 -> @@ -322,7 +311,7 @@ dsCmd ids local_vars env_ids [] res_ty = let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - env_ty = tupleType env_ids + env_ty = mkTupleType env_ids in dsExpr arrow `thenDs` \ core_arrow -> dsExpr arg `thenDs` \ core_arg -> @@ -342,11 +331,11 @@ dsCmd ids local_vars env_ids [] res_ty = let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty - env_ty = tupleType env_ids + 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 @@ -520,7 +509,7 @@ dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc) 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 @@ -609,8 +598,8 @@ dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) 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, @@ -634,9 +623,9 @@ dsCmdStmt 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 @@ -648,9 +637,9 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) (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 @@ -663,9 +652,9 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) 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 @@ -677,8 +666,10 @@ 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 @@ -692,12 +683,11 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) -- \ (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 -> @@ -705,15 +695,14 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) `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 $ @@ -734,8 +723,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) -- 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) @@ -757,7 +746,7 @@ 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 = tupleType env2_ids + env2_ty = mkTupleType env2_ids in -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) @@ -765,8 +754,8 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss) getUniqSupplyDs `thenDs` \ uniqs -> newSysLocalDs env2_ty `thenDs` \ env2_id -> let - later_ty = tupleType later_ids - post_pair_ty = mkCoreTupTy [later_ty, env2_ty] + 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 @@ -780,9 +769,10 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss) -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids)) let - env1_ty = tupleType env1_ids - pre_pair_ty = mkCoreTupTy [env1_ty, env2_ty] - pre_loop_body = mkCoreTup [mkTupleExpr env1_ids, mkTupleExpr env2_ids] + 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 @@ -791,8 +781,8 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt stmts later_ids rec_ids rhss) -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn let - env_ty = tupleType env_ids - out_ty = tupleType out_ids + 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 @@ -811,7 +801,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 = tupleType out_ids + out_ty = mkTupleType out_ids local_vars' = local_vars `unionVarSet` rec_id_set in @@ -820,11 +810,11 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss 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 -> @@ -840,9 +830,9 @@ 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 = 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 @@ -855,7 +845,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss -- 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 squash_pair_fn @@ -907,9 +897,9 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) 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) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 4705082..d7b55f5 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -25,6 +25,7 @@ module DsUtils ( mkStringLit, mkStringLitFS, mkIntegerExpr, mkSelectorBinds, mkTupleExpr, mkTupleSelector, + mkTupleType, mkTupleCase, mkBigCoreTup, mkCoreTup, mkCoreSel, mkCoreTupTy, dsReboundNames, lookupReboundName, @@ -43,9 +44,9 @@ import CoreSyn import Constants ( mAX_TUPLE_SIZE ) import DsMonad -import CoreUtils ( exprType, mkIfThenElse, mkCoerce ) +import CoreUtils ( exprType, mkIfThenElse, mkCoerce, bindNonRec ) import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody ) -import Id ( idType, Id, mkWildId, mkTemplateLocals ) +import Id ( idType, Id, mkWildId, mkTemplateLocals, mkSysLocal ) import Name ( Name ) import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons ) @@ -63,6 +64,7 @@ import TysWiredIn ( nilDataCon, consDataCon, stringTy, isPArrFakeCon ) import BasicTypes ( Boxity(..) ) import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet ) +import UniqSupply ( splitUniqSupply, uniqFromSupply ) import PrelNames ( unpackCStringName, unpackCStringUtf8Name, plusIntegerName, timesIntegerName, lengthPName, indexPName ) @@ -621,14 +623,21 @@ a 10-tuple of 2-tuples (11 objects). So we want the leaves to be big. \begin{code} mkTupleExpr :: [Id] -> CoreExpr -mkTupleExpr ids - = mk_tuple_expr (chunkify (map Var ids)) +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) where - mk_tuple_expr :: [[CoreExpr]] -> CoreExpr -- Each sub-list is short enough to fit in a tuple - mk_tuple_expr [exprs] = mkCoreTup exprs - mk_tuple_expr exprs_s = mk_tuple_expr (chunkify (map mkCoreTup exprs_s)) - + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) chunkify :: [a] -> [[a]] -- The sub-lists of the result all have length <= mAX_TUPLE_SIZE @@ -685,6 +694,64 @@ mkTupleSelector vars the_var scrut_var scrut the_var `elem` gp ] \end{code} +A generalization of @mkTupleSelector@, allowing the body +of the case to be an arbitrary expression. + +If the tuple is big, it is nested: + + mkTupleCase uniqs [a,b,c,d] body v e + = case e of v { (p,q) -> + case p of p { (a,b) -> + case q of q { (c,d) -> + body }}} + +To avoid shadowing, we use uniqs to invent new variables p,q. + +ToDo: eliminate cases where none of the variables are needed. + +\begin{code} +mkTupleCase + :: UniqSupply -- for inventing names of intermediate variables + -> [Id] -- the tuple args + -> CoreExpr -- body of the case + -> Id -- a variable of the same type as the scrutinee + -> CoreExpr -- scrutinee + -> CoreExpr + +mkTupleCase uniqs vars body scrut_var scrut + = mk_tuple_case uniqs (chunkify vars) body + where + mk_tuple_case us [vars] body + = mkSmallTupleCase vars body scrut_var scrut + 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' + 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') +\end{code} + +The same, but with a tuple small enough not to need nesting. + +\begin{code} +mkSmallTupleCase + :: [Id] -- the tuple args + -> CoreExpr -- body of the case + -> Id -- a variable of the same type as the scrutinee + -> CoreExpr -- scrutinee + -> CoreExpr + +mkSmallTupleCase [var] body _scrut_var scrut + = bindNonRec var scrut body +mkSmallTupleCase vars body scrut_var scrut + = Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, body)] +\end{code} %************************************************************************ %* * -- 1.7.10.4