X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsListComp.lhs;h=a98aef6b3a2c7584613dbf49d7f43866a2305187;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=6bb41a92e4b54bcd7cfcdbd3c2babd43ca1a2885;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 6bb41a9..a98aef6 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[DsListComp]{Desugaring list comprehensions and array comprehensions} + +Desugaring list comprehensions and array comprehensions \begin{code} module DsListComp ( dsListComp, dsPArrComp ) where @@ -10,30 +12,25 @@ module DsListComp ( dsListComp, dsPArrComp ) where import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) -import BasicTypes ( Boxity(..) ) +import BasicTypes import HsSyn -import TcHsSyn ( hsPatType, mkVanillaTuplePat ) +import TcHsSyn import CoreSyn import DsMonad -- the monadery used in the desugarer import DsUtils -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 TysWiredIn ( nilDataCon, consDataCon, trueDataConId, falseDataConId, - unitDataConId, unitTy, mkListTy, parrTyCon ) -import Match ( matchSimply ) -import PrelNames ( foldrName, buildName, replicatePName, mapPName, - filterPName, zipPName, crossPName ) -import PrelInfo ( pAT_ERROR_ID ) -import SrcLoc ( noLoc, unLoc ) -import Panic ( panic ) +import DynFlags +import CoreUtils +import Var +import Type +import TysPrim +import TysWiredIn +import Match +import PrelNames +import PrelInfo +import SrcLoc +import Panic \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -52,7 +49,7 @@ dsListComp lquals body elt_ty let quals = map unLoc lquals in - if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags + if not (dopt Opt_RewriteRules 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 @@ -197,7 +194,7 @@ deBindComp pat core_list1 quals body core_list2 u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha - u2_ty = hsPatType pat + u2_ty = hsLPatType pat res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty @@ -313,7 +310,7 @@ dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = dsLExpr list1 `thenDs` \ core_list1 -> -- find the required type - let x_ty = hsPatType pat + let x_ty = hsLPatType pat b_ty = idType n_id in @@ -354,7 +351,9 @@ dsPArrComp :: [Stmt Id] -> LHsExpr Id -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr -dsPArrComp qs body _ = +dsPArrComp [ParStmt qss] body _ = -- parallel comprehension + dePArrParComp qss body +dsPArrComp qs body _ = -- no ParStmt in `qs' dsLookupGlobalId replicatePName `thenDs` \repP -> let unitArray = mkApps (Var repP) [Type unitTy, mkIntExpr 1, @@ -362,6 +361,8 @@ dsPArrComp qs body _ = in dePArrComp qs body (mkTuplePat []) unitArray + + -- the work horse -- dePArrComp :: [Stmt Id] @@ -390,30 +391,34 @@ dePArrComp (ExprStmt b _ _ : qs) body pa cea = 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 +-- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e -- in --- <<[:e' | qs:]>> (pa, p) (crossP ea ef) +-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- 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 - false = Var falseDataConId - true = Var trueDataConId + dsLookupGlobalId filterPName `thenDs` \filterP -> + dsLookupGlobalId crossMapPName `thenDs` \crossMapP -> + dsLExpr e `thenDs` \ce -> + let ety'cea = parrElemType cea + ety'ce = parrElemType ce + false = Var falseDataConId + true = Var trueDataConId in - newSysLocalDs ty'ce `thenDs` \v -> + newSysLocalDs ety'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' = mkTuplePat [pa, p] + let cef = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] in - dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef]) + mkLambda ety'cea pa cef `thenDs` \(clam, + _ ) -> + let ety'cef = ety'ce -- filter doesn't change the element type + pa' = mkTuplePat [pa, p] + in + dePArrComp qs body pa' (mkApps (Var crossMapP) + [Type ety'cea, Type ety'cef, cea, clam]) -- -- <<[:e' | let ds, qs:]>> pa ea = -- <<[:e' | qs:]>> (pa, (x_1, ..., x_n)) --- (mapP (\v@pa -> (v, let ds in (x_1, ..., x_n))) ea) +-- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea) -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- @@ -435,27 +440,29 @@ dePArrComp (LetStmt ds : qs) body pa cea = let pa' = mkTuplePat [pa, mkTuplePat (map nlVarPat xs)] proj = mkLams [v] ccase in - dePArrComp qs body pa' (mkApps (Var mapP) [Type ty'cea, proj, cea]) + dePArrComp qs body pa' (mkApps (Var mapP) + [Type ty'cea, Type errTy, proj, cea]) +-- +-- The parser guarantees that parallel comprehensions can only appear as +-- singeltons qualifier lists, which we already special case in the caller. +-- So, encountering one here is a bug. -- +dePArrComp (ParStmt _ : _) _ _ _ = + panic "DsListComp.dePArrComp: malformed comprehension AST" + -- <<[:e' | qs | qss:]>> pa ea = -- <<[:e' | qss:]>> (pa, (x_1, ..., x_n)) -- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>) -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrComp (ParStmt qss : qs) body pa cea = - dsLookupGlobalId crossPName `thenDs` \crossP -> +dePArrParComp qss body = deParStmt qss `thenDs` \(pQss, ceQss) -> - let ty'cea = parrElemType cea - ty'ceQss = parrElemType ceQss - pa' = mkTuplePat [pa, pQss] - in - dePArrComp qs body pa' (mkApps (Var crossP) [Type ty'cea, Type ty'ceQss, - cea, ceQss]) + dePArrComp [] body pQss ceQss where deParStmt [] = - -- empty parallel statement lists have not source representation + -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = -- first statement let res_expr = mkExplicitTuple (map nlHsVar xs) @@ -478,19 +485,28 @@ dePArrComp (ParStmt qss : qs) body pa cea = -- generate Core corresponding to `\p -> e' -- -deLambda :: Type -- type of the argument - -> LPat Id -- argument pattern - -> LHsExpr Id -- body - -> DsM (CoreExpr, Type) -deLambda ty p e = - newSysLocalDs ty `thenDs` \v -> +deLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> LHsExpr Id -- body + -> DsM (CoreExpr, Type) +deLambda ty p e = dsLExpr e `thenDs` \ce -> - let errTy = exprType ce - errMsg = "DsListComp.deLambda: internal error!" + mkLambda ty p ce + +-- generate Core for a lambda pattern match, where the body is already in Core +-- +mkLambda :: Type -- type of the argument + -> LPat Id -- argument pattern + -> CoreExpr -- desugared body + -> DsM (CoreExpr, Type) +mkLambda ty p ce = + newSysLocalDs ty `thenDs` \v -> + let errMsg = "DsListComp.deLambda: internal error!" + ce'ty = exprType ce in - mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> + mkErrorAppDs pAT_ERROR_ID ce'ty errMsg `thenDs` \cerr -> matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr `thenDs` \res -> - returnDs (mkLams [v] res, errTy) + returnDs (mkLams [v] res, ce'ty) -- obtain the element type of the parallel array produced by the given Core -- expression