remove empty dir

[ghc-hetmet.git] / ghc / compiler / deSugar / DsListComp.lhs

diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 99b8980..6bb41a9 100644 (file)
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -8,36 +8,31 @@ module DsListComp ( dsListComp, dsPArrComp ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
+import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )

 
 import BasicTypes      ( Boxity(..) )
 
 import BasicTypes      ( Boxity(..) )

-import DataCon         ( dataConId )
-import TyCon           ( tyConName )
-import HsSyn           ( OutPat(..), HsExpr(..), Stmt(..),
-                         HsMatchContext(..), HsDoContext(..),
-                         collectHsOutBinders )
-import TcHsSyn         ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
-                         outPatType )
+import HsSyn
+import TcHsSyn         ( hsPatType, mkVanillaTuplePat )

 import CoreSyn
 
 import DsMonad         -- the monadery used in the desugarer
 import DsUtils
 
 import CoreSyn
 
 import DsMonad         -- the monadery used in the desugarer
 import DsUtils
 

-import CmdLineOpts     ( opt_FoldrBuildOn )
+import DynFlags                ( DynFlag(..), dopt )
+import StaticFlags     ( opt_RulesOff )

 import CoreUtils       ( exprType, mkIfThenElse )
 import Id              ( idType )
 import Var              ( Id )
 import Type            ( mkTyVarTy, mkFunTys, mkFunTy, Type,
                          splitTyConApp_maybe )
 import TysPrim         ( alphaTyVar )
 import CoreUtils       ( exprType, mkIfThenElse )
 import Id              ( idType )
 import Var              ( Id )
 import Type            ( mkTyVarTy, mkFunTys, mkFunTy, Type,
                          splitTyConApp_maybe )
 import TysPrim         ( alphaTyVar )

-import TysWiredIn      ( nilDataCon, consDataCon, unitDataConId, unitTy,
-                         mkListTy, mkTupleTy, intDataCon )
+import TysWiredIn      ( nilDataCon, consDataCon, trueDataConId, falseDataConId, 
+                         unitDataConId, unitTy, mkListTy, parrTyCon )

 import Match           ( matchSimply )
 import Match           ( matchSimply )

-import PrelNames       ( trueDataConName, falseDataConName, foldrName,
-                         buildName, replicatePName, mapPName, filterPName,
-                         zipPName, crossPName, parrTyConName ) 
+import PrelNames       ( foldrName, buildName, replicatePName, mapPName, 
+                         filterPName, zipPName, crossPName ) 

 import PrelInfo                ( pAT_ERROR_ID )
 import PrelInfo                ( pAT_ERROR_ID )

-import SrcLoc          ( noSrcLoc )
+import SrcLoc          ( noLoc, unLoc )

 import Panic           ( panic )
 \end{code}
 
 import Panic           ( panic )
 \end{code}
 

@@ -48,29 +43,39 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject).
 There will be at least one ``qualifier'' in the input.
 
 \begin{code}
 There will be at least one ``qualifier'' in the input.
 
 \begin{code}

-dsListComp :: [TypecheckedStmt] 
+dsListComp :: [LStmt Id] 
+          -> LHsExpr Id

           -> Type              -- Type of list elements
           -> DsM CoreExpr
           -> Type              -- Type of list elements
           -> DsM CoreExpr

-
-dsListComp quals elt_ty
-  |  not opt_FoldrBuildOn               -- Be boring
-  || isParallelComp quals
-  = deListComp quals (mkNilExpr elt_ty)
-
-  | otherwise                           -- foldr/build lives!
-  = newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->
+dsListComp lquals body elt_ty
+  = getDOptsDs  `thenDs` \dflags ->
+    let
+       quals = map unLoc lquals
+    in
+    if opt_RulesOff || 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                -- Foldr/build should be enabled, so desugar 
+               -- into foldrs and builds
+    newTyVarsDs [alphaTyVar]    `thenDs` \ [n_tyvar] ->

     let
        n_ty = mkTyVarTy n_tyvar
         c_ty = mkFunTys [elt_ty, n_ty] n_ty
     in
     newSysLocalsDs [c_ty,n_ty]         `thenDs` \ [c, n] ->
     let
        n_ty = mkTyVarTy n_tyvar
         c_ty = mkFunTys [elt_ty, n_ty] n_ty
     in
     newSysLocalsDs [c_ty,n_ty]         `thenDs` \ [c, n] ->

