X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=cd22b8ff8c927f999148ddcd8c904c5db7c8ad68;hp=e5e1fd9472e23ef9e5cc452448dc095f109461b1;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=6febb616f1ff46942434e9df39c6e4977b07cc6f

diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index e5e1fd9..cd22b8f 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,12 +92,12 @@ 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
-    (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
-    usingExpr' <- dsLExpr usingExpr
+dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr)
+ = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
+      ; usingExpr' <- dsLExpr usingExpr
     
-    using_args <- 
-        case maybeByExpr of
+      ; using_args <-
+          case maybeByExpr of
             Nothing -> return [expr]
             Just byExpr -> do
                 byExpr' <- dsLExpr byExpr
@@ -111,16 +108,15 @@ dsTransformStmt (TransformStmt (stmts, binders) usingExpr maybeByExpr) = do
                 
                 return [Lam tuple_binder byExprWrapper, expr]
 
-    let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
-    
-    let pat = mkBigLHsVarPatTup binders
-    return (inner_list_expr, pat)
+      ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
+            pat = mkBigLHsVarPatTup binders
+      ; return (inner_list_expr, pat) }
     
 -- This function factors out commonality between the desugaring strategies for GroupStmt.
 -- 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 +125,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 +145,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 +262,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 +354,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 +503,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 <- dsLookupDPHId 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
+    sglP <- dsLookupDPHId singletonPName
     let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
-    dePArrComp qs body (mkLHsPatTup []) unitArray
+    dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
 
 
 
@@ -529,7 +543,7 @@ dePArrComp :: [Stmt Id]
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --
 dePArrComp [] e' pa cea = do
-    mapP <- dsLookupGlobalId mapPName
+    mapP <- dsLookupDPHId mapPName
     let ty = parrElemType cea
     (clam, ty'e') <- deLambda ty pa e'
     return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
@@ -537,7 +551,7 @@ dePArrComp [] e' pa cea = do
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
 dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
-    filterP <- dsLookupGlobalId filterPName
+    filterP <- dsLookupDPHId filterPName
     let ty = parrElemType cea
     (clam,_) <- deLambda ty pa b
     dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
@@ -556,8 +570,8 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
 dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
-    filterP <- dsLookupGlobalId filterPName
-    crossMapP <- dsLookupGlobalId crossMapPName
+    filterP <- dsLookupDPHId filterPName
+    crossMapP <- dsLookupDPHId crossMapPName
     ce <- dsLExpr e
     let ety'cea = parrElemType cea
         ety'ce  = parrElemType ce
@@ -581,16 +595,16 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
 --    {x_1, ..., x_n} = DV (ds)		-- Defined Variables
 --
 dePArrComp (LetStmt ds : qs) body pa cea = do
-    mapP <- dsLookupGlobalId mapPName
-    let xs     = map unLoc (collectLocalBinders ds)
+    mapP <- dsLookupDPHId mapPName
+    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,16 +634,16 @@ 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
     ---
     parStmts []             pa cea = return (pa, cea)
     parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
-      zipP <- dsLookupGlobalId zipPName
+      zipP <- dsLookupDPHId 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 +666,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