2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[RnBinds]{Renaming and dependency analysis of bindings}
6 This module does renaming and dependency analysis on value bindings in
7 the abstract syntax. It does {\em not} do cycle-checks on class or
8 type-synonym declarations; those cannot be done at this stage because
9 they may be affected by renaming (which isn't fully worked out yet).
12 #include "HsVersions.h"
15 rnTopBinds, rnTopMonoBinds,
21 IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops
24 import HsPragmas ( isNoGenPragmas, noGenPragmas )
28 import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
29 import RnEnv ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName )
31 import CmdLineOpts ( opt_SigsRequired )
32 import Digraph ( stronglyConnComp )
33 import ErrUtils ( addErrLoc, addShortErrLocLine )
34 import Name ( OccName(..), Provenance,
35 Name {- instance Eq -},
36 NameSet(..), emptyNameSet, mkNameSet, unionNameSets,
37 minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
39 import Maybes ( catMaybes )
40 --import PprStyle--ToDo:rm
42 import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
43 import UniqSet ( SYN_IE(UniqSet) )
44 import ListSetOps ( minusList )
45 import Bag ( bagToList )
46 import UniqFM ( UniqFM )
47 import ErrUtils ( SYN_IE(Error) )
50 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
51 -- place and can be used when complaining.
53 The code tree received by the function @rnBinds@ contains definitions
54 in where-clauses which are all apparently mutually recursive, but which may
55 not really depend upon each other. For example, in the top level program
60 the definitions of @a@ and @y@ do not depend on each other at all.
61 Unfortunately, the typechecker cannot always check such definitions.
62 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
63 definitions. In Proceedings of the International Symposium on Programming,
64 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
65 However, the typechecker usually can check definitions in which only the
66 strongly connected components have been collected into recursive bindings.
67 This is precisely what the function @rnBinds@ does.
69 ToDo: deal with case where a single monobinds binds the same variable
72 The vertag tag is a unique @Int@; the tags only need to be unique
73 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
74 (heavy monad machinery not needed).
78 type Cycle = [VertexTag]
79 type Edge = (VertexTag, VertexTag)
82 %************************************************************************
84 %* naming conventions *
86 %************************************************************************
88 \subsection[name-conventions]{Name conventions}
90 The basic algorithm involves walking over the tree and returning a tuple
91 containing the new tree plus its free variables. Some functions, such
92 as those walking polymorphic bindings (HsBinds) and qualifier lists in
93 list comprehensions (@Quals@), return the variables bound in local
94 environments. These are then used to calculate the free variables of the
95 expression evaluated in these environments.
97 Conventions for variable names are as follows:
100 new code is given a prime to distinguish it from the old.
103 a set of variables defined in @Exp@ is written @dvExp@
106 a set of variables free in @Exp@ is written @fvExp@
109 %************************************************************************
111 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
113 %************************************************************************
115 \subsubsection[dep-HsBinds]{Polymorphic bindings}
117 Non-recursive expressions are reconstructed without any changes at top
118 level, although their component expressions may have to be altered.
119 However, non-recursive expressions are currently not expected as
120 \Haskell{} programs, and this code should not be executed.
122 Monomorphic bindings contain information that is returned in a tuple
123 (a @FlatMonoBindsInfo@) containing:
127 a unique @Int@ that serves as the ``vertex tag'' for this binding.
130 the name of a function or the names in a pattern. These are a set
131 referred to as @dvLhs@, the defined variables of the left hand side.
134 the free variables of the body. These are referred to as @fvBody@.
137 the definition's actual code. This is referred to as just @code@.
140 The function @nonRecDvFv@ returns two sets of variables. The first is
141 the set of variables defined in the set of monomorphic bindings, while the
142 second is the set of free variables in those bindings.
144 The set of variables defined in a non-recursive binding is just the
145 union of all of them, as @union@ removes duplicates. However, the
146 free variables in each successive set of cumulative bindings is the
147 union of those in the previous set plus those of the newest binding after
148 the defined variables of the previous set have been removed.
150 @rnMethodBinds@ deals only with the declarations in class and
151 instance declarations. It expects only to see @FunMonoBind@s, and
152 it expects the global environment to contain bindings for the binders
153 (which are all class operations).
155 %************************************************************************
157 %* Top-level bindings
159 %************************************************************************
161 @rnTopBinds@ assumes that the environment already
162 contains bindings for the binders of this particular binding.
165 rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
167 rnTopBinds EmptyBinds = returnRn EmptyBinds
168 rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind []
169 rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
170 -- The parser doesn't produce other forms
173 rnTopMonoBinds EmptyMonoBinds sigs
174 = returnRn EmptyBinds
176 rnTopMonoBinds mbinds sigs
177 = mapRn lookupRn binder_rdr_names `thenRn` \ binder_names ->
179 binder_set = mkNameSet binder_names
181 rn_mono_binds True {- top level -}
182 binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
185 binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
188 %************************************************************************
192 %************************************************************************
195 - collects up the binders for this declaration group,
196 - checks that they form a set
197 - extends the environment to bind them to new local names
198 - calls @rnMonoBinds@ to do the real work
201 rnBinds :: RdrNameHsBinds
202 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
203 -> RnMS s (result, FreeVars)
205 rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
206 rnBinds (SingleBind (RecBind bind)) thing_inside = rnMonoBinds bind [] thing_inside
207 rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside
208 -- the parser doesn't produce other forms
211 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
212 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
213 -> RnMS s (result, FreeVars)
215 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
217 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
218 = -- Extract all the binders in this group,
219 -- and extend current scope, inventing new names for the new binders
220 -- This also checks that the names form a set
221 bindLocatedLocalsRn "binding group" mbinders_w_srclocs $ \ new_mbinders ->
223 binder_set = mkNameSet new_mbinders
225 rn_mono_binds False {- not top level -}
226 binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
228 -- Now do the "thing inside", and deal with the free-variable calculations
229 thing_inside binds `thenRn` \ (result,result_fvs) ->
230 returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set)
232 mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
236 %************************************************************************
238 %* MonoBinds -- the main work is done here
240 %************************************************************************
242 @rnMonoBinds@ is used by *both* top-level and nested bindings. It
243 assumes that all variables bound in this group are already in scope.
244 This is done *either* by pass 3 (for the top-level bindings), *or* by
245 @rnNestedMonoBinds@ (for the nested ones).
248 rn_mono_binds :: Bool -- True <=> top level
249 -> NameSet -- Binders of this group
251 -> [RdrNameSig] -- Signatures attached to this group
252 -> RnMS s (RenamedHsBinds, --
253 FreeVars) -- Free variables
255 rn_mono_binds is_top_lev binders mbinds sigs
257 -- Rename the bindings, returning a MonoBindsInfo
258 -- which is a list of indivisible vertices so far as
259 -- the strongly-connected-components (SCC) analysis is concerned
260 rnBindSigs is_top_lev binders sigs `thenRn` \ siglist ->
261 flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) ->
263 -- Do the SCC analysis
264 let vertices = mkVertices mbinds_info
265 edges = mkEdges mbinds_info
266 scc_result = stronglyConnComp (==) edges vertices
267 final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result)
269 -- Deal with bound and free-var calculation
270 rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
272 returnRn (final_binds, rhs_fvs)
275 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
276 unique ``vertex tags'' on its output; minor plumbing required.
279 flattenMonoBinds :: Int -- Next free vertex tag
280 -> [RenamedSig] -- Signatures
282 -> RnMS s (Int, FlatMonoBindsInfo)
284 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
286 flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
287 = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) ->
288 flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) ->
289 returnRn (uniq2, flat1 ++ flat2)
291 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
292 = pushSrcLocRn locn $
293 rnPat pat `thenRn` \ pat' ->
294 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
296 -- Find which things are bound in this group
298 names_bound_here = mkNameSet (collectPatBinders pat')
299 sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
300 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
306 fvs `unionNameSets` sigs_fvs,
307 PatMonoBind pat' grhss_and_binds' locn,
312 flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
313 = pushSrcLocRn locn $
314 mapRn (checkPrecMatch inf name) matches `thenRn_`
315 lookupRn name `thenRn` \ name' ->
316 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
318 fvs = unionManyNameSets fv_lists
319 sigs_for_me = filter ((name' ==) . sig_name) sigs
320 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
326 fvs `unionNameSets` sigs_fvs,
327 FunMonoBind name' inf new_matches locn,
334 @rnMethodBinds@ is used for the method bindings of an instance
335 declaration. like @rnMonoBinds@ but without dependency analysis.
338 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
340 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
342 rnMethodBinds (AndMonoBinds mb1 mb2)
343 = andRn AndMonoBinds (rnMethodBinds mb1)
346 rnMethodBinds (FunMonoBind occname inf matches locn)
347 = pushSrcLocRn locn $
348 mapRn (checkPrecMatch inf occname) matches `thenRn_`
349 lookupRn occname `thenRn` \ op_name ->
350 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
351 returnRn (FunMonoBind op_name inf new_matches locn)
353 rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
354 = pushSrcLocRn locn $
355 lookupRn occname `thenRn` \ op_name ->
356 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
357 returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
359 -- Can't handle method pattern-bindings which bind multiple methods.
360 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
361 = pushSrcLocRn locn $
362 failWithRn EmptyMonoBinds (methodBindErr mbind)
366 -- If a SPECIALIZE pragma is of the "... = blah" form,
367 -- then we'd better make sure "blah" is taken into
368 -- acct in the dependency analysis (or we get an
369 -- unexpected out-of-scope error)! WDP 95/07
371 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
375 %************************************************************************
377 \subsection[reconstruct-deps]{Reconstructing dependencies}
379 %************************************************************************
381 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
382 as the two cases are similar.
385 reconstructCycle :: [Edge] -- Original edges
390 reconstructCycle edges mbi cycle
391 = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle)
393 relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi,
394 vertex `is_elem` cycle]
395 (binds, sig_lists) = unzip relevant_binds_and_sigs
396 this_gp_binds = foldr1 AndMonoBinds binds
397 this_gp_sigs = foldr1 (++) sig_lists
399 is_elem = isIn "reconstructRec"
401 mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds
402 mk_binds bs [] True = SingleBind (RecBind bs)
403 mk_binds bs ss True = BindWith (RecBind bs) ss
404 mk_binds bs [] False = SingleBind (NonRecBind bs)
405 mk_binds bs ss False = BindWith (NonRecBind bs) ss
407 -- moved from Digraph, as this is the only use here
408 -- (avoid overloading cost). We have to use elem
409 -- (not FiniteMaps or whatever), because there may be
410 -- many edges out of one vertex. We give it its own
411 -- "elem" just for speed.
413 isCyclic es [] = panic "isCyclic: empty component"
414 isCyclic es [v] = (v,v) `elem` es
415 isCyclic es vs = True
418 elem x (y:ys) = x==y || elem x ys
421 %************************************************************************
423 %* Manipulating FlatMonoBindInfo *
425 %************************************************************************
427 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
428 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
429 a function binding, and has itself been dependency-analysed and
433 type FlatMonoBindsInfo
434 = [(VertexTag, -- Identifies the vertex
435 NameSet, -- Set of names defined in this vertex
436 NameSet, -- Set of names used in this vertex
437 RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
438 [RenamedSig]) -- Signatures, if any, for this vertex
441 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
442 mkEdges :: FlatMonoBindsInfo -> [Edge]
444 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
446 mkEdges flat_info -- An edge (v,v') indicates that v depends on v'
447 = [ (source_vertex, target_vertex)
448 | (source_vertex, _, used_names, _, _) <- flat_info,
449 target_name <- nameSetToList used_names,
450 target_vertex <- vertices_defining target_name flat_info
453 -- If each name only has one binding in this group, then
454 -- vertices_defining will always return the empty list, or a
455 -- singleton. The case when there is more than one binding (an
456 -- error) needs more thought.
458 vertices_defining name flat_info2
459 = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
460 name `elemNameSet` names_defined
465 %************************************************************************
467 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
469 %************************************************************************
471 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
472 (b)~signatures given for things not bound here; (c)~with suitably
473 flaggery, that all top-level things have type signatures.
476 rnBindSigs :: Bool -- True <=> top-level binders
477 -> NameSet -- Set of names bound in this group
479 -> RnMS s [RenamedSig] -- List of Sig constructors
481 rnBindSigs is_toplev binders sigs
482 = -- Rename the signatures
483 mapRn renameSig sigs `thenRn` \ sigs' ->
485 -- Check for (a) duplicate signatures
486 -- (b) signatures for things not in this group
487 -- (c) optionally, bindings with no signature
489 (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
490 not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
491 type_sig_vars = [n | Sig n _ _ <- goodies]
493 | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars
496 mapRn dupSigDeclErr dups `thenRn_`
497 mapRn unknownSigErr not_this_group `thenRn_`
498 mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
500 returnRn sigs' -- bad ones and all:
501 -- we need bindings of *some* sort for every name
504 renameSig (Sig v ty src_loc)
505 = pushSrcLocRn src_loc $
506 lookupRn v `thenRn` \ new_v ->
507 rnHsType ty `thenRn` \ new_ty ->
508 returnRn (Sig new_v new_ty src_loc)
510 renameSig (SpecSig v ty using src_loc)
511 = pushSrcLocRn src_loc $
512 lookupRn v `thenRn` \ new_v ->
513 rnHsType ty `thenRn` \ new_ty ->
514 rn_using using `thenRn` \ new_using ->
515 returnRn (SpecSig new_v new_ty new_using src_loc)
517 rn_using Nothing = returnRn Nothing
518 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
519 returnRn (Just new_x)
521 renameSig (InlineSig v src_loc)
522 = pushSrcLocRn src_loc $
523 lookupRn v `thenRn` \ new_v ->
524 returnRn (InlineSig new_v src_loc)
526 renameSig (DeforestSig v src_loc)
527 = pushSrcLocRn src_loc $
528 lookupRn v `thenRn` \ new_v ->
529 returnRn (DeforestSig new_v src_loc)
531 renameSig (MagicUnfoldingSig v str src_loc)
532 = pushSrcLocRn src_loc $
533 lookupRn v `thenRn` \ new_v ->
534 returnRn (MagicUnfoldingSig new_v str src_loc)
537 Checking for distinct signatures; oh, so boring
540 cmp_sig :: RenamedSig -> RenamedSig -> TAG_
541 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `cmp` n2
542 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
543 cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
544 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
545 = -- may have many specialisations for one value;
546 -- but not ones that are exactly the same...
547 thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2)
549 cmp_sig other_1 other_2 -- Tags *must* be different
550 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_
553 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
554 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
555 sig_tag (InlineSig n1 _) = ILIT(3)
556 sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
557 sig_tag (DeforestSig n1 _) = ILIT(5)
558 sig_tag _ = panic# "tag(RnBinds)"
560 sig_name (Sig n _ _) = n
561 sig_name (ClassOpSig n _ _ _) = n
562 sig_name (SpecSig n _ _ _) = n
563 sig_name (InlineSig n _) = n
564 sig_name (MagicUnfoldingSig n _ _) = n
567 %************************************************************************
569 \subsection{Error messages}
571 %************************************************************************
574 dupSigDeclErr (sig:sigs)
576 addErrRn (\sty -> ppSep [ppStr "more than one",
577 ppStr what_it_is, ppStr "given for",
578 ppQuote (ppr sty (sig_name sig))])
580 (what_it_is, loc) = sig_doc sig
584 addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for",
585 ppQuote (ppr sty (sig_name sig))])
587 (flavour, loc) = sig_doc sig
589 sig_doc (Sig _ _ loc) = ("type signature",loc)
590 sig_doc (ClassOpSig _ _ _ loc) = ("class-method type signature", loc)
591 sig_doc (SpecSig _ _ _ loc) = ("SPECIALIZE pragma",loc)
592 sig_doc (InlineSig _ loc) = ("INLINE pragma",loc)
593 sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc)
595 missingSigErr var sty
596 = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)]
598 methodBindErr mbind sty
599 = ppHang (ppStr "Can't handle multiple methods defined by one pattern binding")