From 663a01b260eb7a2e14cc943524931f4147cd523a Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 2 Jun 2003 13:28:09 +0000 Subject: [PATCH] [project @ 2003-06-02 13:28:08 by simonpj] ------------------------------------- Fix the big-tuple-from-desugaring problem ------------------------------------- The desugarer generates a tuple from - mutually recursive bindings - pattern bindings If either bind a lot of variables, GHC can generate a big tuple that isn't in the library, with subsequent disaster. This commit fixes the problem, by using nested tuples. It does *not* fix the problem with big tuples written by the user. And there's still a potential desugarer problem with parallel list comprehensions that bind a lot of variables (and parallel array comprehensions) -- but I expect they are much much rarer. The fix isn't fully tested yet -- I'll try to do that today. --- ghc/compiler/deSugar/DsListComp.lhs | 11 ++-- ghc/compiler/deSugar/DsUtils.lhs | 113 ++++++++++++++++++++++++++--------- 2 files changed, 93 insertions(+), 31 deletions(-) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 9824aa3..7af59eb 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -229,7 +229,9 @@ mkZipBind elt_tys mapDs newSysLocalDs list_tys `thenDs` \ as's -> newSysLocalDs zip_fn_ty `thenDs` \ zip_fn -> let - inner_rhs = mkConsExpr ret_elt_ty (mkTupleExpr as') (mkVarApps (Var zip_fn) as's) + inner_rhs = mkConsExpr ret_elt_ty + (mkCoreTup (map Var as')) + (mkVarApps (Var zip_fn) as's) zip_body = foldr mk_case inner_rhs (zip3 ass as' as's) in returnDs (zip_fn, mkLams ass zip_body) @@ -348,7 +350,7 @@ dsPArrComp qs _ = dsLookupGlobalId replicatePName `thenDs` \repP -> let unitArray = mkApps (Var repP) [Type unitTy, mkIntExpr 1, - mkTupleExpr []] + mkCoreTup []] in dePArrComp qs (TuplePat [] Boxed) unitArray @@ -412,9 +414,10 @@ dePArrComp (LetStmt ds : qs) pa cea = ty'cea = parrElemType cea in newSysLocalDs ty'cea `thenDs` \v -> - dsLet ds (mkTupleExpr xs) `thenDs` \clet -> + dsLet ds (mkCoreTup (map Var xs)) `thenDs` \clet -> newSysLocalDs (exprType clet) `thenDs` \let'v -> - let projBody = mkDsLet (NonRec let'v clet) $ mkTupleExpr [v, let'v] + let projBody = mkDsLet (NonRec let'v clet) $ + mkCoreTup [Var v, Var let'v] errTy = exprType projBody errMsg = "DsListComp.dePArrComp: internal error!" in diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 3411ebf..31f11d6 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -36,12 +36,12 @@ import {-# SOURCE #-} Match ( matchSimply ) import HsSyn import TcHsSyn ( TypecheckedPat, hsPatType ) import CoreSyn - +import Constants ( mAX_TUPLE_SIZE ) import DsMonad import CoreUtils ( exprType, mkIfThenElse, mkCoerce ) import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody ) -import Id ( idType, Id, mkWildId ) +import Id ( idType, Id, mkWildId, mkTemplateLocals ) import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, dataConSourceArity ) @@ -49,7 +49,7 @@ import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp ) import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy ) import TysPrim ( intPrimTy ) import TysWiredIn ( nilDataCon, consDataCon, - tupleCon, + tupleCon, mkTupleTy, unitDataConId, unitTy, charTy, charDataCon, intTy, intDataCon, smallIntegerDataCon, @@ -63,7 +63,7 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name, lengthPName, indexPName ) import Outputable import UnicodeUtil ( intsToUtf8, stringToUtf8 ) -import Util ( isSingleton, notNull ) +import Util ( isSingleton, notNull, zipEqual ) import FastString \end{code} @@ -567,27 +567,46 @@ mkSelectorBinds pat val_expr \end{code} -@mkTupleExpr@ builds a tuple; the inverse to @mkTupleSelector@. If it -has only one element, it is the identity function. +%************************************************************************ +%* * + 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 + = mk_tuple_expr (chunkify (map Var ids)) + 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)) + + +chunkify :: [a] -> [[a]] +-- The sub-lists of the result all have length <= mAX_TUPLE_SIZE +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + -- n_chunks_m1 = numbe of chunks - 1 + n_xs = length xs + n_chunks_m1 = n_xs `div` mAX_TUPLE_SIZE + chunk_size = n_xs `div` n_chunks_m1 -{- This code has been replaced by mkCoreTup below -mkTupleExpr [] = Var unitDataConId -mkTupleExpr [id] = Var id -mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) - (map (Type . idType) ids ++ [ Var i | i <-ids]) --} - -mkTupleExpr ids = mkCoreTup(map Var ids) - -mkCoreTup :: [CoreExpr] -> CoreExpr -mkCoreTup [] = Var unitDataConId -mkCoreTup [c] = c -mkCoreTup cs = mkConApp (tupleCon Boxed (length cs)) - (map (Type . exprType) cs ++ cs) - + split [] = [] + split xs = take chunk_size xs : split (drop chunk_size xs) \end{code} @@ -600,6 +619,19 @@ are in scope. If there is just one id in the ``tuple'', then the selector is just the identity. +If it's big, it does nesting + mkTupleSelector [a,b,c,d] b v e + = case e of v { + (p,q) -> case p of p { + (a,b) -> b }} +We use 'tpl' vars for the p,q, since shadowing does not matter. + +In fact, it's more convenient to generate it innermost first, getting + + case (case e of v + (p,q) -> p) of p + (a,b) -> b + \begin{code} mkTupleSelector :: [Id] -- The tuple args -> Id -- The selected one @@ -607,13 +639,17 @@ mkTupleSelector :: [Id] -- The tuple args -> CoreExpr -- Scrutinee -> CoreExpr -mkTupleSelector [var] should_be_the_same_var scrut_var scrut - = ASSERT(var == should_be_the_same_var) - scrut - mkTupleSelector vars the_var scrut_var scrut - = ASSERT( notNull vars ) - Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] + = mk_tup_sel (chunkify vars) the_var + where + mk_tup_sel [vars] the_var = mkCoreSel vars the_var scrut_var scrut + mk_tup_sel vars_s the_var = mkCoreSel group the_var tpl_v $ + mk_tup_sel (chunkify tpl_vs) tpl_v + where + tpl_tys = [mkTupleTy Boxed (length gp) (map idType gp) | gp <- vars_s] + tpl_vs = mkTemplateLocals tpl_tys + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + the_var `elem` gp ] \end{code} @@ -635,7 +671,30 @@ mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl] mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + +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 + -> 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 + = ASSERT(var == should_be_the_same_var) + scrut + +mkCoreSel vars the_var scrut_var scrut + = ASSERT( notNull vars ) + Case scrut scrut_var + [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)] \end{code} -- 1.7.10.4