ghc/compiler/deSugar/DsListComp.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DsListComp]{Desugaring list comprehensions}
   5
   6 \begin{code}
   7 module DsListComp ( dsListComp ) where
   8
   9 import Ubiq
  10 import DsLoop           -- break dsExpr-ish loop
  11
  12 import HsSyn            ( Qual(..), HsExpr, HsBinds )
  13 import TcHsSyn          ( TypecheckedQual(..), TypecheckedHsExpr(..) )
  14 import DsHsSyn          ( outPatType )
  15 import CoreSyn
  16
  17 import DsMonad          -- the monadery used in the desugarer
  18 import DsUtils
  19
  20 import CmdLineOpts      ( opt_FoldrBuildOn )
  21 import CoreUtils        ( coreExprType, mkCoreIfThenElse )
  22 import PrelInfo         ( nilDataCon, consDataCon, listTyCon,
  23                           mkBuild, foldrId )
  24 import Type             ( mkTyVarTy, mkForAllTy, mkFunTys )
  25 import TysPrim          ( alphaTy )
  26 import TyVar            ( alphaTyVar )
  27 import Match            ( matchSimply )
  28 import Util             ( panic )
  29 \end{code}
  30
  31 List comprehensions may be desugared in one of two ways: ``ordinary''
  32 (as you would expect if you read SLPJ's book) and ``with foldr/build
  33 turned on'' (if you read Gill {\em et al.}'s paper on the subject).
  34
  35 There will be at least one ``qualifier'' in the input.
  36
  37 \begin{code}
  38 dsListComp :: CoreExpr -> [TypecheckedQual] -> DsM CoreExpr
  39
  40 dsListComp expr quals
  41   = let
  42         expr_ty = coreExprType expr
  43     in
  44     if not opt_FoldrBuildOn then -- be boring
  45         deListComp expr quals (nIL_EXPR expr_ty)
  46
  47     else -- foldr/build lives!
  48         new_alpha_tyvar             `thenDs` \ (n_tyvar, n_ty) ->
  49         let
  50             alpha_to_alpha = mkFunTys [alphaTy] alphaTy
  51
  52             c_ty = mkFunTys [expr_ty, n_ty] n_ty
  53             g_ty = mkForAllTy alphaTyVar (
  54                         (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                         n_ty n
  61                         quals       `thenDs` \ result ->
  62
  63         returnDs (mkBuild expr_ty n_tyvar c n g result)
  64   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 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 Just as in Phil's chapter~7 in SLPJ, using the rules for
  80 optimally-compiled list comprehensions.  This is what Kevin followed
  81 as well, and I quite happily do the same.  The TQ translation scheme
  82 transforms a list of qualifiers (either boolean expressions or
  83 generators) into a single expression which implements the list
  84 comprehension.  Because we are generating 2nd-order polymorphic
  85 lambda-calculus, calls to NIL and CONS must be applied to a type
  86 argument, as well as their usual value arguments.
  87 \begin{verbatim}
  88 TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
  89
  90 (Rule C)
  91 TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
  92
  93 (Rule B)
  94 TQ << [ e | b , qs ] ++ L >> =
  95     if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
  96
  97 (Rule A')
  98 TQ << [ e | p <- L1, qs ]  ++  L2 >> =
  99   letrec
 100     h = \ u1 ->
 101           case u1 of
 102             []        ->  TE << L2 >>
 103             (u2 : u3) ->
 104                   (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
 105                     [] (h u3)
 106   in
 107     h ( TE << L1 >> )
 108
 109 "h", "u1", "u2", and "u3" are new variables.
 110 \end{verbatim}
 111
 112 @deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
 113 is the TE translation scheme.  Note that we carry around the @L@ list
 114 already desugared.  @dsListComp@ does the top TE rule mentioned above.
 115
 116 \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   = dsExpr filt                `thenDs` \ core_filt ->
 124     deListComp expr quals list `thenDs` \ core_rest ->
 125     returnDs ( mkCoreIfThenElse core_filt core_rest list )
 126
 127 deListComp expr (LetQual binds : quals) list
 128   = panic "deListComp:LetQual"
 129
 130 deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
 131   = dsExpr list1                    `thenDs` \ core_list1 ->
 132     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         u2_ty = outPatType pat
 137
 138         res_ty = coreExprType core_list2
 139         h_ty = mkFunTys [u1_ty] res_ty
 140     in
 141     newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
 142                                     `thenDs` \ [h', u1, u2, u3] ->
 143     {-
 144        Make the function h unfoldable by the deforester.
 145        Since it only occurs once in the body, we can't get
 146        an increase in code size by unfolding it.
 147     -}
 148     let
 149         h = if False -- LATER: sw_chkr DoDeforest???
 150             then panic "deListComp:deforest"
 151                  -- replaceIdInfo h' (addInfo (getIdInfo h') DoDeforest)
 152             else h'
 153     in
 154     -- the "fail" value ...
 155     mkAppDs (Var h) [] [Var u3]  `thenDs` \ core_fail ->
 156
 157     deListComp expr quals core_fail `thenDs` \ rest_expr ->
 158
 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     returnDs (
 164       mkCoLetrecAny [
 165       ( h,
 166         (Lam (ValBinder u1)
 167          (Case (Var u1)
 168             (AlgAlts
 169               [(nilDataCon,  [], core_list2),
 170                (consDataCon, [u2, u3], core_match)]
 171             NoDefault)))
 172       )] letrec_body
 173     )
 174 \end{code}
 175
 176 %************************************************************************
 177 %*                                                                      *
 178 \subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
 179 %*                                                                      *
 180 %************************************************************************
 181
 182 @dfListComp@ are the rules used with foldr/build turned on:
 183 \begin{verbatim}
 184 TE < [ e | ] >>          c n = c e n
 185 TE << [ e | b , q ] >>   c n = if b then TE << [ e | q ] >> c n else n
 186 TE << [ e | p <- l , q ] c n =  foldr
 187                         (\ TE << p >> b -> TE << [ e | q ] >> c b
 188                            _          b  -> b)  n l
 189 \end{verbatim}
 190 \begin{code}
 191 dfListComp :: CoreExpr          -- the inside of the comp
 192            -> Type                      -- the type of the inside
 193            -> Type -> Id                -- 'c'; its type and id
 194            -> Type -> Id                -- 'n'; its type and id
 195            -> [TypecheckedQual]         -- the rest of the qual's
 196            -> DsM CoreExpr
 197
 198 dfListComp expr expr_ty c_ty c_id n_ty n_id []
 199   = 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   = dsExpr filt                                 `thenDs` \ core_filt ->
 203     dfListComp expr expr_ty c_ty c_id n_ty n_id quals
 204                                                 `thenDs` \ core_rest ->
 205     returnDs (mkCoreIfThenElse core_filt core_rest (Var n_id))
 206
 207 dfListComp expr expr_ty c_ty c_id n_ty n_id (LetQual binds : quals)
 208   = panic "dfListComp:LetQual"
 209
 210 dfListComp expr expr_ty c_ty c_id n_ty n_id (GeneratorQual pat list1 : quals)
 211     -- evaluate the two lists
 212   = dsExpr list1                                `thenDs` \ core_list1 ->
 213
 214     -- find the required type
 215
 216     let p_ty   = outPatType pat
 217         b_ty   = n_ty           -- alias b_ty to n_ty
 218         fn_ty  = mkFunTys [p_ty, b_ty] b_ty
 219         lst_ty = coreExprType core_list1
 220     in
 221
 222     -- create some new local id's
 223
 224     newSysLocalsDs [b_ty,p_ty,fn_ty,lst_ty]             `thenDs` \ [b,p,fn,lst] ->
 225
 226     -- build rest of the comprehesion
 227
 228     dfListComp expr expr_ty c_ty c_id b_ty b quals      `thenDs` \ core_rest ->
 229     -- build the pattern match
 230
 231     matchSimply (Var p) pat b_ty core_rest (Var b)      `thenDs` \ core_expr ->
 232
 233     -- now build the outermost foldr, and return
 234
 235     returnDs (
 236       mkCoLetsAny
 237         [NonRec fn (mkValLam [p, b] core_expr),
 238          NonRec lst core_list1]
 239         (mkFoldr p_ty n_ty fn n_id lst)
 240     )
 241
 242 mkFoldr a b f z xs
 243   = mkValApp (mkTyApp (Var foldrId) [a,b]) [VarArg f, VarArg z, VarArg xs]
 244 \end{code}