X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=e7c1f20df8494caa90a79f68140dc7fd9157669d;hp=35ff21fa5695c7b55b709e061ee3cc9572714582;hb=fb6d198f498d4e325a540f28aaa6e1d1530839c3;hpb=dcc8f0a89f1ff43684b6e0f34b9ded3ec6b96e1c diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 35ff21f..e7c1f20 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -6,7 +6,7 @@ Desugaring list comprehensions and array comprehensions \begin{code} -{-# OPTIONS -w #-} +{-# OPTIONS -fno-warn-incomplete-patterns #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See @@ -19,26 +19,25 @@ module DsListComp ( dsListComp, dsPArrComp ) where import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) -import BasicTypes 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 TysPrim import TysWiredIn import Match import PrelNames import PrelInfo import SrcLoc -import Panic import Outputable +import FastString import Control.Monad ( liftM2 ) \end{code} @@ -58,24 +57,16 @@ 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 || isParallelComp quals -- Foldr-style desugaring can't handle parallel list comprehensions then deListComp quals body (mkNilExpr elt_ty) - else do -- Foldr/build should be enabled, so desugar - -- into foldrs and builds - [n_tyvar] <- newTyVarsDs [alphaTyVar] - - let n_ty = mkTyVarTy n_tyvar - c_ty = mkFunTys [elt_ty, n_ty] n_ty - [c, n] <- newSysLocalsDs [c_ty, n_ty] - - result <- dfListComp c n quals body - build_id <- dsLookupGlobalId buildName - return (Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] result) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body) + -- Foldr/build should be enabled, so desugar + -- into foldrs and builds where -- We must test for ParStmt anywhere, not just at the head, because an extension @@ -294,6 +285,12 @@ deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' abov \begin{code} +deBindComp :: OutPat Id + -> CoreExpr + -> [Stmt Id] + -> LHsExpr Id + -> CoreExpr + -> DsM (Expr Id) deBindComp pat core_list1 quals body core_list2 = do let u3_ty@u1_ty = exprType core_list1 -- two names, same thing @@ -403,13 +400,7 @@ dfBindComp c_id n_id (pat, core_list1) quals body = do pat core_rest (Var b) -- now build the outermost foldr, and return - foldr_id <- dsLookupGlobalId foldrName - return (Var foldr_id `App` Type x_ty - `App` Type b_ty - `App` mkLams [x, b] core_expr - `App` Var n_id - `App` core_list1) - + mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1 \end{code} %************************************************************************ @@ -475,7 +466,6 @@ mkUnzipBind elt_tys = do unzip_fn <- newSysLocalDs unzip_fn_ty - foldr_id <- dsLookupGlobalId foldrName [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) @@ -487,10 +477,8 @@ mkUnzipBind elt_tys = do folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) folder_body = mkLams [ax, axs] folder_body_outer_case - unzip_body = mkApps (Var foldr_id) [Type elt_tuple_ty, Type elt_list_tuple_ty, folder_body, nil_tuple, Var ys] - unzip_body_saturated = mkLams [ys] unzip_body - - return (unzip_fn, unzip_body_saturated) + unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + return (unzip_fn, mkLams [ys] unzip_body) where elt_tuple_ty = mkBigCoreTupTy elt_tys elt_tuple_list_ty = mkListTy elt_tuple_ty @@ -523,10 +511,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 @@ -599,10 +609,10 @@ dePArrComp (LetStmt ds : qs) body pa cea = do 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)] @@ -623,6 +633,7 @@ dePArrComp (ParStmt _ : _) _ _ _ = -- where -- {x_1, ..., x_n} = DV (qs) -- +dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr dePArrParComp qss body = do (pQss, ceQss) <- deParStmt qss dePArrComp [] body pQss ceQss @@ -631,7 +642,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 --- @@ -640,7 +651,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] @@ -663,7 +674,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