[project @ 2003-10-30 09:03: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 ee25c8b..fc3a689 100644 (file)
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -11,9 +11,8 @@ module DsListComp ( dsListComp, dsPArrComp ) where
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
 
 import BasicTypes      ( Boxity(..) )
 import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
 
 import BasicTypes      ( Boxity(..) )

-import TyCon           ( tyConName )

 import HsSyn           ( Pat(..), HsExpr(..), Stmt(..),
 import HsSyn           ( Pat(..), HsExpr(..), Stmt(..),

-                         HsMatchContext(..), HsDoContext(..),
+                         HsMatchContext(..), HsStmtContext(..),

                          collectHsBinders )
 import TcHsSyn         ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
                          hsPatType )
                          collectHsBinders )
 import TcHsSyn         ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr,
                          hsPatType )

@@ -22,19 +21,18 @@ import CoreSyn
 import DsMonad         -- the monadery used in the desugarer
 import DsUtils
 
 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 SrcLoc          ( noSrcLoc )
 import Panic           ( panic )
 import PrelInfo                ( pAT_ERROR_ID )
 import SrcLoc          ( noSrcLoc )
 import Panic           ( panic )

@@ -52,12 +50,19 @@ dsListComp :: [TypecheckedStmt]
           -> DsM CoreExpr
 
 dsListComp quals elt_ty
           -> 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] ->
+  = getDOptsDs  `thenDs` \dflags ->
+    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 +73,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 +131,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.

@@ -140,26 +145,29 @@ with the Unboxed variety.
 
 deListComp :: [TypecheckedStmt] -> 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      = 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)
+       do_list_comp (stmts, bndrs)

          = dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc])
                       (mk_bndrs_tys bndrs)
 
          = dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc])
                       (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
 deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above
 
        -- Last: the one to return
 deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above

@@ -202,7 +210,7 @@ deBindComp pat core_list1 quals core_list2
        letrec_body = App (Var h) core_list1
     in
     deListComp quals core_fail                 `thenDs` \ rest_expr ->
        letrec_body = App (Var h) core_list1
     in
     deListComp quals core_fail                 `thenDs` \ rest_expr ->

-    matchSimply (Var u2) (DoCtxt ListComp) pat
+    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 $

@@ -224,29 +232,26 @@ 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
     list_tys   = map mkListTy elt_tys
        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
+    ret_elt_ty = mkCoreTupTy elt_tys

     zip_fn_ty  = mkFunTys list_tys (mkListTy ret_elt_ty)
 
     mk_case (as, a', as') rest
          = Case (Var as) as [(DataAlt nilDataCon,  [],        mkNilExpr ret_elt_ty),
                              (DataAlt consDataCon, [a', as'], rest)]
 
     zip_fn_ty  = mkFunTys list_tys (mkListTy ret_elt_ty)
 
     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
-

 -- Helper functions that makes an HsTuple only for non-1-sized tuples
 mk_hs_tuple_expr :: [Id] -> TypecheckedHsExpr
 mk_hs_tuple_expr []   = HsVar unitDataConId
 -- Helper functions that makes an HsTuple only for non-1-sized tuples
 mk_hs_tuple_expr :: [Id] -> TypecheckedHsExpr
 mk_hs_tuple_expr []   = HsVar unitDataConId

@@ -315,7 +320,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) (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

@@ -348,7 +353,7 @@ dsPArrComp qs _  =
   dsLookupGlobalId replicatePName                        `thenDs` \repP ->
   let unitArray = mkApps (Var repP) [Type unitTy, 
                                     mkIntExpr 1, 
   dsLookupGlobalId replicatePName                        `thenDs` \repP ->
   let unitArray = mkApps (Var repP) [Type unitTy, 
                                     mkIntExpr 1, 

-                                    mkTupleExpr []]
+                                    mkCoreTup []]

   in
   dePArrComp qs (TuplePat [] Boxed) unitArray
 
   in
   dePArrComp qs (TuplePat [] Boxed) unitArray
 

@@ -384,18 +389,16 @@ dePArrComp (ExprStmt b _ _ : qs) pa cea =
 --    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
 --
 dePArrComp (BindStmt p e _ : qs) pa cea =
 --    <<[:e' | qs:]>> (pa, p) (crossP ea ef)
 --
 dePArrComp (BindStmt p e _ : qs) pa cea =

-  dsLookupGlobalId falseDataConName                      `thenDs` \falseId ->
-  dsLookupGlobalId trueDataConName                       `thenDs` \trueId ->

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

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

@@ -414,14 +417,15 @@ dePArrComp (LetStmt ds : qs) pa cea =
       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    ->
       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   ->
+  matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr  `thenDs` \ccase   ->

   let pa'    = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
       proj   = mkLams [v] ccase
   in
   let pa'    = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
       proj   = mkLams [v] ccase
   in

@@ -433,8 +437,8 @@ 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    ->
   let pa'     = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
       ty'cea  = parrElemType cea
   dsLookupGlobalId zipPName                              `thenDs` \zipP    ->
   let pa'     = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
       ty'cea  = parrElemType cea

@@ -444,7 +448,7 @@ dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
   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'
 --
 
 -- generate Core corresponding to `\p -> e'
 --

@@ -459,7 +463,7 @@ deLambda ty p e  =
       errMsg   = "DsListComp.deLambda: internal error!"
   in
   mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->
       errMsg   = "DsListComp.deLambda: internal error!"
   in
   mkErrorAppDs pAT_ERROR_ID errTy errMsg                  `thenDs` \cerr    ->

-  matchSimply (Var v) (DoCtxt PArrComp) p ce cerr        `thenDs` \res     ->
+  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

@@ -468,7 +472,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}