-    dfListComp c n quals               `thenDs` \ result ->
-    dsLookupGlobalValue buildName      `thenDs` \ build_id ->
+    dfListComp c n quals body          `thenDs` \ result ->
+    dsLookupGlobalId buildName `thenDs` \ build_id ->

     returnDs (Var build_id `App` Type elt_ty 
                           `App` mkLams [n_tyvar, c, n] result)
 
     returnDs (Var build_id `App` Type elt_ty 
                           `App` mkLams [n_tyvar, c, n] result)
 

-  where isParallelComp (ParStmtOut bndrstmtss : _) = True
-       isParallelComp _                           = False
+  where isParallelComp (ParStmt bndrstmtss : _) = True
+       isParallelComp _                        = False

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -127,7 +132,7 @@ comprehensions.  The translation goes roughly as follows:
 where (x1, .., xn) are the variables bound in p1, v1, p2
       (y1, .., ym) are the variables bound in q1, v2, q2
 
 where (x1, .., xn) are the variables bound in p1, v1, p2
       (y1, .., ym) are the variables bound in q1, v2, q2
 

-In the translation below, the ParStmtOut branch translates each parallel branch
+In the translation below, the ParStmt branch translates each parallel branch

 into a sub-comprehension, and desugars each independently.  The resulting lists
 are fed to a zip function, we create a binding for all the variables bound in all
 the comprehensions, and then we hand things off the the desugarer for bindings.
 into a sub-comprehension, and desugars each independently.  The resulting lists
 are fed to a zip function, we create a binding for all the variables bound in all
 the comprehensions, and then we hand things off the the desugarer for bindings.

@@ -138,59 +143,61 @@ The introduced tuples are Boxed, but only because I couldn't get it to work
 with the Unboxed variety.
 
 \begin{code}
 with the Unboxed variety.
 
 \begin{code}

+deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr

 
 

-deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
-
-deListComp (ParStmtOut bndrstmtss : quals) list
-  = mapDs do_list_comp bndrstmtss      `thenDs` \ exps ->
+deListComp (ParStmt stmtss_w_bndrs : quals) body list
+  = mappM do_list_comp stmtss_w_bndrs  `thenDs` \ exps ->

     mkZipBind qual_tys                 `thenDs` \ (zip_fn, zip_rhs) ->
 
        -- Deal with [e | pat <- zip l1 .. ln] in example above
     deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) 
     mkZipBind qual_tys                 `thenDs` \ (zip_fn, zip_rhs) ->
 
        -- Deal with [e | pat <- zip l1 .. ln] in example above
     deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) 

-                  quals list
+                  quals body list
+
+  where 
+       bndrs_s = map snd stmtss_w_bndrs

 
 

-  where -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
-       pat            = TuplePat pats Boxed
-       pats           = map (\(bs,_) -> mk_hs_tuple_pat bs) bndrstmtss
+       -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+       pat      = mkTuplePat pats
+       pats     = map mk_hs_tuple_pat bndrs_s

 
        -- Types of (x1,..,xn), (y1,..,yn) etc
 
        -- Types of (x1,..,xn), (y1,..,yn) etc

-       qual_tys = [ mk_bndrs_tys bndrs | (bndrs,_) <- bndrstmtss ]
+       qual_tys = map mk_bndrs_tys bndrs_s

 
 

