X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=a98aef6b3a2c7584613dbf49d7f43866a2305187;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=74091017c6cc95df841ffcdd263ccc34b262ebc2;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 7409101..a98aef6 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -21,7 +21,6 @@ import DsMonad -- the monadery used in the desugarer import DsUtils import DynFlags -import StaticFlags import CoreUtils import Var import Type @@ -50,7 +49,7 @@ dsListComp lquals body elt_ty let quals = map unLoc lquals in - if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags + if not (dopt Opt_RewriteRules 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 @@ -352,7 +351,9 @@ dsPArrComp :: [Stmt Id] -> LHsExpr Id -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr -dsPArrComp qs body _ = +dsPArrComp [ParStmt qss] body _ = -- parallel comprehension + dePArrParComp qss body +dsPArrComp qs body _ = -- no ParStmt in `qs' dsLookupGlobalId replicatePName `thenDs` \repP -> let unitArray = mkApps (Var repP) [Type unitTy, mkIntExpr 1, @@ -360,6 +361,8 @@ dsPArrComp qs body _ = in dePArrComp qs body (mkTuplePat []) unitArray + + -- the work horse -- dePArrComp :: [Stmt Id] @@ -388,30 +391,34 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea]) -- -- <<[:e' | p <- e, qs:]>> pa ea = --- let ef = filterP (\x -> case x of {p -> True; _ -> False}) e +-- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e -- in --- <<[:e' | qs:]>> (pa, p) (crossP ea ef) +-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- dePArrComp (BindStmt p e _ _ : qs) body pa cea = - dsLookupGlobalId filterPName `thenDs` \filterP -> - dsLookupGlobalId crossPName `thenDs` \crossP -> - dsLExpr e `thenDs` \ce -> - let ty'cea = parrElemType cea - ty'ce = parrElemType ce - false = Var falseDataConId - true = Var trueDataConId + dsLookupGlobalId filterPName `thenDs` \filterP -> + dsLookupGlobalId crossMapPName `thenDs` \crossMapP -> + dsLExpr e `thenDs` \ce -> + let ety'cea = parrElemType cea + ety'ce = parrElemType ce + false = Var falseDataConId + true = Var trueDataConId in - newSysLocalDs ty'ce `thenDs` \v -> + newSysLocalDs ety'ce `thenDs` \v -> matchSimply (Var v) (StmtCtxt PArrComp) p true false `thenDs` \pred -> - let cef = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce] - ty'cef = ty'ce -- filterP preserves the type - pa' = mkTuplePat [pa, p] + let cef = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] + in + mkLambda ety'cea pa cef `thenDs` \(clam, + _ ) -> + let ety'cef = ety'ce -- filter doesn't change the element type + pa' = mkTuplePat [pa, p] in - dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef]) + dePArrComp qs body pa' (mkApps (Var crossMapP) + [Type ety'cea, Type ety'cef, cea, clam]) -- -- <<[:e' | let ds, qs:]>> pa ea = -- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) --- (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea) +-- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea) -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- @@ -433,27 +440,29 @@ dePArrComp (LetStmt ds : qs) body pa cea = let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)] proj = mkLams [v] ccase in - dePArrComp qs body pa' (mkApps (Var mapP) [Type ty'cea, proj, cea]) + dePArrComp qs body pa' (mkApps (Var mapP) + [Type ty'cea, Type errTy, proj, cea]) -- +-- The parser guarantees that parallel comprehensions can only appear as +-- singeltons qualifier lists, which we already special case in the caller. +-- So, encountering one here is a bug. +-- +dePArrComp (ParStmt _ : _) _ _ _ = + panic "DsListComp.dePArrComp: malformed comprehension AST" + -- <<[:e' | qs | qss:]>> pa ea = -- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) -- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrComp (ParStmt qss : qs) body pa cea = - dsLookupGlobalId crossPName `thenDs` \crossP -> +dePArrParComp qss body = deParStmt qss `thenDs` \(pQss, ceQss) -> - let ty'cea = parrElemType cea - ty'ceQss = parrElemType ceQss - pa' = mkTuplePat [pa, pQss] - in - dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss, - cea, ceQss]) + dePArrComp [] body pQss ceQss where deParStmt [] = - -- empty parallel statement lists have not source representation + -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = -- first statement let res_expr = mkExplicitTuple (map nlHsVar xs) @@ -476,19 +485,28 @@ dePArrComp (ParStmt qss : qs) body pa cea = -- generate Core corresponding to `\p -> e' -- -deLambda :: Type -- type of the argument - -> LPat Id -- argument pattern - -> LHsExpr Id -- body - -> DsM (CoreExpr, Type) -deLambda ty p e = - newSysLocalDs ty `thenDs` \v -> +deLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> LHsExpr Id -- body + -> DsM (CoreExpr, Type) +deLambda ty p e = dsLExpr e `thenDs` \ce -> - let errTy = exprType ce - errMsg = "DsListComp.deLambda: internal error!" + mkLambda ty p ce + +-- generate Core for a lambda pattern match, where the body is already in Core +-- +mkLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> CoreExpr -- desugared body + -> DsM (CoreExpr, Type) +mkLambda ty p ce = + newSysLocalDs ty `thenDs` \v -> + let errMsg = "DsListComp.deLambda: internal error!" + ce'ty = exprType ce in - mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> + mkErrorAppDs pAT_ERROR_ID ce'ty errMsg `thenDs` \cerr -> matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res -> - returnDs (mkLams [v] res, errTy) + returnDs (mkLams [v] res, ce'ty) -- obtain the element type of the parallel array produced by the given Core -- expression