X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FdeSugar%2FDsListComp.lhs;h=39b00d4a2c676b233f3b4f37453860bf83f673a5;hb=6c381e873e222417d9a67aeec77b9555eca7b7a8;hp=51748b61357500c36353e3e2a7e104eb8473fa27;hpb=8147a9f0bcc48ef0db1e91f8b985a4f5c3fed560;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs
index 51748b6..39b00d4 100644
--- a/ghc/compiler/deSugar/DsListComp.lhs
+++ b/ghc/compiler/deSugar/DsListComp.lhs
@@ -1,29 +1,31 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[DsListComp]{Desugaring list comprehensions}
 
 \begin{code}
 module DsListComp ( dsListComp ) where
 
+import Ubiq
+import DsLoop		-- break dsExpr-ish loop
 
-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 HsSyn		( Qual(..), HsExpr, HsBinds )
+import TcHsSyn		( TypecheckedQual(..), TypecheckedHsExpr(..) )
+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	( coreExprType, mkCoreIfThenElse )
+import PrelInfo		( nilDataCon, consDataCon, listTyCon,
+			  mkBuild, foldrId )
+import Type		( mkTyVarTy, mkForAllTy, mkFunTys )
+import TysPrim		( alphaTy )
+import TyVar		( alphaTyVar )
 import Match		( matchSimply )
-import Util
+import Util		( panic )
 \end{code}
 
 List comprehensions may be desugared in one of two ways: ``ordinary''
@@ -33,37 +35,38 @@ 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 :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
 
 dsListComp expr quals
-  = let  expr_ty    = typeOfCoreExpr expr
+  = let
+	expr_ty = coreExprType expr
     in
-    ifSwitchSetDs FoldrBuildOn (
+    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
-	    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))
+	    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] -> 
+	newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] ->
 
 	dfListComp expr expr_ty
-			c_ty c 
+			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] []
+    nIL_EXPR ty = mkCon nilDataCon [] [ty] []
 
-    new_alpha_tyvar :: DsM (TyVar, UniType)
+    new_alpha_tyvar :: DsM (TyVar, Type)
     new_alpha_tyvar
-      = newTyVarsDs [alpha_tv]	`thenDs` \ [new_ty] ->
+      = newTyVarsDs [alphaTyVar]    `thenDs` \ [new_ty] ->
 	returnDs (new_ty,mkTyVarTy new_ty)
 \end{code}
 
@@ -111,26 +114,29 @@ 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
+deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
 
 deListComp expr [] list		-- Figure 7.4, SLPJ, p 135, rule C above
-  = mkCoConDs consDataCon [typeOfCoreExpr expr] [expr, list]
+  = mkConDs consDataCon [coreExprType expr] [expr, list]
 
-deListComp expr ((FilterQual filt): quals) list	-- rule B above
+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 expr (LetQual binds : quals) list
+  = panic "deListComp:LetQual"
+
 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
+	u3_ty@u1_ty = coreExprType core_list1	-- two names, same thing
 
 	-- 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
+	u2_ty = outPatType pat
+
+	res_ty = coreExprType core_list2
+	h_ty = mkFunTys [u1_ty] res_ty
     in
     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 				    `thenDs` \ [h', u1, u2, u3] ->
@@ -139,30 +145,30 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
        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)
+	    then panic "deListComp:deforest"
+		 -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
 	    else h'
     in
     -- the "fail" value ...
-    mkCoAppDs (CoVar h) (CoVar u3)  `thenDs` \ core_fail ->
+    mkAppDs (Var h) [] [Var u3]  `thenDs` \ core_fail ->
 
     deListComp expr quals core_fail `thenDs` \ rest_expr ->
 
-    matchSimply (CoVar u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
+    matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
 
-    mkCoAppDs (CoVar h) core_list1  `thenDs` \ letrec_body ->
+    mkAppDs (Var h) [] [core_list1]  `thenDs` \ letrec_body ->
 
     returnDs (
       mkCoLetrecAny [
       ( h,
-	(CoLam [ u1 ]
-	 (CoCase (CoVar u1)
-	    (CoAlgAlts
+	(Lam (ValBinder u1)
+	 (Case (Var u1)
+	    (AlgAlts
 	      [(nilDataCon,  [], core_list2),
 	       (consDataCon, [u2, u3], core_match)]
-	    CoNoDefault)))
+	    NoDefault)))
       )] letrec_body
     )
 \end{code}
@@ -177,38 +183,40 @@ deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
 \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 
+TE << [ e | p <- l , q ] c n =  foldr
+			(\ TE << p >> b -> TE << [ e | q ] >> c b
 			   _          b  -> b)	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
+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
-	   -> DsM PlainCoreExpr
+	   -> DsM CoreExpr
 
-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 []
+  = mkAppDs (Var c_id) [] [expr, Var n_id]
 
-dfListComp expr expr_ty c_ty c_id n_ty n_id ((FilterQual filt) : quals)
+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))
+    returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
 
-dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals)
+dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
+  = panic "dfListComp:LetQual"
+
+dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : 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 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
     in
 
     -- create some new local id's
@@ -220,15 +228,17 @@ dfListComp expr expr_ty c_ty c_id n_ty n_id ((GeneratorQual pat list1):quals)
     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 p) pat b_ty core_rest (Var b)	`thenDs` \ core_expr ->
 
     -- now build the outermost foldr, and return
 
     returnDs (
       mkCoLetsAny
-	[CoNonRec fn (CoLam [p,b] core_expr),
-	 CoNonRec lst core_list1]
+	[NonRec fn (mkValLam [p, b] core_expr),
+	 NonRec lst core_list1]
 	(mkFoldr p_ty n_ty fn n_id lst)
     )
-\end{code}
 
+mkFoldr a b f z xs
+  = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
+\end{code}