-       do_list_comp (bndrs, stmts)
-         = dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc])
+       do_list_comp (stmts, bndrs)
+         = dsListComp stmts (mk_hs_tuple_expr bndrs)

                       (mk_bndrs_tys bndrs)
 
                       (mk_bndrs_tys bndrs)
 

-       mk_bndrs_tys bndrs = mk_tuple_ty (map idType bndrs)
+       mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs)

 
        -- Last: the one to return
 
        -- Last: the one to return

-deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above
-  = dsExpr expr                        `thenDs` \ core_expr ->
-    returnDs (mkConsExpr (exprType core_expr) core_expr list)
+deListComp [] body list                -- Figure 7.4, SLPJ, p 135, rule C above
+  = dsLExpr body               `thenDs` \ core_body ->
+    returnDs (mkConsExpr (exprType core_body) core_body list)

 
        -- Non-last: must be a guard
 
        -- Non-last: must be a guard

-deListComp (ExprStmt guard ty locn : quals) list       -- rule B above
-  = dsExpr guard                       `thenDs` \ core_guard ->
-    deListComp quals list      `thenDs` \ core_rest ->
+deListComp (ExprStmt guard _ _ : quals) body list      -- rule B above
+  = dsLExpr guard                      `thenDs` \ core_guard ->
+    deListComp quals body list `thenDs` \ core_rest ->

     returnDs (mkIfThenElse core_guard core_rest list)
 
 -- [e | let B, qs] = let B in [e | qs]
     returnDs (mkIfThenElse core_guard core_rest list)
 
 -- [e | let B, qs] = let B in [e | qs]

-deListComp (LetStmt binds : quals) list
-  = deListComp quals list      `thenDs` \ core_rest ->
-    dsLet binds core_rest
+deListComp (LetStmt binds : quals) body list
+  = deListComp quals body list `thenDs` \ core_rest ->
+    dsLocalBinds binds core_rest

 
 

-deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above
-  = dsExpr list1                   `thenDs` \ core_list1 ->
-    deBindComp pat core_list1 quals core_list2
+deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
+  = dsLExpr list1                  `thenDs` \ core_list1 ->
+    deBindComp pat core_list1 quals body core_list2

 \end{code}
 
 
 \begin{code}
 \end{code}
 
 
 \begin{code}

-deBindComp pat core_list1 quals core_list2
+deBindComp pat core_list1 quals body core_list2

   = let
        u3_ty@u1_ty = exprType core_list1       -- two names, same thing
 
        -- u1_ty is a [alpha] type, and u2_ty = alpha
   = let
        u3_ty@u1_ty = exprType core_list1       -- two names, same thing
 
        -- u1_ty is a [alpha] type, and u2_ty = alpha

-       u2_ty = outPatType pat
+       u2_ty = hsPatType pat

 
        res_ty = exprType core_list2
        h_ty   = u1_ty `mkFunTy` res_ty
 
        res_ty = exprType core_list2
        h_ty   = u1_ty `mkFunTy` res_ty

@@ -202,13 +209,15 @@ deBindComp pat core_list1 quals core_list2
        core_fail   = App (Var h) (Var u3)
        letrec_body = App (Var h) core_list1
     in
        core_fail   = App (Var h) (Var u3)
        letrec_body = App (Var h) core_list1
     in

-    deListComp quals core_fail                 `thenDs` \ rest_expr ->
-    matchSimply (Var u2) (DoCtxt ListComp) pat
+    deListComp quals body core_fail            `thenDs` \ rest_expr ->
+    matchSimply (Var u2) (StmtCtxt ListComp) pat

                rest_expr core_fail             `thenDs` \ core_match ->
     let
        rhs = Lam u1 $
                rest_expr core_fail             `thenDs` \ core_match ->
     let
        rhs = Lam u1 $

