X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsListComp.lhs;h=c39cddd55acde9c9d6bc8afd9f6d9d972c7e5250;hb=9bb6b6d0fbca6c82040027fab9859c9fcbc1ef7e;hp=5508cb1b40fe01624ed97743a3f753bcf1f8dbb6;hpb=dabfa71f33eabc5a2d10959728f772aa016f1c84;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 5508cb1..c39cddd 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -1,16 +1,17 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[DsListComp]{Desugaring list comprehensions} \begin{code} module DsListComp ( dsListComp ) where -import Ubiq -import DsLoop -- break dsExpr-ish loop +#include "HsVersions.h" -import HsSyn ( Qual(..), HsExpr, HsBinds ) -import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) + +import HsSyn ( Stmt(..) ) +import TcHsSyn ( TypecheckedStmt ) import DsHsSyn ( outPatType ) import CoreSyn @@ -18,14 +19,14 @@ import DsMonad -- the monadery used in the desugarer import DsUtils import CmdLineOpts ( opt_FoldrBuildOn ) -import CoreUtils ( coreExprType, mkCoreIfThenElse ) -import PrelVals ( mkBuild, foldrId ) -import Type ( mkTyVarTy, mkForAllTy, mkFunTys ) -import TysPrim ( alphaTy ) -import TysWiredIn ( nilDataCon, consDataCon, listTyCon ) -import TyVar ( alphaTyVar ) +import CoreUtils ( exprType, mkIfThenElse ) +import Id ( idType ) +import Var ( Id ) +import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type ) +import TysPrim ( alphaTyVar ) +import TysWiredIn ( nilDataCon, consDataCon ) import Match ( matchSimply ) -import Util ( panic ) +import PrelNames ( foldrName, buildName ) \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -35,39 +36,27 @@ 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 :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr +dsListComp :: [TypecheckedStmt] + -> Type -- Type of list elements + -> DsM CoreExpr -dsListComp expr quals - = let - expr_ty = coreExprType expr +dsListComp quals elt_ty + | not opt_FoldrBuildOn -- Be boring + = deListComp quals (mkNilExpr elt_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 - if not opt_FoldrBuildOn then -- be boring - deListComp expr quals (nIL_EXPR expr_ty) - - else -- foldr/build lives! - new_alpha_tyvar `thenDs` \ (n_tyvar, n_ty) -> - let - alpha_to_alpha = mkFunTys [alphaTy] alphaTy - - c_ty = mkFunTys [expr_ty, n_ty] n_ty - g_ty = mkForAllTy alphaTyVar ( - (mkFunTys [expr_ty, alpha_to_alpha] alpha_to_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) - where - nIL_EXPR ty = mkCon nilDataCon [] [ty] [] - - new_alpha_tyvar :: DsM (TyVar, Type) - new_alpha_tyvar - = newTyVarsDs [alphaTyVar] `thenDs` \ [new_ty] -> - returnDs (new_ty, mkTyVarTy new_ty) + 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} %************************************************************************ @@ -113,66 +102,54 @@ 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 :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr +deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr -deListComp expr [] list -- Figure 7.4, SLPJ, p 135, rule C above - = mkConDs consDataCon [coreExprType expr] [expr, list] +deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above + = dsExpr expr `thenDs` \ core_expr -> + returnDs (mkConsExpr (exprType core_expr) core_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 ) +deListComp (GuardStmt 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) -deListComp expr (LetQual binds : quals) list - = panic "deListComp:LetQual" +-- [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 expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above +deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above = dsExpr list1 `thenDs` \ core_list1 -> let - u3_ty@u1_ty = coreExprType core_list1 -- two names, same thing + 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 - res_ty = coreExprType core_list2 - h_ty = mkFunTys [u1_ty] res_ty + 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] -> - {- - 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. - -} + newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> + + -- the "fail" value ... let - h = if False -- LATER: sw_chkr DoDeforest??? - then panic "deListComp:deforest" - -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest) - else h' + core_fail = App (Var h) (Var u3) + letrec_body = App (Var h) core_list1 in - -- the "fail" value ... - mkAppDs (Var h) [] [Var u3] `thenDs` \ core_fail -> - - deListComp expr quals core_fail `thenDs` \ rest_expr -> - - matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match -> - - mkAppDs (Var h) [] [core_list1] `thenDs` \ letrec_body -> - - returnDs ( - mkCoLetrecAny [ - ( h, - (Lam (ValBinder u1) - (Case (Var u1) - (AlgAlts - [(nilDataCon, [], core_list2), - (consDataCon, [u2, u3], core_match)] - NoDefault))) - )] letrec_body - ) + deListComp quals core_fail `thenDs` \ rest_expr -> + matchSimply (Var u2) ListCompMatch 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} @@ -180,65 +157,64 @@ 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 :: CoreExpr -- the inside of the comp - -> Type -- the type of the inside - -> Type -> Id -- 'c'; its type and id - -> Type -> Id -- 'n'; its type and id - -> [TypecheckedQual] -- the rest of the qual's +dfListComp :: Id -> Id -- 'c' and 'n' + -> [TypecheckedStmt] -- the rest of the qual's -> DsM CoreExpr -dfListComp expr expr_ty c_ty c_id n_ty n_id [] - = mkAppDs (Var c_id) [] [expr, Var n_id] +dfListComp c_id n_id [ReturnStmt expr] + = dsExpr expr `thenDs` \ core_expr -> + returnDs (mkApps (Var c_id) [core_expr, Var 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 (Var n_id)) +dfListComp c_id n_id (GuardStmt 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 expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals) - = panic "dfListComp:LetQual" +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 expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals) +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 = outPatType pat - b_ty = n_ty -- alias b_ty to n_ty - fn_ty = mkFunTys [p_ty, b_ty] b_ty - lst_ty = coreExprType 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 (Var p) pat b_ty core_rest (Var b) `thenDs` \ core_expr -> + matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return - + dsLookupGlobalValue foldrName `thenDs` \ foldr_id -> returnDs ( - mkCoLetsAny - [NonRec fn (mkValLam [p, b] core_expr), - NonRec 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 ) - -mkFoldr a b f z xs - = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs] \end{code} + +