DsListComp.lhs 7.44 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 4 5 6 7 8
%
\section[DsListComp]{Desugaring list comprehensions}

\begin{code}
module DsListComp ( dsListComp ) where

9 10
import Ubiq
import DsLoop		-- break dsExpr-ish loop
11

12
import HsSyn		( Qual(..), HsExpr, HsBinds )
13
import TcHsSyn		( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) )
14 15
import DsHsSyn		( outPatType )
import CoreSyn
16

17
import DsMonad		-- the monadery used in the desugarer
18
import DsUtils
19 20 21 22 23 24 25 26

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 )
27
import Match		( matchSimply )
28
import Util		( panic )
29 30 31 32 33 34 35 36 37
\end{code}

List comprehensions may be desugared in one of two ways: ``ordinary''
(as you would expect if you read SLPJ's book) and ``with foldr/build
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}
38
dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
39 40

dsListComp expr quals
41 42
  = let
	expr_ty = coreExprType expr
43
    in
44 45 46 47
    if not opt_FoldrBuildOn then -- be boring
	deListComp expr quals (nIL_EXPR expr_ty)

    else -- foldr/build lives!
48 49
	new_alpha_tyvar		    `thenDs` \ (n_tyvar, n_ty) ->
	let
50 51 52 53 54
	    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))
55
	in
56
	newSysLocalsDs [c_ty,n_ty,g_ty]  `thenDs` \ [c, n, g] ->
57 58

	dfListComp expr expr_ty
59
			c_ty c
60 61 62 63 64
			n_ty n
			quals	    `thenDs` \ result ->

	returnDs (mkBuild expr_ty n_tyvar c n g result)
  where
65
    nIL_EXPR ty = mkCon nilDataCon [] [ty] []
66

67
    new_alpha_tyvar :: DsM (TyVar, Type)
68
    new_alpha_tyvar
69
      = newTyVarsDs [alphaTyVar]    `thenDs` \ [new_ty] ->
70
	returnDs (new_ty, mkTyVarTy new_ty)
71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
\end{code}

%************************************************************************
%*									*
\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
%*									*
%************************************************************************

Just as in Phil's chapter~7 in SLPJ, using the rules for
optimally-compiled list comprehensions.  This is what Kevin followed
as well, and I quite happily do the same.  The TQ translation scheme
transforms a list of qualifiers (either boolean expressions or
generators) into a single expression which implements the list
comprehension.  Because we are generating 2nd-order polymorphic
lambda-calculus, calls to NIL and CONS must be applied to a type
argument, as well as their usual value arguments.
\begin{verbatim}
TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>

(Rule C)
TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>

(Rule B)
TQ << [ e | b , qs ] ++ L >> =
    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>

(Rule A')
TQ << [ e | p <- L1, qs ]  ++  L2 >> =
  letrec
    h = \ u1 ->
    	  case u1 of
	    []        ->  TE << L2 >>
	    (u2 : u3) ->
		  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
		    [] (h u3)
  in
    h ( TE << L1 >> )

"h", "u1", "u2", and "u3" are new variables.
\end{verbatim}

@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
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}
117
deListComp :: CoreExpr -> [TypecheckedQual] -> CoreExpr -> DsM CoreExpr
118 119

deListComp expr [] list		-- Figure 7.4, SLPJ, p 135, rule C above
120
  = mkConDs consDataCon [coreExprType expr] [expr, list]
121

122
deListComp expr (FilterQual filt : quals) list	-- rule B above
123 124 125 126
  = dsExpr filt                `thenDs` \ core_filt ->
    deListComp expr quals list `thenDs` \ core_rest ->
    returnDs ( mkCoreIfThenElse core_filt core_rest list )

127 128 129
deListComp expr (LetQual binds : quals) list
  = panic "deListComp:LetQual"

130 131 132
deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
  = dsExpr list1		    `thenDs` \ core_list1 ->
    let
133
	u3_ty@u1_ty = coreExprType core_list1	-- two names, same thing
134 135

	-- u1_ty is a [alpha] type, and u2_ty = alpha
136 137 138 139
	u2_ty = outPatType pat

	res_ty = coreExprType core_list2
	h_ty = mkFunTys [u1_ty] res_ty
140 141 142 143 144 145 146 147 148 149
    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.
    -}
    let
	h = if False -- LATER: sw_chkr DoDeforest???
150 151
	    then panic "deListComp:deforest"
		 -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
152 153 154
	    else h'
    in
    -- the "fail" value ...
155
    mkAppDs (Var h) [] [Var u3]  `thenDs` \ core_fail ->
156 157 158

    deListComp expr quals core_fail `thenDs` \ rest_expr ->

159
    matchSimply (Var u2) pat res_ty rest_expr core_fail `thenDs` \ core_match ->
160

161
    mkAppDs (Var h) [] [core_list1]  `thenDs` \ letrec_body ->
162 163 164 165

    returnDs (
      mkCoLetrecAny [
      ( h,
166 167 168
	(Lam (ValBinder u1)
	 (Case (Var u1)
	    (AlgAlts
169 170
	      [(nilDataCon,  [], core_list2),
	       (consDataCon, [u2, u3], core_match)]
171
	    NoDefault)))
172 173 174 175 176 177 178 179 180 181 182 183 184 185
      )] letrec_body
    )
\end{code}

%************************************************************************
%*									*
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
%*									*
%************************************************************************

@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
186 187
TE << [ e | p <- l , q ] c n =  foldr
			(\ TE << p >> b -> TE << [ e | q ] >> c b
188 189 190
			   _          b  -> b)	n l
\end{verbatim}
\begin{code}
191 192 193 194
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
195
	   -> [TypecheckedQual] 	-- the rest of the qual's
196
	   -> DsM CoreExpr
197

198 199
dfListComp expr expr_ty c_ty c_id n_ty n_id []
  = mkAppDs (Var c_id) [] [expr, Var n_id]
200

201
dfListComp expr expr_ty c_ty c_id n_ty n_id (FilterQual filt : quals)
202 203 204
  = dsExpr filt                			`thenDs` \ core_filt ->
    dfListComp expr expr_ty c_ty c_id n_ty n_id quals
						`thenDs` \ core_rest ->
205
    returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
206

207 208 209 210
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)
211 212 213 214 215
    -- evaluate the two lists
  = dsExpr list1				`thenDs` \ core_list1 ->

    -- find the required type

216 217 218 219
    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
220 221 222 223 224 225 226 227 228 229 230
    in

    -- create some new local id's

    newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty]		`thenDs` \ [b,p,fn,lst] ->

    -- build rest of the comprehesion

    dfListComp expr expr_ty c_ty c_id b_ty b quals	`thenDs` \ core_rest ->
    -- build the pattern match

231
    matchSimply (Var p) pat b_ty core_rest (Var b)	`thenDs` \ core_expr ->
232 233 234 235 236

    -- now build the outermost foldr, and return

    returnDs (
      mkCoLetsAny
237 238
	[NonRec fn (mkValLam [p, b] core_expr),
	 NonRec lst core_list1]
239 240 241
	(mkFoldr p_ty n_ty fn n_id lst)
    )

242 243 244
mkFoldr a b f z xs
  = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
\end{code}