diff options
author | Roman Leshchinskiy <rl@cse.unsw.edu.au> | 2009-03-07 13:40:49 +0000 |
---|---|---|
committer | Roman Leshchinskiy <rl@cse.unsw.edu.au> | 2009-03-07 13:40:49 +0000 |
commit | 7a4a8360e8b7119485d10d073a984e617d6a0422 (patch) | |
tree | 907c523cf74c5968fd1eae87bb2ec60541a63d40 /compiler/deSugar/DsListComp.lhs | |
parent | f20fe8deeee0353f8cdb27ca8031dd38b4b44ed1 (diff) | |
download | haskell-7a4a8360e8b7119485d10d073a984e617d6a0422.tar.gz |
Special-case desugaring of simple parallel array comprehensions
Diffstat (limited to 'compiler/deSugar/DsListComp.lhs')
-rw-r--r-- | compiler/deSugar/DsListComp.lhs | 24 |
1 files changed, 23 insertions, 1 deletions
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index bdbe65ee7e..9508e510de 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -510,10 +510,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 |