X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsListComp.lhs;h=9a77075d960f84ae89d7a8af6e09b91744e5ce1e;hb=962aaded9a544188b7d86639ab4993af205e9d72;hp=88c76f6de6704320b0dd4af02ee125ae938dd9ed;hpb=af93bb787305c0401eb658f149021e22d1ab98cc;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 88c76f6..9a77075 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -12,29 +12,28 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) import TyCon ( tyConName ) -import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), - HsMatchContext(..), HsDoContext(..), - collectHsOutBinders ) +import HsSyn ( Pat(..), HsExpr(..), Stmt(..), + HsMatchContext(..), HsStmtContext(..), + collectHsBinders ) import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, - outPatType ) + hsPatType ) 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 TysWiredIn ( nilDataCon, consDataCon, unitDataConId, unitTy, - mkListTy, mkTupleTy, intDataCon ) +import TysWiredIn ( nilDataCon, consDataCon, trueDataConId, falseDataConId, + unitDataConId, unitTy, mkListTy ) import Match ( matchSimply ) -import PrelNames ( trueDataConName, falseDataConName, foldrName, - buildName, replicatePName, mapPName, filterPName, - zipPName, crossPName, parrTyConName ) +import PrelNames ( foldrName, buildName, replicatePName, mapPName, + filterPName, zipPName, crossPName, parrTyConName ) import PrelInfo ( pAT_ERROR_ID ) import SrcLoc ( noSrcLoc ) import Panic ( panic ) @@ -52,24 +51,31 @@ dsListComp :: [TypecheckedStmt] -> 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 in newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] -> dfListComp c n quals `thenDs` \ result -> - dsLookupGlobalValue buildName `thenDs` \ build_id -> + dsLookupGlobalId buildName `thenDs` \ build_id -> 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} %************************************************************************ @@ -126,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 -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. @@ -140,26 +146,29 @@ with the Unboxed variety. deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr -deListComp (ParStmtOut bndrstmtss : quals) list - = mapDs do_list_comp bndrstmtss `thenDs` \ exps -> +deListComp (ParStmt stmtss_w_bndrs : quals) list + = mapDs 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 - 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 - 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) - 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 @@ -189,7 +198,7 @@ deBindComp pat core_list1 quals 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 = outPatType pat + u2_ty = hsPatType pat res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty @@ -202,7 +211,7 @@ deBindComp pat core_list1 quals core_list2 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 $ @@ -229,24 +238,21 @@ mkZipBind elt_tys mapDs newSysLocalDs list_tys `thenDs` \ as's -> 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 - 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)] --- 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 @@ -304,7 +310,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) = dsExpr list1 `thenDs` \ core_list1 -> -- find the required type - let x_ty = outPatType pat + let x_ty = hsPatType pat b_ty = idType n_id in @@ -315,11 +321,11 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) 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 - dsLookupGlobalValue foldrName `thenDs` \ foldr_id -> + dsLookupGlobalId foldrName `thenDs` \ foldr_id -> returnDs ( Var foldr_id `App` Type x_ty `App` Type b_ty @@ -345,10 +351,10 @@ dsPArrComp :: [TypecheckedStmt] -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr dsPArrComp qs _ = - dsLookupGlobalValue replicatePName `thenDs` \repP -> + dsLookupGlobalId replicatePName `thenDs` \repP -> let unitArray = mkApps (Var repP) [Type unitTy, - mkConApp intDataCon [mkIntLit 1], - mkTupleExpr []] + mkIntExpr 1, + mkCoreTup []] in dePArrComp qs (TuplePat [] Boxed) unitArray @@ -362,7 +368,7 @@ dePArrComp :: [TypecheckedStmt] -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- dePArrComp [ResultStmt e' _] pa cea = - dsLookupGlobalValue mapPName `thenDs` \mapP -> + dsLookupGlobalId mapPName `thenDs` \mapP -> let ty = parrElemType cea in deLambda ty pa e' `thenDs` \(clam, @@ -372,7 +378,7 @@ dePArrComp [ResultStmt e' _] pa cea = -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- dePArrComp (ExprStmt b _ _ : qs) pa cea = - dsLookupGlobalValue filterPName `thenDs` \filterP -> + dsLookupGlobalId filterPName `thenDs` \filterP -> let ty = parrElemType cea in deLambda ty pa b `thenDs` \(clam,_) -> @@ -384,18 +390,16 @@ dePArrComp (ExprStmt b _ _ : qs) pa cea = -- <<[: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 -> + dsLookupGlobalId filterPName `thenDs` \filterP -> + dsLookupGlobalId crossPName `thenDs` \crossP -> + dsExpr e `thenDs` \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) (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 @@ -409,19 +413,20 @@ dePArrComp (BindStmt p e _ : qs) pa cea = -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- dePArrComp (LetStmt ds : qs) pa cea = - dsLookupGlobalValue mapPName `thenDs` \mapP -> - let xs = collectHsOutBinders ds + dsLookupGlobalId mapPName `thenDs` \mapP -> + let xs = collectHsBinders ds 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 -> - 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) (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 @@ -433,9 +438,9 @@ dePArrComp (LetStmt ds : qs) pa cea = -- 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 -> +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 resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc @@ -444,7 +449,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 - dePArrComp (ParStmtOut qss : qss2) pa' cea' + dePArrComp (ParStmt qss : qss2) pa' cea' -- generate Core corresponding to `\p -> e' -- @@ -459,7 +464,7 @@ deLambda ty p e = 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