-             Case (Var u1) u1 [(DataAlt nilDataCon,  [],       core_list2),
-                               (DataAlt consDataCon, [u2, u3], core_match)]
+             Case (Var u1) u1 res_ty
+                  [(DataAlt nilDataCon,  [],       core_list2),
+                   (DataAlt consDataCon, [u2, u3], core_match)]
+                       -- Increasing order of tag

     in
     returnDs (Let (Rec [(h, rhs)]) letrec_body)
 \end{code}
     in
     returnDs (Let (Rec [(h, rhs)]) letrec_body)
 \end{code}

@@ -225,38 +234,36 @@ mkZipBind :: [Type] -> DsM (Id, CoreExpr)
 --                             (a2:as'2) -> (a2,a2) : zip as'1 as'2)]
 
 mkZipBind elt_tys 
 --                             (a2:as'2) -> (a2,a2) : zip as'1 as'2)]
 
 mkZipBind elt_tys 

-  = mapDs newSysLocalDs  list_tys      `thenDs` \ ass ->
-    mapDs newSysLocalDs  elt_tys       `thenDs` \ as' ->
-    mapDs newSysLocalDs  list_tys      `thenDs` \ as's ->
+  = mappM newSysLocalDs  list_tys      `thenDs` \ ass ->
+    mappM newSysLocalDs  elt_tys       `thenDs` \ as' ->
+    mappM newSysLocalDs  list_tys      `thenDs` \ as's ->

     newSysLocalDs zip_fn_ty            `thenDs` \ zip_fn ->
     let 
     newSysLocalDs zip_fn_ty            `thenDs` \ zip_fn ->
     let 

-       inner_rhs = mkConsExpr ret_elt_ty (mkTupleExpr as') (mkVarApps (Var zip_fn) as's)
+       inner_rhs = mkConsExpr ret_elt_ty 
+                       (mkCoreTup (map Var as'))
+                       (mkVarApps (Var zip_fn) as's)

        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
     in
     returnDs (zip_fn, mkLams ass zip_body)
   where
        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
     in
     returnDs (zip_fn, mkLams ass zip_body)
   where

-    list_tys   = map mkListTy elt_tys
-    ret_elt_ty = mk_tuple_ty elt_tys
-    zip_fn_ty  = mkFunTys list_tys (mkListTy ret_elt_ty)
+    list_tys    = map mkListTy elt_tys
+    ret_elt_ty  = mkCoreTupTy elt_tys
+    list_ret_ty = mkListTy ret_elt_ty
+    zip_fn_ty   = mkFunTys list_tys list_ret_ty

 
     mk_case (as, a', as') rest
 
     mk_case (as, a', as') rest

-         = Case (Var as) as [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
-                             (DataAlt consDataCon, [a', as'], rest)]
-
--- Helper function 
-mk_tuple_ty :: [Type] -> Type
-mk_tuple_ty [ty] = ty
-mk_tuple_ty tys  = mkTupleTy Boxed (length tys) tys
-
+         = Case (Var as) as list_ret_ty
+                 [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
+                  (DataAlt consDataCon, [a', as'], rest)]
+                       -- Increasing order of tag

 -- Helper functions that makes an HsTuple only for non-1-sized tuples
 -- Helper functions that makes an HsTuple only for non-1-sized tuples

-mk_hs_tuple_expr :: [Id] -> TypecheckedHsExpr
-mk_hs_tuple_expr []   = HsVar unitDataConId
-mk_hs_tuple_expr [id] = HsVar id
-mk_hs_tuple_expr ids  = ExplicitTuple [ HsVar i | i <- ids ] Boxed
-
-mk_hs_tuple_pat :: [Id] -> TypecheckedPat
-mk_hs_tuple_pat [b] = VarPat b
-mk_hs_tuple_pat bs  = TuplePat (map VarPat bs) Boxed
+mk_hs_tuple_expr :: [Id] -> LHsExpr Id
+mk_hs_tuple_expr []   = nlHsVar unitDataConId
+mk_hs_tuple_expr [id] = nlHsVar id
+mk_hs_tuple_expr ids  = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed
+
+mk_hs_tuple_pat :: [Id] -> LPat Id
+mk_hs_tuple_pat bs  = mkTuplePat (map nlVarPat bs)

 \end{code}
 
 
 \end{code}
 
 

@@ -281,31 +288,32 @@ TE[ e | p <- l , q ] c n = let
 
 \begin{code}
 dfListComp :: Id -> Id                 -- 'c' and 'n'
 
 \begin{code}
 dfListComp :: Id -> Id                 -- 'c' and 'n'

-          -> [TypecheckedStmt]         -- the rest of the qual's
+          -> [Stmt Id]         -- the rest of the qual's
+          -> LHsExpr Id

           -> DsM CoreExpr
 
        -- Last: the one to return
           -> DsM CoreExpr
 
        -- Last: the one to return

-dfListComp c_id n_id [ResultStmt expr locn]
-  = dsExpr expr                        `thenDs` \ core_expr ->
-    returnDs (mkApps (Var c_id) [core_expr, Var n_id])
+dfListComp c_id n_id [] body
+  = dsLExpr body               `thenDs` \ core_body ->
+    returnDs (mkApps (Var c_id) [core_body, Var n_id])

 
        -- Non-last: must be a guard
 
        -- Non-last: must be a guard

-dfListComp c_id n_id (ExprStmt guard ty locn  : quals)
-  = dsExpr guard                                       `thenDs` \ core_guard ->
-    dfListComp c_id n_id quals `thenDs` \ core_rest ->
+dfListComp c_id n_id (ExprStmt guard _ _  : quals) body
+  = dsLExpr guard                              `thenDs` \ core_guard ->
+    dfListComp c_id n_id quals body    `thenDs` \ core_rest ->

     returnDs (mkIfThenElse core_guard core_rest (Var n_id))
 
     returnDs (mkIfThenElse core_guard core_rest (Var n_id))
 

-dfListComp c_id n_id (LetStmt binds : quals)
+dfListComp c_id n_id (LetStmt binds : quals) body

   -- new in 1.3, local bindings
   -- new in 1.3, local bindings

-  = dfListComp c_id n_id quals `thenDs` \ core_rest ->
-    dsLet binds core_rest
+  = dfListComp c_id n_id quals body    `thenDs` \ core_rest ->
+    dsLocalBinds binds core_rest

 
 

-dfListComp c_id n_id (BindStmt pat list1 locn : quals)
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body

     -- evaluate the two lists
     -- evaluate the two lists

-  = dsExpr list1                               `thenDs` \ core_list1 ->
+  = dsLExpr list1                      `thenDs` \ core_list1 ->

 
     -- find the required type
 
     -- find the required type

-    let x_ty   = outPatType pat
+    let x_ty   = hsPatType pat

        b_ty   = idType n_id
     in
 
        b_ty   = idType n_id
     in
 

@@ -313,14 +321,14 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
     newSysLocalsDs [b_ty,x_ty]                 `thenDs` \ [b,x] ->
 
     -- build rest of the comprehesion
     newSysLocalsDs [b_ty,x_ty]                 `thenDs` \ [b,x] ->
 
     -- build rest of the comprehesion

-    dfListComp c_id b quals                    `thenDs` \ core_rest ->
+    dfListComp c_id b quals body               `thenDs` \ core_rest ->

 
     -- build the pattern match
 
     -- build the pattern match

-    matchSimply (Var x) (DoCtxt ListComp) 
+    matchSimply (Var x) (StmtCtxt ListComp)

                pat core_rest (Var b)           `thenDs` \ core_expr ->
 
     -- now build the outermost foldr, and return
                pat core_rest (Var b)           `thenDs` \ core_expr ->
 
     -- now build the outermost foldr, and return

-    dsLookupGlobalValue foldrName              `thenDs` \ foldr_id ->
+    dsLookupGlobalId foldrName         `thenDs` \ foldr_id ->

     returnDs (
       Var foldr_id `App` Type x_ty 
                   `App` Type b_ty
     returnDs (
       Var foldr_id `App` Type x_ty 
                   `App` Type b_ty

@@ -342,28 +350,30 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
 --
 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 --
 --
 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 --

-dsPArrComp      :: [TypecheckedStmt] 
+dsPArrComp      :: [Stmt Id] 
+               -> LHsExpr Id

                -> Type             -- Don't use; called with `undefined' below
                -> DsM CoreExpr
                -> Type             -- Don't use; called with `undefined' below
                -> DsM CoreExpr

-dsPArrComp qs _  =
-  dsLookupGlobalValue replicatePName                     `thenDs` \repP ->
+dsPArrComp qs body _  =
+  dsLookupGlobalId replicatePName                        `thenDs` \repP ->

   let unitArray = mkApps (Var repP) [Type unitTy, 
   let unitArray = mkApps (Var repP) [Type unitTy, 

-                                    mkConApp intDataCon [mkIntLit 1], 
-                                    mkTupleExpr []]
+                                    mkIntExpr 1, 
+                                    mkCoreTup []]

   in
   in

-  dePArrComp qs (TuplePat [] Boxed) unitArray
+  dePArrComp qs body (mkTuplePat []) unitArray

 
 -- the work horse
 --
 
 -- the work horse
 --

-dePArrComp :: [TypecheckedStmt] 
-          -> TypecheckedPat            -- the current generator pattern
-          -> CoreExpr                  -- the current generator expression
+dePArrComp :: [Stmt Id] 
+          -> LHsExpr Id
+          -> LPat Id           -- the current generator pattern
+          -> CoreExpr          -- the current generator expression

           -> DsM CoreExpr
 --
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --
           -> DsM CoreExpr
 --
 --  <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
 --

-dePArrComp [ResultStmt e' _] pa cea =
-  dsLookupGlobalValue mapPName                           `thenDs` \mapP    ->
+dePArrComp [] e' pa cea =
+  dsLookupGlobalId mapPName                              `thenDs` \mapP    ->

   let ty = parrElemType cea
   in
   deLambda ty pa e'                                      `thenDs` \(clam, 
   let ty = parrElemType cea
   in
   deLambda ty pa e'                                      `thenDs` \(clam, 

@@ -372,36 +382,34 @@ dePArrComp [ResultStmt e' _] pa cea =
 --
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --
 --
 --  <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
 --

-dePArrComp (ExprStmt b _ _ : qs) pa cea =
-  dsLookupGlobalValue filterPName                        `thenDs` \filterP  ->
+dePArrComp (ExprStmt b _ _ : qs) body pa cea =
+  dsLookupGlobalId filterPName                   `thenDs` \filterP  ->

   let ty = parrElemType cea
   in
   let ty = parrElemType cea
   in

-  deLambda ty pa b                                       `thenDs` \(clam,_) ->
-  dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
+  deLambda ty pa b                               `thenDs` \(clam,_) ->
+  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
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
 --
 --
 --  <<[:e' | p <- e, qs:]>> pa ea = 
 --    let ef = filterP (\x -> case x of {p -> True; _ -> False}) e
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
 --

-dePArrComp (BindStmt p e _ : qs) pa cea =
-  dsLookupGlobalValue falseDataConName                   `thenDs` \falseId ->
-  dsLookupGlobalValue trueDataConName                    `thenDs` \trueId ->
-  dsLookupGlobalValue filterPName                        `thenDs` \filterP ->
-  dsLookupGlobalValue crossPName                         `thenDs` \crossP  ->
-  dsExpr e                                               `thenDs` \ce      ->
+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
   let ty'cea = parrElemType cea
       ty'ce  = parrElemType ce

-      false  = Var falseId
-      true   = Var trueId
+      false  = Var falseDataConId
+      true   = Var trueDataConId

   in
   newSysLocalDs ty'ce                                    `thenDs` \v       ->
   in
   newSysLocalDs ty'ce                                    `thenDs` \v       ->

-  matchSimply (Var v) (DoCtxt PArrComp) p true false      `thenDs` \pred    ->
+  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
   let cef    = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce]
       ty'cef = ty'ce                           -- filterP preserves the type

-      pa'    = TuplePat [pa, p] Boxed
+      pa'    = mkTuplePat [pa, p]

   in
   in

-  dePArrComp qs pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])
+  dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef])

 --
 --  <<[:e' | let ds, qs:]>> pa ea = 
 --    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 
 --
 --  <<[:e' | let ds, qs:]>> pa ea = 
 --    <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) 

@@ -409,24 +417,25 @@ dePArrComp (BindStmt p e _ : qs) pa cea =
 --  where
 --    {x_1, ..., x_n} = DV (ds)                -- Defined Variables
 --
 --  where
 --    {x_1, ..., x_n} = DV (ds)                -- Defined Variables
 --

-dePArrComp (LetStmt ds : qs) pa cea =
-  dsLookupGlobalValue mapPName                           `thenDs` \mapP    ->
-  let xs     = collectHsOutBinders ds
+dePArrComp (LetStmt ds : qs) body pa cea =
+  dsLookupGlobalId mapPName                              `thenDs` \mapP    ->
+  let xs     = map unLoc (collectLocalBinders ds)

       ty'cea = parrElemType cea
   in
   newSysLocalDs ty'cea                                   `thenDs` \v       ->
       ty'cea = parrElemType cea
   in
   newSysLocalDs ty'cea                                   `thenDs` \v       ->

-  dsLet ds (mkTupleExpr xs)                              `thenDs` \clet    ->
+  dsLocalBinds ds (mkCoreTup (map Var xs))               `thenDs` \clet    ->

   newSysLocalDs (exprType clet)                                  `thenDs` \let'v   ->
   newSysLocalDs (exprType clet)                                  `thenDs` \let'v   ->

-  let projBody = mkDsLet (NonRec let'v clet) $ mkTupleExpr [v, let'v]
+  let projBody = mkDsLet (NonRec let'v clet) $ 
+                mkCoreTup [Var v, Var let'v]

       errTy    = exprType projBody
       errMsg   = "DsListComp.dePArrComp: internal error!"
   in
   mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
       errTy    = exprType projBody
       errMsg   = "DsListComp.dePArrComp: internal error!"
   in
   mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->

-  matchSimply (Var v) (DoCtxt PArrComp) pa projBody cerr  `thenDs` \ccase   ->
-  let pa'    = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
+  matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr`thenDs` \ccase   ->
+  let pa'    = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]

       proj   = mkLams [v] ccase
   in
       proj   = mkLams [v] ccase
   in

-  dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
+  dePArrComp qs body pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])

 --
 --  <<[:e' | qs | qss:]>> pa ea = 
 --    <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) 
 --
 --  <<[:e' | qs | qss:]>> pa ea = 
 --    <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) 

@@ -434,33 +443,53 @@ dePArrComp (LetStmt ds : qs) pa cea =
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --

-dePArrComp (ParStmtOut []             : qss2) pa cea = dePArrComp qss2 pa cea
-dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
-  dsLookupGlobalValue zipPName                           `thenDs` \zipP    ->
-  let pa'     = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
-      ty'cea  = parrElemType cea
-      resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc
-  in
-  dsPArrComp (qs ++ [resStmt]) undefined                 `thenDs` \cqs     ->
-  let ty'cqs = parrElemType cqs
-      cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
+dePArrComp (ParStmt qss : qs) body pa cea = 
+  dsLookupGlobalId crossPName                          `thenDs` \crossP  ->
+  deParStmt qss                                                `thenDs` \(pQss, 
+                                                                  ceQss) ->
+  let ty'cea   = parrElemType cea
+      ty'ceQss = parrElemType ceQss
+      pa'      = mkTuplePat [pa, pQss]

   in
   in

-  dePArrComp (ParStmtOut qss : qss2) pa' cea'
+  dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss, 
+                                              cea, ceQss])
+  where
+    deParStmt []             =
+      -- empty parallel statement lists have not source representation
+      panic "DsListComp.dePArrComp: Empty parallel list comprehension"
+    deParStmt ((qs, xs):qss) =          -- first statement
+      let res_expr = mkExplicitTuple (map nlHsVar xs)
+      in
+      dsPArrComp (map unLoc qs) res_expr undefined       `thenDs` \cqs     ->
+      parStmts qss (mkTuplePat (map nlVarPat xs)) cqs
+    ---
+    parStmts []             pa cea = return (pa, cea)
+    parStmts ((qs, xs):qss) pa cea =    -- subsequent statements (zip'ed)
+      dsLookupGlobalId zipPName                                  `thenDs` \zipP    ->
+      let pa'      = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)]
+         ty'cea   = parrElemType cea
+         res_expr = mkExplicitTuple (map nlHsVar xs)
+      in
+      dsPArrComp (map unLoc qs) res_expr undefined       `thenDs` \cqs     ->
+      let ty'cqs = parrElemType cqs
+         cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
+      in
+      parStmts qss pa' cea'

 
 -- generate Core corresponding to `\p -> e'
 --
 deLambda        :: Type                        -- type of the argument
 
 -- generate Core corresponding to `\p -> e'
 --
 deLambda        :: Type                        -- type of the argument

-               -> TypecheckedPat       -- argument pattern
-               -> TypecheckedHsExpr    -- body
+               -> LPat Id              -- argument pattern
+               -> LHsExpr Id           -- body

                -> DsM (CoreExpr, Type)
 deLambda ty p e  =
   newSysLocalDs ty                                       `thenDs` \v       ->
                -> DsM (CoreExpr, Type)
 deLambda ty p e  =
   newSysLocalDs ty                                       `thenDs` \v       ->

-  dsExpr e                                               `thenDs` \ce      ->
+  dsLExpr e                                              `thenDs` \ce      ->

   let errTy    = exprType ce
       errMsg   = "DsListComp.deLambda: internal error!"
   in
   let errTy    = exprType ce
       errMsg   = "DsListComp.deLambda: internal error!"
   in

-  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
-  matchSimply (Var v) (DoCtxt PArrComp) p ce cerr        `thenDs` \res     ->
+  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    -> 
+  matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr      `thenDs` \res     ->

   returnDs (mkLams [v] res, errTy)
 
 -- obtain the element type of the parallel array produced by the given Core
   returnDs (mkLams [v] res, errTy)
 
 -- obtain the element type of the parallel array produced by the given Core

@@ -469,7 +498,19 @@ deLambda ty p e  =
 parrElemType   :: CoreExpr -> Type
 parrElemType e  = 
   case splitTyConApp_maybe (exprType e) of
 parrElemType   :: CoreExpr -> Type
 parrElemType e  = 
   case splitTyConApp_maybe (exprType e) of

-    Just (tycon, [ty]) | tyConName tycon == parrTyConName -> ty
+    Just (tycon, [ty]) | tycon == parrTyCon -> ty

     _                                                    -> panic
       "DsListComp.parrElemType: not a parallel array type"
     _                                                    -> panic
       "DsListComp.parrElemType: not a parallel array type"

+
+-- Smart constructor for source tuple patterns
+--
+mkTuplePat :: [LPat Id] -> LPat Id
+mkTuplePat [lpat] = lpat
+mkTuplePat lpats  = noLoc $ mkVanillaTuplePat lpats Boxed
+
+-- Smart constructor for source tuple expressions
+--
+mkExplicitTuple :: [LHsExpr id] -> LHsExpr id
+mkExplicitTuple [lexp] = lexp
+mkExplicitTuple lexps  = noLoc $ ExplicitTuple lexps Boxed

 \end{code}
 \end{code}