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).
13 rnTopBinds, rnTopMonoBinds,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} RnSource ( rnHsSigType )
23 import HsPragmas ( isNoGenPragmas, noGenPragmas )
27 import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
28 import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn,
29 newLocalNames, isUnboundName, warnUnusedBinds
31 import CmdLineOpts ( opt_SigsRequired )
32 import Digraph ( stronglyConnComp, SCC(..) )
33 import Name ( OccName(..), Provenance,
35 NameSet(..), emptyNameSet, mkNameSet, unionNameSets,
36 minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
38 import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
39 import Maybes ( catMaybes )
40 import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, assocDefault )
41 import UniqSet ( UniqSet )
42 import ListSetOps ( minusList )
43 import Bag ( bagToList )
44 import UniqFM ( UniqFM )
48 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
49 -- place and can be used when complaining.
51 The code tree received by the function @rnBinds@ contains definitions
52 in where-clauses which are all apparently mutually recursive, but which may
53 not really depend upon each other. For example, in the top level program
58 the definitions of @a@ and @y@ do not depend on each other at all.
59 Unfortunately, the typechecker cannot always check such definitions.
60 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
61 definitions. In Proceedings of the International Symposium on Programming,
62 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
63 However, the typechecker usually can check definitions in which only the
64 strongly connected components have been collected into recursive bindings.
65 This is precisely what the function @rnBinds@ does.
67 ToDo: deal with case where a single monobinds binds the same variable
70 The vertag tag is a unique @Int@; the tags only need to be unique
71 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
72 (heavy monad machinery not needed).
76 type Cycle = [VertexTag]
77 type Edge = (VertexTag, VertexTag)
80 %************************************************************************
82 %* naming conventions *
84 %************************************************************************
86 \subsection[name-conventions]{Name conventions}
88 The basic algorithm involves walking over the tree and returning a tuple
89 containing the new tree plus its free variables. Some functions, such
90 as those walking polymorphic bindings (HsBinds) and qualifier lists in
91 list comprehensions (@Quals@), return the variables bound in local
92 environments. These are then used to calculate the free variables of the
93 expression evaluated in these environments.
95 Conventions for variable names are as follows:
98 new code is given a prime to distinguish it from the old.
101 a set of variables defined in @Exp@ is written @dvExp@
104 a set of variables free in @Exp@ is written @fvExp@
107 %************************************************************************
109 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
111 %************************************************************************
113 \subsubsection[dep-HsBinds]{Polymorphic bindings}
115 Non-recursive expressions are reconstructed without any changes at top
116 level, although their component expressions may have to be altered.
117 However, non-recursive expressions are currently not expected as
118 \Haskell{} programs, and this code should not be executed.
120 Monomorphic bindings contain information that is returned in a tuple
121 (a @FlatMonoBindsInfo@) containing:
125 a unique @Int@ that serves as the ``vertex tag'' for this binding.
128 the name of a function or the names in a pattern. These are a set
129 referred to as @dvLhs@, the defined variables of the left hand side.
132 the free variables of the body. These are referred to as @fvBody@.
135 the definition's actual code. This is referred to as just @code@.
138 The function @nonRecDvFv@ returns two sets of variables. The first is
139 the set of variables defined in the set of monomorphic bindings, while the
140 second is the set of free variables in those bindings.
142 The set of variables defined in a non-recursive binding is just the
143 union of all of them, as @union@ removes duplicates. However, the
144 free variables in each successive set of cumulative bindings is the
145 union of those in the previous set plus those of the newest binding after
146 the defined variables of the previous set have been removed.
148 @rnMethodBinds@ deals only with the declarations in class and
149 instance declarations. It expects only to see @FunMonoBind@s, and
150 it expects the global environment to contain bindings for the binders
151 (which are all class operations).
153 %************************************************************************
155 %* Top-level bindings
157 %************************************************************************
159 @rnTopBinds@ assumes that the environment already
160 contains bindings for the binders of this particular binding.
163 rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
165 rnTopBinds EmptyBinds = returnRn EmptyBinds
166 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
167 -- The parser doesn't produce other forms
170 rnTopMonoBinds EmptyMonoBinds sigs
171 = returnRn EmptyBinds
173 rnTopMonoBinds mbinds sigs
174 = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
176 binder_set = mkNameSet binder_names
177 exported_binders = mkNameSet (filter isExportedName binder_names)
179 rn_mono_binds TopLevel
180 binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
182 unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
184 warnUnusedBinds unused_binders `thenRn_`
187 binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
190 %************************************************************************
194 %************************************************************************
197 - collects up the binders for this declaration group,
198 - checks that they form a set
199 - extends the environment to bind them to new local names
200 - calls @rnMonoBinds@ to do the real work
203 rnBinds :: RdrNameHsBinds
204 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
205 -> RnMS s (result, FreeVars)
207 rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
208 rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
209 -- the parser doesn't produce other forms
212 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
213 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
214 -> RnMS s (result, FreeVars)
216 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
218 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
219 = -- Extract all the binders in this group,
220 -- and extend current scope, inventing new names for the new binders
221 -- This also checks that the names form a set
222 bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs $ \ new_mbinders ->
224 binder_set = mkNameSet new_mbinders
226 rn_mono_binds NotTopLevel
227 binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
229 -- Now do the "thing inside", and deal with the free-variable calculations
230 thing_inside binds `thenRn` \ (result,result_fvs) ->
232 all_fvs = result_fvs `unionNameSets` bind_fvs
233 net_fvs = all_fvs `minusNameSet` binder_set
234 unused_binders = binder_set `minusNameSet` all_fvs
236 warnUnusedBinds unused_binders `thenRn_`
237 returnRn (result, net_fvs)
239 mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
243 %************************************************************************
245 %* MonoBinds -- the main work is done here
247 %************************************************************************
249 @rnMonoBinds@ is used by *both* top-level and nested bindings. It
250 assumes that all variables bound in this group are already in scope.
251 This is done *either* by pass 3 (for the top-level bindings), *or* by
252 @rnNestedMonoBinds@ (for the nested ones).
255 rn_mono_binds :: TopLevelFlag
256 -> NameSet -- Binders of this group
258 -> [RdrNameSig] -- Signatures attached to this group
259 -> RnMS s (RenamedHsBinds, --
260 FreeVars) -- Free variables
262 rn_mono_binds top_lev binders mbinds sigs
264 -- Rename the bindings, returning a MonoBindsInfo
265 -- which is a list of indivisible vertices so far as
266 -- the strongly-connected-components (SCC) analysis is concerned
267 rnBindSigs top_lev binders sigs `thenRn` \ siglist ->
268 flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) ->
270 -- Do the SCC analysis
271 let edges = mkEdges mbinds_info
272 scc_result = stronglyConnComp edges
273 final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
275 -- Deal with bound and free-var calculation
276 rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
278 returnRn (final_binds, rhs_fvs)
281 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
282 unique ``vertex tags'' on its output; minor plumbing required.
285 flattenMonoBinds :: Int -- Next free vertex tag
286 -> [RenamedSig] -- Signatures
288 -> RnMS s (Int, [FlatMonoBindsInfo])
290 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
292 flattenMonoBinds uniq sigs (AndMonoBinds bs1 bs2)
293 = flattenMonoBinds uniq sigs bs1 `thenRn` \ (uniq1, flat1) ->
294 flattenMonoBinds uniq1 sigs bs2 `thenRn` \ (uniq2, flat2) ->
295 returnRn (uniq2, flat1 ++ flat2)
297 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
298 = pushSrcLocRn locn $
299 rnPat pat `thenRn` \ pat' ->
300 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
302 -- Find which things are bound in this group
304 names_bound_here = mkNameSet (collectPatBinders pat')
305 sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
306 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
312 fvs `unionNameSets` sigs_fvs,
313 PatMonoBind pat' grhss_and_binds' locn,
318 flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
319 = pushSrcLocRn locn $
320 mapRn (checkPrecMatch inf name) matches `thenRn_`
321 lookupBndrRn name `thenRn` \ name' ->
322 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
324 fvs = unionManyNameSets fv_lists
325 sigs_for_me = filter ((name' ==) . sig_name) sigs
326 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
332 fvs `unionNameSets` sigs_fvs,
333 FunMonoBind name' inf new_matches locn,
340 @rnMethodBinds@ is used for the method bindings of an instance
341 declaration. like @rnMonoBinds@ but without dependency analysis.
344 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
346 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
348 rnMethodBinds (AndMonoBinds mb1 mb2)
349 = andRn AndMonoBinds (rnMethodBinds mb1)
352 rnMethodBinds (FunMonoBind occname inf matches locn)
353 = pushSrcLocRn locn $
354 mapRn (checkPrecMatch inf occname) matches `thenRn_`
356 newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
357 -- Make a fresh local for the bound variable; it must be different
358 -- to occurrences of the same thing on the LHS, which refer to the global
361 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
362 returnRn (FunMonoBind op_name inf new_matches locn)
364 rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
365 = pushSrcLocRn locn $
366 newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
367 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
368 returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
370 -- Can't handle method pattern-bindings which bind multiple methods.
371 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
372 = pushSrcLocRn locn $
373 failWithRn EmptyMonoBinds (methodBindErr mbind)
377 -- If a SPECIALIZE pragma is of the "... = blah" form,
378 -- then we'd better make sure "blah" is taken into
379 -- acct in the dependency analysis (or we get an
380 -- unexpected out-of-scope error)! WDP 95/07
382 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
386 %************************************************************************
388 \subsection[reconstruct-deps]{Reconstructing dependencies}
390 %************************************************************************
392 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
393 as the two cases are similar.
396 reconstructCycle :: SCC FlatMonoBindsInfo
399 reconstructCycle (AcyclicSCC (_, _, _, binds, sigs))
400 = MonoBind binds sigs NonRecursive
402 reconstructCycle (CyclicSCC cycle)
403 = MonoBind this_gp_binds this_gp_sigs Recursive
405 this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, _, binds, _) <- cycle]
406 this_gp_sigs = foldr1 (++) [sigs | (_, _, _, _, sigs) <- cycle]
409 %************************************************************************
411 %* Manipulating FlatMonoBindInfo *
413 %************************************************************************
415 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
416 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
417 a function binding, and has itself been dependency-analysed and
421 type FlatMonoBindsInfo
422 = (VertexTag, -- Identifies the vertex
423 NameSet, -- Set of names defined in this vertex
424 NameSet, -- Set of names used in this vertex
425 RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
426 [RenamedSig]) -- Signatures, if any, for this vertex
429 mkEdges :: [FlatMonoBindsInfo] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
432 = [ (info, tag, dest_vertices (nameSetToList names_used))
433 | info@(tag, names_defined, names_used, mbind, sigs) <- flat_info
436 -- An edge (v,v') indicates that v depends on v'
437 dest_vertices src_mentions = [ target_vertex
438 | (target_vertex, names_defined, _, _, _) <- flat_info,
439 mentioned_name <- src_mentions,
440 mentioned_name `elemNameSet` names_defined
445 %************************************************************************
447 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
449 %************************************************************************
451 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
452 (b)~signatures given for things not bound here; (c)~with suitably
453 flaggery, that all top-level things have type signatures.
456 rnBindSigs :: TopLevelFlag
457 -> NameSet -- Set of names bound in this group
459 -> RnMS s [RenamedSig] -- List of Sig constructors
461 rnBindSigs top_lev binders sigs
462 = -- Rename the signatures
463 mapRn renameSig sigs `thenRn` \ sigs' ->
465 -- Check for (a) duplicate signatures
466 -- (b) signatures for things not in this group
467 -- (c) optionally, bindings with no signature
469 (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
470 not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
471 type_sig_vars = [n | Sig n _ _ <- goodies]
472 sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
473 un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
476 mapRn dupSigDeclErr dups `thenRn_`
477 mapRn unknownSigErr not_this_group `thenRn_`
478 mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
480 returnRn sigs' -- bad ones and all:
481 -- we need bindings of *some* sort for every name
484 renameSig (Sig v ty src_loc)
485 = pushSrcLocRn src_loc $
486 lookupBndrRn v `thenRn` \ new_v ->
487 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
488 returnRn (Sig new_v new_ty src_loc)
490 renameSig (SpecSig v ty using src_loc)
491 = pushSrcLocRn src_loc $
492 lookupBndrRn v `thenRn` \ new_v ->
493 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
494 rn_using using `thenRn` \ new_using ->
495 returnRn (SpecSig new_v new_ty new_using src_loc)
497 rn_using Nothing = returnRn Nothing
498 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
499 returnRn (Just new_x)
501 renameSig (InlineSig v src_loc)
502 = pushSrcLocRn src_loc $
503 lookupBndrRn v `thenRn` \ new_v ->
504 returnRn (InlineSig new_v src_loc)
506 renameSig (MagicUnfoldingSig v str src_loc)
507 = pushSrcLocRn src_loc $
508 lookupBndrRn v `thenRn` \ new_v ->
509 returnRn (MagicUnfoldingSig new_v str src_loc)
512 Checking for distinct signatures; oh, so boring
515 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
516 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
517 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
518 cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2
519 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
520 = -- may have many specialisations for one value;
521 -- but not ones that are exactly the same...
522 thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
524 cmp_sig other_1 other_2 -- Tags *must* be different
525 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
528 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
529 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
530 sig_tag (InlineSig n1 _) = ILIT(3)
531 sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
532 sig_tag _ = panic# "tag(RnBinds)"
534 sig_name (Sig n _ _) = n
535 sig_name (ClassOpSig n _ _ _) = n
536 sig_name (SpecSig n _ _ _) = n
537 sig_name (InlineSig n _) = n
538 sig_name (MagicUnfoldingSig n _ _) = n
541 %************************************************************************
543 \subsection{Error messages}
545 %************************************************************************
548 dupSigDeclErr (sig:sigs)
550 addErrRn (sep [ptext SLIT("more than one"),
551 ptext what_it_is, ptext SLIT("given for"),
552 quotes (ppr (sig_name sig))])
554 (what_it_is, loc) = sig_doc sig
558 addErrRn (sep [ptext flavour, ptext SLIT("but no definition for"),
559 quotes (ppr (sig_name sig))])
561 (flavour, loc) = sig_doc sig
563 sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
564 sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
565 sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc)
566 sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
567 sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
570 = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
573 = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))