ghc/compiler/rename/RenameExpr4.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[RenameExpr]{Renaming of expressions}
   5
   6 Basically dependency analysis.
   7
   8 Handles @Match@, @GRHSsAndBinds@, @Expr@, and @Qual@ datatypes.  In
   9 general, all of these functions return a renamed thing, and a set of
  10 free variables.
  11
  12 \begin{code}
  13 #include "HsVersions.h"
  14
  15 module RenameExpr4 (
  16         rnMatch4, rnGRHSsAndBinds4, rnPat4,
  17
  18         -- and to make the interface self-sufficient...
  19         Bag, GRHSsAndBinds, InPat, Name, Maybe,
  20         ProtoName, GlobalNameFun(..), UniqSet(..), UniqFM, SrcLoc,
  21         Unique, SplitUniqSupply,
  22         Pretty(..), PprStyle, PrettyRep
  23    ) where
  24
  25 import AbsSyn
  26 import NameTypes        ( FullName )
  27 import Outputable
  28 import ProtoName        ( ProtoName(..) )
  29 import Rename4          ( rnPolyType4 )
  30 import RenameAuxFuns    ( GlobalNameFuns(..) ) -- ToDo: rm this line
  31 import RenameBinds4     ( rnBinds4, FreeVars(..) )
  32 import RenameMonad4
  33 import UniqSet
  34 import Util
  35 \end{code}
  36
  37
  38 *********************************************************
  39 *                                                       *
  40 \subsection{Patterns}
  41 *                                                       *
  42 *********************************************************
  43
  44 \begin{code}
  45 rnPat4 ::  ProtoNamePat -> Rn4M RenamedPat
  46
  47 rnPat4  WildPatIn = returnRn4 WildPatIn
  48
  49 rnPat4 (VarPatIn name)
  50   = lookupValue name    `thenRn4` \ vname ->
  51     returnRn4 (VarPatIn vname)
  52
  53 rnPat4  (LitPatIn n) = returnRn4 (LitPatIn n)
  54
  55 rnPat4  (LazyPatIn pat)
  56   = rnPat4  pat `thenRn4` \ pat' ->
  57     returnRn4 (LazyPatIn pat')
  58
  59 rnPat4  (AsPatIn name pat)
  60   = rnPat4  pat `thenRn4` \ pat' ->
  61     lookupValue name    `thenRn4` \ vname ->
  62     returnRn4 (AsPatIn vname pat')
  63
  64 rnPat4 (ConPatIn name pats)
  65   = lookupValue name        `thenRn4` \ name' ->
  66     mapRn4 rnPat4 pats  `thenRn4` \ patslist ->
  67     returnRn4 (ConPatIn name' patslist)
  68
  69 rnPat4  (ConOpPatIn pat1 name pat2)
  70   = lookupValue name    `thenRn4` \ name' ->
  71     rnPat4  pat1        `thenRn4` \ pat1' ->
  72     rnPat4  pat2        `thenRn4` \ pat2' ->
  73     returnRn4 (ConOpPatIn pat1' name' pat2')
  74
  75 rnPat4  (ListPatIn pats)
  76   = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
  77     returnRn4 (ListPatIn patslist)
  78
  79 rnPat4  (TuplePatIn pats)
  80   = mapRn4 rnPat4 pats `thenRn4` \ patslist ->
  81     returnRn4 (TuplePatIn patslist)
  82
  83 rnPat4  (NPlusKPatIn name lit)
  84   = lookupValue name    `thenRn4` \ vname ->
  85     returnRn4 (NPlusKPatIn vname lit)
  86
  87 #ifdef DPH
  88 rnPat4  (ProcessorPatIn pats pat)
  89   = mapRn4 rnPat4 pats  `thenRn4` \ pats' ->
  90     rnPat4 pat      `thenRn4` \ pat'  ->
  91     returnRn4 (ProcessorPatIn pats' pat')
  92 #endif {- Data Parallel Haskell -}
  93 \end{code}
  94
  95 ************************************************************************
  96 *                                                                       *
  97 \subsection{Match}
  98 *                                                                       *
  99 ************************************************************************
 100
 101 \begin{code}
 102 rnMatch4 :: ProtoNameMatch -> Rn4M (RenamedMatch, FreeVars)
 103
 104 rnMatch4 match
 105   = getSrcLocRn4                        `thenRn4` \ src_loc ->
 106     namesFromProtoNames "variable in pattern"
 107          (binders `zip` repeat src_loc) `thenRn4` \ new_binders ->
 108     extendSS2 new_binders (rnMatch4_aux match)
 109   where
 110     binders = collect_binders match
 111
 112     collect_binders :: ProtoNameMatch -> [ProtoName]
 113
 114     collect_binders (GRHSMatch _) = []
 115     collect_binders (PatMatch pat match)
 116       = collectPatBinders pat ++ collect_binders match
 117
 118 rnMatch4_aux (PatMatch pat match)
 119   = rnPat4 pat          `thenRn4` \ pat' ->
 120     rnMatch4_aux match  `thenRn4` \ (match', fvMatch) ->
 121     returnRn4 (PatMatch pat' match', fvMatch)
 122
 123 rnMatch4_aux (GRHSMatch grhss_and_binds)
 124   = rnGRHSsAndBinds4 grhss_and_binds `thenRn4` \ (grhss_and_binds', fvs) ->
 125     returnRn4 (GRHSMatch grhss_and_binds', fvs)
 126 \end{code}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsubsection[dep-GRHSs]{Guarded right-hand sides (GRHSsAndBinds)}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 rnGRHSsAndBinds4 :: ProtoNameGRHSsAndBinds -> Rn4M (RenamedGRHSsAndBinds, FreeVars)
 136
 137 rnGRHSsAndBinds4 (GRHSsAndBindsIn grhss binds)
 138   = rnBinds4 binds                      `thenRn4` \ (binds', fvBinds, scope) ->
 139     extendSS2 scope (rnGRHSs4 grhss)    `thenRn4` \ (grhss', fvGRHS) ->
 140     returnRn4 (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
 141   where
 142     rnGRHSs4 [] = returnRn4 ([], emptyUniqSet)
 143
 144     rnGRHSs4 (grhs:grhss)
 145       = rnGRHS4  grhs   `thenRn4` \ (grhs',  fvs) ->
 146         rnGRHSs4 grhss  `thenRn4` \ (grhss', fvss) ->
 147         returnRn4 (grhs' : grhss', fvs `unionUniqSets` fvss)
 148
 149     rnGRHS4 (GRHS guard expr locn)
 150       = pushSrcLocRn4 locn                                (
 151         rnExpr4 guard   `thenRn4` \ (guard', fvsg) ->
 152         rnExpr4 expr    `thenRn4` \ (expr',  fvse) ->
 153         returnRn4 (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
 154         )
 155
 156     rnGRHS4 (OtherwiseGRHS expr locn)
 157       = pushSrcLocRn4 locn                                (
 158         rnExpr4 expr    `thenRn4` \ (expr', fvs) ->
 159         returnRn4 (OtherwiseGRHS expr' locn, fvs)
 160         )
 161 \end{code}
 162
 163 %************************************************************************
 164 %*                                                                      *
 165 \subsubsection[dep-Expr]{Expressions}
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 \begin{code}
 170 rnExprs4 :: [ProtoNameExpr] -> Rn4M ([RenamedExpr], FreeVars)
 171
 172 rnExprs4 [] = returnRn4 ([], emptyUniqSet)
 173
 174 rnExprs4 (expr:exprs)
 175   = rnExpr4 expr        `thenRn4` \ (expr', fvExpr) ->
 176     rnExprs4 exprs      `thenRn4` \ (exprs', fvExprs) ->
 177     returnRn4 (expr':exprs', fvExpr `unionUniqSets` fvExprs)
 178 \end{code}
 179
 180 Variables. We look up the variable and return the resulting name.  The
 181 interesting question is what the free-variable set should be.  We
 182 don't want to return imported or prelude things as free vars.  So we
 183 look at the Name returned from the lookup, and make it part of the
 184 free-var set iff:
 185 \begin{itemize}
 186 \item
 187 if it's a @Short@,
 188 \item
 189 or it's an @OtherTopId@ and it's defined in this module
 190 (this includes locally-defined constructrs, but that's too bad)
 191 \end{itemize}
 192
 193 \begin{code}
 194 rnExpr4 :: ProtoNameExpr -> Rn4M (RenamedExpr, FreeVars)
 195
 196 rnExpr4 (Var v)
 197   = lookupValue v               `thenRn4` \ vname ->
 198     returnRn4 (Var vname, fv_set vname)
 199   where
 200     fv_set n@(Short uniq sname)     = singletonUniqSet n
 201     fv_set n@(OtherTopId uniq fname)
 202           | isLocallyDefined fname
 203           && not (isConop (getOccurrenceName fname))
 204                                     = singletonUniqSet n
 205     fv_set other                    = emptyUniqSet
 206
 207 rnExpr4 (Lit lit)  = returnRn4 (Lit lit, emptyUniqSet)
 208
 209 rnExpr4 (Lam match)
 210   = rnMatch4 match      `thenRn4` \ (match', fvMatch) ->
 211     returnRn4 (Lam match', fvMatch)
 212
 213 rnExpr4 (App fun arg)
 214   = rnExpr4 fun `thenRn4` \ (fun',fvFun) ->
 215     rnExpr4 arg `thenRn4` \ (arg',fvArg) ->
 216     returnRn4 (App fun' arg', fvFun `unionUniqSets` fvArg)
 217
 218 rnExpr4 (OpApp e1 op e2)
 219   = rnExpr4 e1  `thenRn4` \ (e1', fvs_e1) ->
 220     rnExpr4 op  `thenRn4` \ (op', fvs_op) ->
 221     rnExpr4 e2  `thenRn4` \ (e2', fvs_e2) ->
 222     returnRn4 (OpApp e1' op' e2', (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
 223
 224 rnExpr4 (SectionL expr op)
 225   = rnExpr4 expr         `thenRn4` \ (expr', fvs_expr) ->
 226     rnExpr4 op   `thenRn4` \ (op', fvs_op) ->
 227     returnRn4 (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
 228
 229 rnExpr4 (SectionR op expr)
 230   = rnExpr4 op   `thenRn4` \ (op',   fvs_op) ->
 231     rnExpr4 expr         `thenRn4` \ (expr', fvs_expr) ->
 232     returnRn4 (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
 233
 234 rnExpr4 (CCall fun args may_gc is_casm fake_result_ty)
 235   = rnExprs4 args        `thenRn4` \ (args', fvs_args) ->
 236     returnRn4 (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 237
 238 rnExpr4 (SCC label expr)
 239   = rnExpr4 expr         `thenRn4` \ (expr', fvs_expr) ->
 240     returnRn4 (SCC label expr', fvs_expr)
 241
 242 rnExpr4 (Case expr ms)
 243   = rnExpr4 expr                 `thenRn4` \ (new_expr, e_fvs) ->
 244     mapAndUnzipRn4 rnMatch4 ms   `thenRn4` \ (new_ms, ms_fvs) ->
 245     returnRn4 (Case new_expr new_ms, unionManyUniqSets (e_fvs : ms_fvs))
 246
 247 rnExpr4 (ListComp expr quals)
 248   = rnQuals4 quals      `thenRn4` \ ((quals', qual_binders), fvQuals) ->
 249     extendSS2 qual_binders (rnExpr4 expr) `thenRn4` \ (expr', fvExpr) ->
 250     returnRn4 (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
 251
 252 rnExpr4 (Let binds expr)
 253   = rnBinds4 binds      `thenRn4` \ (binds', fvBinds, new_binders) ->
 254     extendSS2 new_binders (rnExpr4 expr) `thenRn4` \ (expr',fvExpr) ->
 255     returnRn4 (Let binds' expr', fvBinds `unionUniqSets` fvExpr)
 256
 257 rnExpr4 (ExplicitList exps)
 258   = rnExprs4 exps        `thenRn4` \ (exps', fvs) ->
 259     returnRn4  (ExplicitList exps', fvs)
 260
 261 rnExpr4 (ExplicitTuple exps)
 262   = rnExprs4 exps        `thenRn4` \ (exps', fvExps) ->
 263     returnRn4 (ExplicitTuple exps', fvExps)
 264
 265 rnExpr4 (ExprWithTySig expr pty)
 266   = rnExpr4 expr                                 `thenRn4` \ (expr', fvExpr) ->
 267     rnPolyType4 False True nullTyVarNamesEnv pty `thenRn4` \ pty' ->
 268     returnRn4 (ExprWithTySig expr' pty', fvExpr)
 269
 270 rnExpr4 (If p b1 b2)
 271   = rnExpr4 p   `thenRn4` \ (p', fvP) ->
 272     rnExpr4 b1  `thenRn4` \ (b1', fvB1) ->
 273     rnExpr4 b2  `thenRn4` \ (b2', fvB2) ->
 274     returnRn4 (If p' b1' b2', unionManyUniqSets [fvP, fvB1, fvB2])
 275
 276 rnExpr4 (ArithSeqIn seq)
 277   = rn_seq seq `thenRn4` \ (new_seq, fvs) ->
 278     returnRn4 (ArithSeqIn new_seq, fvs)
 279   where
 280     rn_seq (From expr)
 281      = rnExpr4 expr      `thenRn4` \ (expr', fvExpr) ->
 282        returnRn4 (From expr', fvExpr)
 283
 284     rn_seq (FromThen expr1 expr2)
 285      = rnExpr4 expr1     `thenRn4` \ (expr1', fvExpr1) ->
 286        rnExpr4 expr2     `thenRn4` \ (expr2', fvExpr2) ->
 287        returnRn4 (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
 288
 289     rn_seq (FromTo expr1 expr2)
 290      = rnExpr4 expr1     `thenRn4` \ (expr1', fvExpr1) ->
 291        rnExpr4 expr2     `thenRn4` \ (expr2', fvExpr2) ->
 292        returnRn4 (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
 293
 294     rn_seq (FromThenTo expr1 expr2 expr3)
 295      = rnExpr4 expr1     `thenRn4` \ (expr1', fvExpr1) ->
 296        rnExpr4 expr2     `thenRn4` \ (expr2', fvExpr2) ->
 297        rnExpr4 expr3     `thenRn4` \ (expr3', fvExpr3) ->
 298        returnRn4 (FromThenTo expr1' expr2' expr3',
 299                   unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
 300
 301 #ifdef DPH
 302 rnExpr4 (ParallelZF expr quals)
 303   = rnParQuals4 quals     `thenRn4` \ ((quals',binds),fvQuals)->
 304     extendSS2  binds
 305                 (rnExpr4 expr) `thenRn4` \ (expr', fvExpr ) ->
 306     returnRn4 (ParallelZF expr' quals' , fvExpr `unionUniqSets` fvQuals)
 307
 308 rnExpr4 (ExplicitProcessor exprs expr)
 309   = rnExprs4 exprs      `thenRn4` \ (exprs',fvExprs) ->
 310     rnExpr4  expr       `thenRn4` \ (expr' ,fvExpr)  ->
 311     returnRn4 (ExplicitProcessor exprs' expr',fvExprs `unionUniqSets` fvExpr)
 312
 313 rnExpr4 (ExplicitPodIn exprs)
 314   = rnExprs4 exprs      `thenRn4` \ (exprs',fvExprs) ->
 315     returnRn4 (ExplicitPodIn exprs',fvExprs)
 316
 317 -- ExplicitPodOut : not in ProtoNameExprs (pops out of typechecker :-)
 318
 319 #endif {- Data Parallel Haskell -}
 320
 321 -- ArithSeqOut: not in ProtoNameExprs
 322 \end{code}
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsubsection[dep-Quals]{@Qual@s: in list comprehensions}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 Note that although some bound vars may appear in the free var set for
 331 the first qual, these will eventually be removed by the caller. For
 332 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 333 @(AndQuals (q <- r) (p <- q))@, the free var set for @(q <- r)@ will
 334 be @[r]@, and the free var set for the entire Quals will be @[r]@. This
 335 @r@ will be removed only when we finally return from examining all the
 336 Quals.
 337
 338 \begin{code}
 339 rnQuals4 :: [ProtoNameQual]  -> Rn4M (([RenamedQual], [Name]), FreeVars)
 340
 341 rnQuals4 [qual]
 342   = rnQual4 qual `thenRn4` \ ((new_qual, bs), fvs) ->
 343     returnRn4 (([new_qual], bs), fvs)
 344
 345 rnQuals4 (qual: quals)
 346   = rnQual4 qual                        `thenRn4` \ ((qual',  bs1), fvQuals1) ->
 347     extendSS2 bs1 (rnQuals4 quals)      `thenRn4` \ ((quals', bs2), fvQuals2) ->
 348     returnRn4
 349        ((qual' : quals', bs2 ++ bs1),   -- The ones on the right (bs2) shadow the
 350                                         -- ones on the left (bs1)
 351         fvQuals1 `unionUniqSets` fvQuals2)
 352
 353 rnQual4 (GeneratorQual pat expr)
 354   = rnExpr4 expr                 `thenRn4` \ (expr', fvExpr) ->
 355     let
 356         binders = collectPatBinders pat
 357     in
 358     getSrcLocRn4                 `thenRn4` \ src_loc ->
 359     namesFromProtoNames "variable in list-comprehension-generator pattern"
 360          (binders `zip` repeat src_loc)   `thenRn4` \ new_binders ->
 361     extendSS new_binders (rnPat4 pat) `thenRn4` \ pat' ->
 362
 363     returnRn4 ((GeneratorQual pat' expr', new_binders), fvExpr)
 364
 365 rnQual4 (FilterQual expr)
 366   = rnExpr4 expr         `thenRn4` \ (expr', fvs) ->
 367     returnRn4 ((FilterQual expr', []), fvs)
 368 \end{code}
 369
 370 %************************************************************************
 371 %*                                                                      *
 372 %* Parallel Quals (in Parallel Zf expressions)                          *
 373 %*                                                                      *
 374 %************************************************************************
 375 \subsubsection[dep-ParQuals]{ParQuals}
 376
 377 \begin{code}
 378 #ifdef DPH
 379 rnPats4 :: [ProtoNamePat] -> Rn4M [RenamedPat]
 380 rnPats4 [] = returnRn4 []
 381 rnPats4 (pat:pats)
 382   = (rnPat4  pat)               `thenRn4` (\ pat'  ->
 383     (rnPats4 pats)      `thenRn4` (\ pats' ->
 384     returnRn4 (pat':pats') ))
 385
 386 rnParQuals4 :: ProtoNameParQuals  -> Rn4M ((RenamedParQuals, [Name]), FreeVars)
 387
 388 rnParQuals4 (AndParQuals q1 q2)
 389  = rnParQuals4 q1               `thenRn4` (\ ((quals1', bs1), fvQuals1) ->
 390    extendSS2 bs1 (rnParQuals4 q2)
 391                                 `thenRn4` (\ ((quals2', bs2), fvQuals2) ->
 392    returnRn4 ((AndParQuals quals1' quals2', bs2 ++ bs1),
 393                     fvQuals1 `unionUniqSets` fvQuals2) ))
 394
 395
 396 rnParQuals4 (DrawnGenIn pats pat expr)
 397  = rnExpr4 expr          `thenRn4`      (\ (expr', fvExpr) ->
 398    let_1_0 (concat (map collectPatBinders pats))        (\ binders1 ->
 399    getSrcLocRn4         `thenRn4`               (\ src_loc ->
 400    namesFromProtoNames "variable in pattern"
 401         (binders1 `zip` repeat src_loc)
 402                                 `thenRn4`               (\ binders1' ->
 403    extendSS binders1' (rnPats4 pats)
 404                                 `thenRn4`               (\ pats' ->
 405    let_1_0 (collectPatBinders pat)                      (\ binders2 ->
 406    namesFromProtoNames "variable in pattern"
 407         (binders2 `zip` repeat src_loc)
 408                                 `thenRn4`               (\ binders2' ->
 409    extendSS binders2' (rnPat4 pat)
 410                                 `thenRn4`               (\ pat' ->
 411    returnRn4 ((DrawnGenIn pats' pat' expr' , binders1' ++ binders2'),
 412                    fvExpr) ))))))))
 413
 414 rnParQuals4 (IndexGen exprs pat expr)
 415  = rnExpr4  expr                 `thenRn4`      (\ (expr',  fvExpr) ->
 416    rnExprs4 exprs                `thenRn4`      (\ (exprs', fvExprs) ->
 417    let_1_0 (collectPatBinders pat)                      (\ binders ->
 418    getSrcLocRn4         `thenRn4`               (\ src_loc ->
 419    namesFromProtoNames "variable in pattern"
 420         (binders `zip` repeat src_loc)
 421                                 `thenRn4`       (\ binders' ->
 422    extendSS binders' (rnPat4 pat)
 423                                 `thenRn4`       (\ pat' ->
 424    returnRn4 ((IndexGen exprs' pat' expr' , binders'),
 425                    fvExpr `unionUniqSets` fvExprs) ))))))
 426
 427 rnParQuals4 (ParFilter expr)
 428  = rnExpr4 expr  `thenRn4` (\  (expr', fvExpr) ->
 429    returnRn4         ((ParFilter expr', []), fvExpr) )
 430 #endif {- Data Parallel Haskell -}
 431 \end{code}