X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsListComp.lhs;h=431fb93f4c4a0303d15afe32ccd308a33d282053;hb=85754c0e8d62a2ac46cb983fb0033fdcdd38f6ef;hp=51748b61357500c36353e3e2a7e104eb8473fa27;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 51748b6..431fb93 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -1,29 +1,35 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[DsListComp]{Desugaring list comprehensions} \begin{code} module DsListComp ( dsListComp ) where +#include "HsVersions.h" -import AbsSyn -- the stuff being desugared -import PlainCore -- the output of desugaring; - -- importing this module also gets all the - -- CoreSyn utility functions -import DsMonad -- the monadery used in the desugarer +import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) + +import BasicTypes ( Boxity(..) ) +import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) ) +import TcHsSyn ( TypecheckedStmt ) +import DsHsSyn ( outPatType ) +import CoreSyn -import AbsPrel ( mkFunTy, nilDataCon, consDataCon, listTyCon, - mkBuild, mkFoldr - ) -import AbsUniType ( alpha_tv, alpha, mkTyVarTy, mkForallTy ) -import CmdLineOpts ( GlobalSwitch(..) ) -import DsExpr ( dsExpr ) +import DsMonad -- the monadery used in the desugarer import DsUtils -import Id ( getIdInfo, replaceIdInfo ) -import IdInfo + +import CmdLineOpts ( opt_FoldrBuildOn ) +import CoreUtils ( exprType, mkIfThenElse ) +import Id ( idType ) +import Var ( Id ) +import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) +import TysPrim ( alphaTyVar ) +import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, tupleCon, mkListTy, mkTupleTy ) import Match ( matchSimply ) -import Util +import PrelNames ( foldrName, buildName ) +import SrcLoc ( noSrcLoc ) +import List ( zip4 ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -33,38 +39,25 @@ 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} -dsListComp :: PlainCoreExpr -> [TypecheckedQual] -> DsM PlainCoreExpr +dsListComp :: [TypecheckedStmt] + -> Type -- Type of list elements + -> DsM CoreExpr -dsListComp expr quals - = let expr_ty = typeOfCoreExpr expr - in - ifSwitchSetDs FoldrBuildOn ( - new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) -> - let - c_ty = expr_ty `mkFunTy` (n_ty `mkFunTy` n_ty) - g_ty = mkForallTy [alpha_tv] ( - (expr_ty `mkFunTy` (alpha `mkFunTy` alpha)) - `mkFunTy` (alpha `mkFunTy` alpha)) - in - newSysLocalsDs [c_ty,n_ty,g_ty] `thenDs` \ [c, n, g] -> - - dfListComp expr expr_ty - c_ty c - n_ty n - quals `thenDs` \ result -> - - returnDs (mkBuild expr_ty n_tyvar c n g result) - - ) {-else be boring-} ( - deListComp expr quals (nIL_EXPR expr_ty) - ) - where - nIL_EXPR ty = CoCon nilDataCon [ty] [] +dsListComp quals elt_ty + | not opt_FoldrBuildOn -- Be boring + = deListComp quals (mkNilExpr elt_ty) - new_alpha_tyvar :: DsM (TyVar, UniType) - new_alpha_tyvar - = newTyVarsDs [alpha_tv] `thenDs` \ [new_ty] -> - returnDs (new_ty,mkTyVarTy new_ty) + | otherwise -- foldr/build lives! + = 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 -> + returnDs (Var build_id `App` Type elt_ty + `App` mkLams [n_tyvar, c, n] result) \end{code} %************************************************************************ @@ -110,63 +103,129 @@ TQ << [ e | p <- L1, qs ] ++ L2 >> = is the TE translation scheme. Note that we carry around the @L@ list already desugared. @dsListComp@ does the top TE rule mentioned above. -\begin{code} -deListComp :: PlainCoreExpr -> [TypecheckedQual] -> PlainCoreExpr -> DsM PlainCoreExpr +To the above, we add an additional rule to deal with parallel list +comprehensions. The translation goes roughly as follows: + [ e | p1 <- e11, let v1 = e12, p2 <- e13 + | q1 <- e21, let v2 = e22, q2 <- e23] + => + [ e | ((p1,v1,p2), (q1,v2,q2)) <- + zip [(p1,v1,p2) | p1 <- e11, let v1 = e12, p2 <- e13] + [(q1,v2,q2) | q1 <- e21, let v2 = e22, q2 <- e23]] +In the translation below, the ParStmtOut 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. +The zip function is generated here a) because it's small, and b) because then we +don't have to deal with arbitrary limits on the number of zip functions in the +prelude, nor which library the zip function came from. +The introduced tuples are Boxed, but only because I couldn't get it to work +with the Unboxed variety. -deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above - = mkCoConDs consDataCon [typeOfCoreExpr expr] [expr, list] - -deListComp expr ((FilterQual filt): quals) list -- rule B above - = dsExpr filt `thenDs` \ core_filt -> - deListComp expr quals list `thenDs` \ core_rest -> - returnDs ( mkCoreIfThenElse core_filt core_rest list ) +\begin{code} -deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above - = dsExpr list1 `thenDs` \ core_list1 -> - let - u3_ty@u1_ty = typeOfCoreExpr core_list1 -- two names, same thing +deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr - -- u1_ty is a [alpha] type, and u2_ty = alpha - u2_ty = typeOfPat pat - - res_ty = typeOfCoreExpr core_list2 - h_ty = mkFunTy u1_ty res_ty +deListComp (ParStmtOut bndrstmtss : quals) list + = mapDs doListComp qualss `thenDs` \ exps -> + mapDs genAS bndrss `thenDs` \ ass -> + mapDs genA bndrss `thenDs` \ as -> + mapDs genAS' bndrss `thenDs` \ as's -> + let retTy = myTupleTy Boxed (length bndrss) qualTys + zipTy = foldr mkFunTy (mkListTy retTy) (map mkListTy qualTys) in - newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] - `thenDs` \ [h', u1, u2, u3] -> - {- - Make the function h unfoldable by the deforester. - Since it only occurs once in the body, we can't get - an increase in code size by unfolding it. - -} --- getSwitchCheckerDs `thenDs` \ sw_chkr -> - let - h = if False -- LATER: sw_chkr DoDeforest??? - then replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest) - else h' + newSysLocalDs zipTy `thenDs` \ zipFn -> + let target = mkConsExpr retTy (mkTupleExpr as) (foldl App (Var zipFn) (map Var as's)) + zipExp = mkLet zipFn (zip4 bndrss ass as as's) exps target in - -- the "fail" value ... - mkCoAppDs (CoVar h) (CoVar u3) `thenDs` \ core_fail -> + deBindComp pat zipExp quals list + where (bndrss, stmtss) = unzip bndrstmtss + pats = map (\ps -> mkTuplePat (map VarPat ps)) bndrss + mkTuplePat [p] = p + mkTuplePat ps = TuplePat ps Boxed + pat = TuplePat pats Boxed + + qualss = map mkQuals bndrstmtss + mkQuals (bndrs, stmts) = (bndrs, stmts ++ [ExprStmt (myTupleExpr bndrs) noSrcLoc]) + + qualTys = map mkBndrsTy bndrss + mkBndrsTy bndrs = myTupleTy Boxed (length bndrs) (map idType bndrs) + + doListComp (bndrs, stmts) + = dsListComp stmts (mkBndrsTy bndrs) + genA bndrs = newSysLocalDs (mkBndrsTy bndrs) + genAS bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs)) + genAS' bndrs = newSysLocalDs (mkListTy (mkBndrsTy bndrs)) + + mkLet zipFn vars exps target + = Let (Rec [(zipFn, + foldr Lam (mkBody target vars) (map getAs vars))]) + (foldl App (Var zipFn) exps) + getAs (_, as, _, _) = as + mkBody target vars + = foldr mkCase (foldr mkTuplCase target vars) vars + mkCase (ps, as, a, as') rest + = Case (Var as) as [(DataAlt nilDataCon, [], mkConApp nilDataCon []), + (DataAlt consDataCon, [a, as'], rest)] + mkTuplCase ([p], as, a, as') rest + = App (Lam p rest) (Var a) + mkTuplCase (ps, as, a, as') rest + = Case (Var a) a [(DataAlt (tupleCon Boxed (length ps)), ps, rest)] + + myTupleTy boxity arity [ty] = ty + myTupleTy boxity arity tys = mkTupleTy boxity arity tys + myTupleExpr [] = HsVar unitDataConId + myTupleExpr [id] = HsVar id + myTupleExpr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed + + -- Last: the one to return +deListComp [ExprStmt 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) + + -- Non-last: must be a guard +deListComp (ExprStmt guard locn : quals) list -- rule B above + = dsExpr guard `thenDs` \ core_guard -> + deListComp quals list `thenDs` \ core_rest -> + 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 (BindStmt pat list1 locn : quals) core_list2 -- rule A' above + = dsExpr list1 `thenDs` \ core_list1 -> + deBindComp pat core_list1 quals core_list2 - deListComp expr quals core_fail `thenDs` \ rest_expr -> +deBindComp pat core_list1 quals core_list2 + = let + u3_ty@u1_ty = exprType core_list1 -- two names, same thing - matchSimply (CoVar u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> + -- u1_ty is a [alpha] type, and u2_ty = alpha + u2_ty = outPatType pat - mkCoAppDs (CoVar h) core_list1 `thenDs` \ letrec_body -> + res_ty = exprType core_list2 + h_ty = u1_ty `mkFunTy` res_ty + in + newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> - returnDs ( - mkCoLetrecAny [ - ( h, - (CoLam [ u1 ] - (CoCase (CoVar u1) - (CoAlgAlts - [(nilDataCon, [], core_list2), - (consDataCon, [u2, u3], core_match)] - CoNoDefault))) - )] letrec_body - ) + -- the "fail" value ... + let + 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) ListComp pat + 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)] + in + returnDs (Let (Rec [(h, rhs)]) letrec_body) \end{code} + %************************************************************************ %* * \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions} @@ -174,61 +233,66 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above %************************************************************************ @dfListComp@ are the rules used with foldr/build turned on: + \begin{verbatim} -TE < [ e | ] >> c n = c e n -TE << [ e | b , q ] >> c n = if b then TE << [ e | q ] >> c n else n -TE << [ e | p <- l , q ] c n = foldr - (\ TE << p >> b -> TE << [ e | q ] >> c b - _ b -> b) n l +TE[ e | ] c n = c e n +TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n +TE[ e | p <- l , q ] c n = let + f = \ x b -> case x of + p -> TE[ e | q ] c b + _ -> b + in + foldr f n l \end{verbatim} + \begin{code} -dfListComp :: PlainCoreExpr -- the inside of the comp - -> UniType -- the type of the inside - -> UniType -> Id -- 'c'; its type and id - -> UniType -> Id -- 'n'; its type and id - -> [TypecheckedQual] -- the rest of the qual's - -> DsM PlainCoreExpr - -dfListComp expr expr_ty c_ty c_id n_ty n_id [] - = mkCoAppDs (CoVar c_id) expr `thenDs` \ inner -> - mkCoAppDs inner (CoVar n_id) - -dfListComp expr expr_ty c_ty c_id n_ty n_id ((FilterQual filt) : quals) - = dsExpr filt `thenDs` \ core_filt -> - dfListComp expr expr_ty c_ty c_id n_ty n_id quals - `thenDs` \ core_rest -> - returnDs (mkCoreIfThenElse core_filt core_rest (CoVar n_id)) - -dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals) +dfListComp :: Id -> Id -- 'c' and 'n' + -> [TypecheckedStmt] -- the rest of the qual's + -> DsM CoreExpr + + -- Last: the one to return +dfListComp c_id n_id [ExprStmt expr locn] + = dsExpr expr `thenDs` \ core_expr -> + returnDs (mkApps (Var c_id) [core_expr, Var n_id]) + + -- Non-last: must be a guard +dfListComp c_id n_id (ExprStmt guard locn : quals) + = dsExpr 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 (LetStmt binds : quals) + -- new in 1.3, local bindings + = dfListComp c_id n_id quals `thenDs` \ core_rest -> + dsLet binds core_rest + +dfListComp c_id n_id (BindStmt pat list1 locn : quals) -- evaluate the two lists = dsExpr list1 `thenDs` \ core_list1 -> -- find the required type - - let p_ty = typeOfPat pat - b_ty = n_ty -- alias b_ty to n_ty - fn_ty = p_ty `mkFunTy` (b_ty `mkFunTy` b_ty) - lst_ty = typeOfCoreExpr core_list1 + let x_ty = outPatType pat + b_ty = idType n_id in -- create some new local id's - - newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty] `thenDs` \ [b,p,fn,lst] -> + newSysLocalsDs [b_ty,x_ty] `thenDs` \ [b,x] -> -- build rest of the comprehesion + dfListComp c_id b quals `thenDs` \ core_rest -> - dfListComp expr expr_ty c_ty c_id b_ty b quals `thenDs` \ core_rest -> -- build the pattern match - - matchSimply (CoVar p) pat b_ty core_rest (CoVar b) `thenDs` \ core_expr -> + matchSimply (Var x) ListComp pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return - + dsLookupGlobalValue foldrName `thenDs` \ foldr_id -> returnDs ( - mkCoLetsAny - [CoNonRec fn (CoLam [p,b] core_expr), - CoNonRec lst core_list1] - (mkFoldr p_ty n_ty fn n_id lst) + Var foldr_id `App` Type x_ty + `App` Type b_ty + `App` mkLams [x, b] core_expr + `App` Var n_id + `App` core_list1 ) \end{code} +