[project @ 2004-09-30 10:35:15 by simonpj]

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

diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index f35a0a4..8491613 100644 (file)
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -8,35 +8,30 @@ module DsListComp ( dsListComp, dsPArrComp ) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

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

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

-import TyCon           ( tyConName )
-import HsSyn           ( Pat(..), HsExpr(..), Stmt(..),
-                         HsMatchContext(..), HsStmtContext(..),
-                         collectHsBinders )
-import TcHsSyn         ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
-                         hsPatType )
+import HsSyn
+import TcHsSyn         ( hsPatType )

 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 CmdLineOpts     ( DynFlag(..), dopt, 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 )
+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}
 

@@ -47,17 +42,26 @@ 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] 

           -> 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 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 (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
     let
        n_ty = mkTyVarTy n_tyvar
         c_ty = mkFunTys [elt_ty, n_ty] n_ty

@@ -68,8 +72,8 @@ dsListComp quals elt_ty
     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}
 
 %************************************************************************

@@ -126,7 +130,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.

@@ -137,38 +141,40 @@ 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] -> 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) 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)) 
                   quals list
 
     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
 

-  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
+  where 
+       bndrs_s = map snd stmtss_w_bndrs
+
+       -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+       pat      = noLoc (TuplePat pats Boxed)
+       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 ++ [noLoc $ ResultStmt (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 ->
+deListComp [ResultStmt expr] list      -- Figure 7.4, SLPJ, p 135, rule C above
+  = dsLExpr expr               `thenDs` \ core_expr ->

     returnDs (mkConsExpr (exprType core_expr) core_expr list)
 
        -- Non-last: must be a guard
     returnDs (mkConsExpr (exprType core_expr) core_expr list)
 
        -- Non-last: must be a guard

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

     deListComp quals list      `thenDs` \ core_rest ->
     returnDs (mkIfThenElse core_guard core_rest list)
 
     deListComp quals list      `thenDs` \ core_rest ->
     returnDs (mkIfThenElse core_guard core_rest list)
 

@@ -177,8 +183,8 @@ deListComp (LetStmt binds : quals) list
   = deListComp quals list      `thenDs` \ core_rest ->
     dsLet binds core_rest
 
   = deListComp quals list      `thenDs` \ core_rest ->
     dsLet binds core_rest
 

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

     deBindComp pat core_list1 quals core_list2
 \end{code}
 
     deBindComp pat core_list1 quals core_list2
 \end{code}
 

@@ -206,8 +212,10 @@ deBindComp pat core_list1 quals core_list2
                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)]
+-- gaw 2004
+             Case (Var u1) u1 res_ty
+                  [(DataAlt nilDataCon,  [],       core_list2),
+                   (DataAlt consDataCon, [u2, u3], core_match)]

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

@@ -224,38 +232,38 @@ 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
+-- gaw 2004
+         = Case (Var as) as list_ret_ty
+                 [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
+                  (DataAlt consDataCon, [a', as'], rest)]

 
 -- 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 [b] = nlVarPat b
+mk_hs_tuple_pat bs  = noLoc $ TuplePat (map nlVarPat bs) Boxed

 \end{code}
 
 
 \end{code}
 
 

@@ -280,17 +288,17 @@ 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

           -> 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 ->
+dfListComp c_id n_id [ResultStmt expr]
+  = dsLExpr expr                       `thenDs` \ core_expr ->

     returnDs (mkApps (Var c_id) [core_expr, Var n_id])
 
        -- Non-last: must be a guard
     returnDs (mkApps (Var c_id) [core_expr, Var n_id])
 
        -- 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 (ExprStmt guard ty  : quals)
+  = dsLExpr guard                                      `thenDs` \ core_guard ->

     dfListComp c_id n_id quals `thenDs` \ core_rest ->
     returnDs (mkIfThenElse core_guard core_rest (Var n_id))
 
     dfListComp c_id n_id quals `thenDs` \ core_rest ->
     returnDs (mkIfThenElse core_guard core_rest (Var n_id))
 

@@ -299,9 +307,9 @@ dfListComp c_id n_id (LetStmt binds : quals)
   = dfListComp c_id n_id quals `thenDs` \ core_rest ->
     dsLet binds core_rest
 
   = dfListComp c_id n_id quals `thenDs` \ core_rest ->
     dsLet binds core_rest
 

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

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

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

 
     -- find the required type
     let x_ty   = hsPatType pat
 
     -- find the required type
     let x_ty   = hsPatType pat

@@ -315,7 +323,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
     dfListComp c_id b quals                    `thenDs` \ core_rest ->
 
     -- build the pattern match
     dfListComp c_id b quals                    `thenDs` \ core_rest ->
 
     -- build the pattern match

-    matchSimply (Var x) (StmtCtxt 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

@@ -341,27 +349,27 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals)
 --
 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 --
 --
 --   [:e | qss:] = <<[:e | qss:]>> () [:():]
 --

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

                -> Type             -- Don't use; called with `undefined' below
                -> DsM CoreExpr
 dsPArrComp qs _  =
   dsLookupGlobalId replicatePName                        `thenDs` \repP ->
   let unitArray = mkApps (Var repP) [Type unitTy, 
                                     mkIntExpr 1, 
                -> Type             -- Don't use; called with `undefined' below
                -> DsM CoreExpr
 dsPArrComp qs _  =
   dsLookupGlobalId replicatePName                        `thenDs` \repP ->
   let unitArray = mkApps (Var repP) [Type unitTy, 
                                     mkIntExpr 1, 

-                                    mkTupleExpr []]
+                                    mkCoreTup []]

   in
   in

