X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=166bfc244c54ec31ab5f0fa9fd7d444cf773c04d;hp=e5e1fd9472e23ef9e5cc452448dc095f109461b1;hb=7fc01c4671980ea3c66d549c0ece4d82fd3f5ade;hpb=6febb616f1ff46942434e9df39c6e4977b07cc6f diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index e5e1fd9..166bfc2 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -15,8 +15,6 @@ Desugaring list comprehensions and array comprehensions module DsListComp ( dsListComp, dsPArrComp ) where --- XXX This define is a bit of a hack, and should be done more nicely -#define FAST_STRING_NOT_NEEDED 1 #include "HsVersions.h" import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) @@ -24,22 +22,21 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) import HsSyn import TcHsSyn import CoreSyn +import MkCore import DsMonad -- the monadery used in the desugarer import DsUtils import DynFlags import CoreUtils -import Var +import Id import Type import TysWiredIn import Match import PrelNames -import PrelInfo import SrcLoc import Outputable - -import Control.Monad ( liftM2 ) +import FastString \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -57,7 +54,7 @@ dsListComp lquals body elt_ty = do dflags <- getDOptsDs let quals = map unLoc lquals - if not (dopt Opt_RewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags + if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags -- Either rules are switched off, or we are ignoring what there are; -- Either way foldr/build won't happen, so use the more efficient -- Wadler-style desugaring @@ -95,7 +92,7 @@ dsInnerListComp (stmts, bndrs) = do -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do +dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) = do (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders) usingExpr' <- dsLExpr usingExpr @@ -120,7 +117,7 @@ dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do +dsGroupStmt (GroupStmt stmts binderMap by using) = do let (fromBinders, toBinders) = unzip binderMap fromBindersTypes = map idType fromBinders @@ -129,23 +126,19 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do toBindersTupleType = mkBigCoreTupTy toBindersTypes -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr, fromBindersTupleType) <- dsInnerListComp (stmts, fromBinders) + (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments - (usingExpr', usingArgs) <- - case groupByClause of - GroupByNothing usingExpr -> liftM2 (,) (dsLExpr usingExpr) (return [expr]) - GroupBySomething usingExpr byExpr -> do - usingExpr' <- dsLExpr (either id noLoc usingExpr) - - byExpr' <- dsLExpr byExpr - - us <- newUniqueSupply - [fromBindersTuple] <- newSysLocalsDs [fromBindersTupleType] - let byExprWrapper = mkTupleCase us fromBinders byExpr' fromBindersTuple (Var fromBindersTuple) - - return (usingExpr', [Lam fromBindersTuple byExprWrapper, expr]) + usingExpr' <- dsLExpr (either id noLoc using) + usingArgs <- case by of + Nothing -> return [expr] + Just by_e -> do { by_e' <- dsLExpr by_e + ; us <- newUniqueSupply + ; [from_tup_id] <- newSysLocalsDs [from_tup_ty] + ; let by_wrap = mkTupleCase us fromBinders by_e' + from_tup_id (Var from_tup_id) + ; return [Lam from_tup_id by_wrap, expr] } -- Create an unzip function for the appropriate arity and element types and find "map" (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes @@ -153,12 +146,12 @@ dsGroupStmt (GroupStmt (stmts, binderMap) groupByClause) = do -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list - inner_list_expr = mkApps usingExpr' ((Type fromBindersTupleType) : usingArgs) + inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs) -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and -- the "b" to be a tuple of "to" lists! unzipped_inner_list_expr = mkApps (Var map_id) - [Type (mkListTy fromBindersTupleType), Type toBindersTupleType, Var unzip_fn, inner_list_expr] + [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr] -- Then finally we bind the unzip function around that expression bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr @@ -270,11 +263,11 @@ deListComp (LetStmt binds : quals) body list = do core_rest <- deListComp quals body list dsLocalBinds binds core_rest -deListComp (stmt@(TransformStmt _ _ _) : quals) body list = do +deListComp (stmt@(TransformStmt {}) : quals) body list = do (inner_list_expr, pat) <- dsTransformStmt stmt deBindComp pat inner_list_expr quals body list -deListComp (stmt@(GroupStmt _ _) : quals) body list = do +deListComp (stmt@(GroupStmt {}) : quals) body list = do (inner_list_expr, pat) <- dsGroupStmt stmt deBindComp pat inner_list_expr quals body list @@ -362,12 +355,12 @@ dfListComp c_id n_id (LetStmt binds : quals) body = do core_rest <- dfListComp c_id n_id quals body dsLocalBinds binds core_rest -dfListComp c_id n_id (stmt@(TransformStmt _ _ _) : quals) body = do +dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do (inner_list_expr, pat) <- dsTransformStmt stmt -- Anyway, we bind the newly transformed list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals body -dfListComp c_id n_id (stmt@(GroupStmt _ _) : quals) body = do +dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do (inner_list_expr, pat) <- dsGroupStmt stmt -- Anyway, we bind the newly grouped list via the generic binding function dfBindComp c_id n_id (pat, inner_list_expr) quals body @@ -511,10 +504,32 @@ dsPArrComp :: [Stmt Id] -> DsM CoreExpr dsPArrComp [ParStmt qss] body _ = -- parallel comprehension dePArrParComp qss body + +-- Special case for simple generators: +-- +-- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e +-- +-- if matching again p cannot fail, or else +-- +-- <<[:e' | p <- e, qs:]>> = +-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) +-- +dsPArrComp (BindStmt p e _ _ : qs) body _ = do + filterP <- dsLookupGlobalId filterPName + ce <- dsLExpr e + let ety'ce = parrElemType ce + false = Var falseDataConId + true = Var trueDataConId + v <- newSysLocalDs ety'ce + pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false + let gen | isIrrefutableHsPat p = ce + | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] + dePArrComp qs body p gen + dsPArrComp qs body _ = do -- no ParStmt in `qs' sglP <- dsLookupGlobalId singletonPName let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] - dePArrComp qs body (mkLHsPatTup []) unitArray + dePArrComp qs body (noLoc $ WildPat unitTy) unitArray @@ -582,15 +597,15 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do -- dePArrComp (LetStmt ds : qs) body pa cea = do mapP <- dsLookupGlobalId mapPName - let xs = map unLoc (collectLocalBinders ds) + let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea clet <- dsLocalBinds ds (mkCoreTup (map Var xs)) let'v <- newSysLocalDs (exprType clet) - let projBody = mkDsLet (NonRec let'v clet) $ + let projBody = mkCoreLet (NonRec let'v clet) $ mkCoreTup [Var v, Var let'v] errTy = exprType projBody - errMsg = "DsListComp.dePArrComp: internal error!" + errMsg = ptext (sLit "DsListComp.dePArrComp: internal error!") cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] @@ -620,7 +635,7 @@ dePArrParComp qss body = do -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = do -- first statement - let res_expr = mkLHsVarTup xs + let res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs) res_expr undefined parStmts qss (mkLHsVarPatTup xs) cqs --- @@ -629,7 +644,7 @@ dePArrParComp qss body = do zipP <- dsLookupGlobalId zipPName let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea - res_expr = mkLHsVarTup xs + res_expr = mkLHsVarTuple xs cqs <- dsPArrComp (map unLoc qs) res_expr undefined let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] @@ -652,7 +667,7 @@ mkLambda :: Type -- type of the argument -> DsM (CoreExpr, Type) mkLambda ty p ce = do v <- newSysLocalDs ty - let errMsg = do "DsListComp.deLambda: internal error!" + let errMsg = ptext (sLit "DsListComp.deLambda: internal error!") ce'ty = exprType ce cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr