X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsListComp.lhs;h=b029637c654758065d5df9c358f091b0eebeda1c;hb=94ff1ec1546169fc839b2318c0d141f3089d3e26;hp=bec2c8ac244ca088abfc99caad05ea6c624b133a;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index bec2c8a..b029637 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -1,18 +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} -#include "HsVersions.h" - module DsListComp ( dsListComp ) where -IMP_Ubiq() -IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) -import HsSyn ( Stmt(..), HsExpr, HsBinds ) -import TcHsSyn ( SYN_IE(TypecheckedStmt), SYN_IE(TypecheckedHsExpr) , SYN_IE(TypecheckedHsBinds) ) +import HsSyn ( Stmt(..), HsExpr ) +import TcHsSyn ( TypecheckedStmt, TypecheckedHsExpr ) import DsHsSyn ( outPatType ) import CoreSyn @@ -20,14 +19,15 @@ 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, mkFunTy ) -import TysPrim ( alphaTy ) +import CoreUtils ( coreExprType ) +import Var ( Id, TyVar ) +import Const ( Con(..) ) +import PrelInfo ( foldrId ) +import Type ( mkTyVarTy, mkForAllTy, mkFunTys, mkFunTy, Type ) +import TysPrim ( alphaTyVar, alphaTy ) import TysWiredIn ( nilDataCon, consDataCon, listTyCon ) -import TyVar ( alphaTyVar ) import Match ( matchSimply ) -import Util ( panic ) +import Outputable \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -66,7 +66,7 @@ dsListComp quals elt_ty returnDs (mkBuild elt_ty n_tyvar c n g result) where - nil_expr = mkCon nilDataCon [] [elt_ty] [] + nil_expr = mkNilExpr elt_ty \end{code} %************************************************************************ @@ -112,23 +112,130 @@ 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. +deListComp :: [TypecheckedStmt] + -> CoreExpr -> CoreExpr -- Cons and nil resp; can be copied freely + -> DsM CoreExpr + +deListComp [ReturnStmt expr] cons nil + = dsExpr expr `thenDs` \ expr' -> + returnDs (mkApps cons [expr', nil]) + +deListComp (GuardStmt guard locn : quals) cons nil + = dsExpr guard `thenDs` \ guard' -> + deListComp quals cons nil `thenDs` \ rest' -> + returnDs (mkIfThenElse guard' rest' nil) + +deListComp (LetStmt binds : quals) cons nil + = deListComp quals cons nil `thenDs` \ rest' -> + dsLet binds rest' + +deListComp (BindStmt pat list locn : quals) cons nil + = dsExpr list `thenDs` \ list' -> + let + pat_ty = outPatType pat + nil_ty = coreExprType nil + in + newSysLocalsDs [pat_ty, nil_ty] `thenDs` \ [x,ys] -> + + dsListComp quals cons (Var ys) `thenDs` \ rest -> + matchSimply (Var x) ListCompMatch pat + rest (Var ys) `thenDs` \ core_match -> + bindNonRecDs (mkLams [x,ys] fn_body) $ \ fn -> + dsListExpr list (Var fn) nil + + +data FExpr = FEOther CoreExpr -- Default case + | FECons -- cons + | FEConsComposedWith CoreExpr -- (cons . e) + | FENil -- nil + +feComposeWith FECons g + = returnDs (FEConsComposedWith g) + +feComposeWith (FEOther f) g + = composeWith f f `thenDs` \ h -> + returnDs (FEOther h) + +feComposeWith (FEConsComposedWith f) g + = composeWith f f `thenDs` \ h -> + returnDs (FEConsComposedWith h) + + +composeWith f g + = newSysLocalDs arg_ty `thenDs` \ x -> + returnDs (Lam x (App e (App f (Var x)))) + where + arg_ty = case splitFunTy_maybe (coreExprType g) of + Just (arg_ty,_) -> arg_ty + other -> panic "feComposeWith" + +deListExpr :: TypecheckedHsExpr + -> FExpr -> FExpr -- Cons and nil expressions + -> DsM CoreExpr + +deListExpr cons nil (HsDoOut ListComp stmts _ _ _ result_ty src_loc) + = deListComp stmts cons nil + +deListExpr cons nil (HsVar map, _, [f,xs]) + | goodInst var mapIdKey = dsExpr f `thenDs` \ f' -> + feComposeWith cons f' `thenDs` \ cons' -> + in + deListExpr xs cons' nil + + +data HsExprForm = GoodForm What [Type] [TypecheckedHsExpr] + | BadForm + +data What = HsMap | HsConcat | HsFilter | HsZip | HsFoldr + +analyseListProducer (HsVar v) ty_args val_args + | good_inst mapIdKey 2 = GoodForm HsMap ty_args val_args + | good_inst concatIdKey 1 = GoodForm HsConcat ty_args val_args + | good_inst filterIdKey 2 = GoodForm HsFilter ty_args val_args + | good_id zipIdKey 2 = GoodForm HsZip ty_args val_args + | otherwise = + where + good_inst key arity = isInstIdOf key v && result_is_list && n_args == arity + good_id key arity = getUnique v == key && result_is_list && n_args == arity + + n_args :: Int + n_args = length val_args + + result_is_list = resultTyIsList (idType v) ty_args val_args + +resultTyIsList ty ty_args val_args + = go ty ty_args + where + go1 ty (_:tys) = case splitForAllTy_maybe ty of + Just (_,ty) -> go1 ty tys + Nothing -> False + go1 ty [] = go2 ty val_args + + go2 ty (_:args) = case splitFunTy_maybe of + Just (_,ty) -> go2 ty args + Nothing -> False + + go2 ty [] = case splitTyConApp_maybe of + Just (tycon, [_]) | tycon == listTyCon -> True + other -> False + + \begin{code} deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above = dsExpr expr `thenDs` \ core_expr -> - mkConDs consDataCon [TyArg (coreExprType core_expr), VarArg core_expr, VarArg list] + returnDs (mkConApp consDataCon [Type (coreExprType core_expr), core_expr, list]) deListComp (GuardStmt guard locn : quals) list -- rule B above = dsExpr guard `thenDs` \ core_guard -> deListComp quals list `thenDs` \ core_rest -> - returnDs (mkCoreIfThenElse core_guard core_rest list) + returnDs (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] deListComp (LetStmt binds : quals) list - = dsBinds binds `thenDs` \ core_binds -> - deListComp quals list `thenDs` \ core_rest -> - returnDs (mkCoLetsAny core_binds core_rest) + = 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 -> @@ -144,23 +251,19 @@ deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty] `thenDs` \ [h, u1, u2, u3] -> -- the "fail" value ... - mkAppDs (Var h) [VarArg (Var u3)] `thenDs` \ core_fail -> + 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) pat res_ty + matchSimply (Var u2) ListCompMatch pat rest_expr core_fail `thenDs` \ core_match -> - mkAppDs (Var h) [VarArg 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 - ) + let + rhs = Lam u1 $ + Case (Var u1) u1 [(DataCon nilDataCon, [], core_list2), + (DataCon consDataCon, [u2, u3], core_match)] + in + returnDs (Let (Rec [(h, rhs)]) letrec_body) \end{code} %************************************************************************ @@ -185,18 +288,17 @@ dfListComp :: Type -> Id -- 'c'; its type and id dfListComp c_ty c_id n_ty n_id [ReturnStmt expr] = dsExpr expr `thenDs` \ core_expr -> - mkAppDs (Var c_id) [VarArg core_expr, VarArg (Var n_id)] + returnDs (mkApps (Var c_id) [core_expr, Var n_id]) dfListComp c_ty c_id n_ty n_id (GuardStmt guard locn : quals) = dsExpr guard `thenDs` \ core_guard -> dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> - returnDs (mkCoreIfThenElse core_guard core_rest (Var n_id)) + returnDs (mkIfThenElse core_guard core_rest (Var n_id)) dfListComp c_ty c_id n_ty n_id (LetStmt binds : quals) -- new in 1.3, local bindings - = dsBinds binds `thenDs` \ core_binds -> - dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> - returnDs (mkCoLetsAny core_binds core_rest) + = dfListComp c_ty c_id n_ty n_id quals `thenDs` \ core_rest -> + dsLet binds core_rest dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals) -- evaluate the two lists @@ -219,17 +321,47 @@ dfListComp c_ty c_id n_ty n_id (BindStmt pat list1 locn : quals) dfListComp 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 p) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return returnDs ( - mkCoLetsAny - [NonRec fn (mkValLam [p, b] core_expr), + mkLets + [NonRec fn (mkLams [p, b] core_expr), NonRec lst core_list1] (mkFoldr p_ty n_ty fn n_id lst) ) +\end{code} + + +@mkBuild@ is sugar for building a build! + +@mkbuild ty tv c n e@ $Rightarrow$ @build ty (/\ tv -> \ c n -> e)@ +@ty@ is the type of the list. +@tv@ is always a new type variable. +@c,n@ are Id's for the abstract cons and nil, @g@ for let binding the argument argument. + c :: a -> b -> b + n :: b + v :: (\/ b . (a -> b -> b) -> b -> b) -> [a] +-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] +@e@ is the object right inside the @build@ + +\begin{code} +mkBuild :: Type + -> TyVar + -> Id + -> Id + -> Id + -> CoreExpr -- template + -> CoreExpr -- template + +mkBuild ty tv c n g expr + = Let (NonRec g (mkLams [tv, c,n] expr)) + (mkApps (Var buildId) [Type ty, Var g]) + +buildId = error "DsListComp: buildId" mkFoldr a b f z xs - = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs] + = mkApps (mkTyApps (Var foldrId) [a,b]) [Var f, Var z, Var xs] \end{code} +