-  dePArrComp qs (TuplePat [] Boxed) unitArray
+  dePArrComp qs (noLoc (TuplePat [] Boxed)) unitArray

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

-dePArrComp :: [TypecheckedStmt] 
-          -> TypecheckedPat            -- the current generator pattern
-          -> CoreExpr                  -- the current generator expression
+dePArrComp :: [Stmt 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 =
+dePArrComp [ResultStmt e'] pa cea =

   dsLookupGlobalId mapPName                              `thenDs` \mapP    ->
   let ty = parrElemType cea
   in
   dsLookupGlobalId mapPName                              `thenDs` \mapP    ->
   let ty = parrElemType cea
   in

@@ -371,7 +379,7 @@ 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 =
+dePArrComp (ExprStmt b _ : qs) pa cea =

   dsLookupGlobalId filterPName                   `thenDs` \filterP  ->
   let ty = parrElemType cea
   in
   dsLookupGlobalId filterPName                   `thenDs` \filterP  ->
   let ty = parrElemType cea
   in

@@ -383,22 +391,20 @@ dePArrComp (ExprStmt b _ _ : qs) pa cea =
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
 --
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
 --

-dePArrComp (BindStmt p e _ : qs) pa cea =
-  dsLookupGlobalId falseDataConName                      `thenDs` \falseId ->
-  dsLookupGlobalId trueDataConName                       `thenDs` \trueId ->
+dePArrComp (BindStmt p e : qs) pa cea =

   dsLookupGlobalId filterPName                   `thenDs` \filterP ->
   dsLookupGlobalId crossPName                    `thenDs` \crossP  ->
   dsLookupGlobalId filterPName                   `thenDs` \filterP ->
   dsLookupGlobalId crossPName                    `thenDs` \crossP  ->

-  dsExpr e                                               `thenDs` \ce      ->
+  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       ->
   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
   in
   newSysLocalDs ty'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'    = TuplePat [pa, p] Boxed
+      pa'    = noLoc (TuplePat [pa, p] Boxed)

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

@@ -410,19 +416,20 @@ dePArrComp (BindStmt p e _ : qs) pa cea =
 --
 dePArrComp (LetStmt ds : qs) pa cea =
   dsLookupGlobalId mapPName                              `thenDs` \mapP    ->
 --
 dePArrComp (LetStmt ds : qs) pa cea =
   dsLookupGlobalId mapPName                              `thenDs` \mapP    ->

-  let xs     = collectHsBinders ds
+  let xs     = map unLoc (collectGroupBinders 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    ->
+  dsLet 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    ->
   matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr  `thenDs` \ccase   ->
       errTy    = exprType projBody
       errMsg   = "DsListComp.dePArrComp: internal error!"
   in
   mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
   matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr  `thenDs` \ccase   ->

-  let pa'    = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
+  let pa'    = noLoc $ TuplePat [pa, noLoc (TuplePat (map nlVarPat xs) Boxed)] Boxed

       proj   = mkLams [v] ccase
   in
   dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])
       proj   = mkLams [v] ccase
   in
   dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea])

@@ -433,32 +440,32 @@ 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 =
+dePArrComp (ParStmt []             : qss2) pa cea = dePArrComp qss2 pa cea
+dePArrComp (ParStmt ((qs, xs):qss) : qss2) pa cea =

   dsLookupGlobalId zipPName                              `thenDs` \zipP    ->
   dsLookupGlobalId zipPName                              `thenDs` \zipP    ->

-  let pa'     = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
+  let pa'     = noLoc $ TuplePat [pa, noLoc (TuplePat (map nlVarPat xs) Boxed)] Boxed

       ty'cea  = parrElemType cea
       ty'cea  = parrElemType cea

-      resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc
+      resStmt = ResultStmt (noLoc $ ExplicitTuple (map nlHsVar xs) Boxed)

   in
   in

-  dsPArrComp (qs ++ [resStmt]) undefined                 `thenDs` \cqs     ->
+  dsPArrComp (map unLoc qs ++ [resStmt]) undefined       `thenDs` \cqs     ->

   let ty'cqs = parrElemType cqs
       cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
   in
   let ty'cqs = parrElemType cqs
       cea'   = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
   in

-  dePArrComp (ParStmtOut qss : qss2) pa' cea'
+  dePArrComp (ParStmt qss : qss2) 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    ->
+  mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    -> 

   matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr      `thenDs` \res     ->
   returnDs (mkLams [v] res, errTy)
 
   matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr      `thenDs` \res     ->
   returnDs (mkLams [v] res, errTy)
 

@@ -468,7 +475,7 @@ 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"
 \end{code}
     _                                                    -> panic
       "DsListComp.parrElemType: not a parallel array type"
 \end{code}