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 )
26 import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
27 import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn,
28 newLocalNames, isUnboundName, warnUnusedBinds
30 import CmdLineOpts ( opt_SigsRequired )
31 import Digraph ( stronglyConnComp, SCC(..) )
32 import Name ( OccName(..), Provenance,
34 NameSet(..), emptyNameSet, mkNameSet, unionNameSets,
35 minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
37 import BasicTypes ( RecFlag(..), TopLevelFlag(..) )
38 import Util ( thenCmp, removeDups, panic, panic#, assertPanic )
39 import UniqSet ( UniqSet )
40 import ListSetOps ( minusList )
41 import Bag ( bagToList )
42 import UniqFM ( UniqFM )
46 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
47 -- place and can be used when complaining.
49 The code tree received by the function @rnBinds@ contains definitions
50 in where-clauses which are all apparently mutually recursive, but which may
51 not really depend upon each other. For example, in the top level program
56 the definitions of @a@ and @y@ do not depend on each other at all.
57 Unfortunately, the typechecker cannot always check such definitions.
58 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
59 definitions. In Proceedings of the International Symposium on Programming,
60 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
61 However, the typechecker usually can check definitions in which only the
62 strongly connected components have been collected into recursive bindings.
63 This is precisely what the function @rnBinds@ does.
65 ToDo: deal with case where a single monobinds binds the same variable
68 The vertag tag is a unique @Int@; the tags only need to be unique
69 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
70 (heavy monad machinery not needed).
74 type Cycle = [VertexTag]
75 type Edge = (VertexTag, VertexTag)
78 %************************************************************************
80 %* naming conventions *
82 %************************************************************************
84 \subsection[name-conventions]{Name conventions}
86 The basic algorithm involves walking over the tree and returning a tuple
87 containing the new tree plus its free variables. Some functions, such
88 as those walking polymorphic bindings (HsBinds) and qualifier lists in
89 list comprehensions (@Quals@), return the variables bound in local
90 environments. These are then used to calculate the free variables of the
91 expression evaluated in these environments.
93 Conventions for variable names are as follows:
96 new code is given a prime to distinguish it from the old.
99 a set of variables defined in @Exp@ is written @dvExp@
102 a set of variables free in @Exp@ is written @fvExp@
105 %************************************************************************
107 %* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
109 %************************************************************************
111 \subsubsection[dep-HsBinds]{Polymorphic bindings}
113 Non-recursive expressions are reconstructed without any changes at top
114 level, although their component expressions may have to be altered.
115 However, non-recursive expressions are currently not expected as
116 \Haskell{} programs, and this code should not be executed.
118 Monomorphic bindings contain information that is returned in a tuple
119 (a @FlatMonoBindsInfo@) containing:
123 a unique @Int@ that serves as the ``vertex tag'' for this binding.
126 the name of a function or the names in a pattern. These are a set
127 referred to as @dvLhs@, the defined variables of the left hand side.
130 the free variables of the body. These are referred to as @fvBody@.
133 the definition's actual code. This is referred to as just @code@.
136 The function @nonRecDvFv@ returns two sets of variables. The first is
137 the set of variables defined in the set of monomorphic bindings, while the
138 second is the set of free variables in those bindings.
140 The set of variables defined in a non-recursive binding is just the
141 union of all of them, as @union@ removes duplicates. However, the
142 free variables in each successive set of cumulative bindings is the
143 union of those in the previous set plus those of the newest binding after
144 the defined variables of the previous set have been removed.
146 @rnMethodBinds@ deals only with the declarations in class and
147 instance declarations. It expects only to see @FunMonoBind@s, and
148 it expects the global environment to contain bindings for the binders
149 (which are all class operations).
151 %************************************************************************
153 %* Top-level bindings
155 %************************************************************************
157 @rnTopBinds@ assumes that the environment already
158 contains bindings for the binders of this particular binding.
161 rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
163 rnTopBinds EmptyBinds = returnRn EmptyBinds
164 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
165 -- The parser doesn't produce other forms
168 rnTopMonoBinds EmptyMonoBinds sigs
169 = returnRn EmptyBinds
171 rnTopMonoBinds mbinds sigs
172 = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names ->
174 binder_set = mkNameSet binder_names
175 exported_binders = mkNameSet (filter isExportedName binder_names)
177 rn_mono_binds TopLevel
178 binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
180 unused_binders = binder_set `minusNameSet` (fv_set `unionNameSets` exported_binders)
182 warnUnusedBinds unused_binders `thenRn_`
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 (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside
207 -- the parser doesn't produce other forms
210 rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
211 -> (RenamedHsBinds -> RnMS s (result, FreeVars))
212 -> RnMS s (result, FreeVars)
214 rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
216 rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
217 = -- Extract all the binders in this group,
218 -- and extend current scope, inventing new names for the new binders
219 -- This also checks that the names form a set
220 bindLocatedLocalsRn (text "binding group") mbinders_w_srclocs $ \ new_mbinders ->
222 binder_set = mkNameSet new_mbinders
224 rn_mono_binds NotTopLevel
225 binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
227 -- Now do the "thing inside", and deal with the free-variable calculations
228 thing_inside binds `thenRn` \ (result,result_fvs) ->
230 all_fvs = result_fvs `unionNameSets` bind_fvs
231 net_fvs = all_fvs `minusNameSet` binder_set
232 unused_binders = binder_set `minusNameSet` all_fvs
234 warnUnusedBinds unused_binders `thenRn_`
235 returnRn (result, net_fvs)
237 mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
241 %************************************************************************
243 %* MonoBinds -- the main work is done here
245 %************************************************************************
247 @rnMonoBinds@ is used by *both* top-level and nested bindings. It
248 assumes that all variables bound in this group are already in scope.
249 This is done *either* by pass 3 (for the top-level bindings), *or* by
250 @rnNestedMonoBinds@ (for the nested ones).
253 rn_mono_binds :: TopLevelFlag
254 -> NameSet -- Binders of this group
256 -> [RdrNameSig] -- Signatures attached to this group
257 -> RnMS s (RenamedHsBinds, --
258 FreeVars) -- Free variables
260 rn_mono_binds top_lev binders mbinds sigs
262 -- Rename the bindings, returning a MonoBindsInfo
263 -- which is a list of indivisible vertices so far as
264 -- the strongly-connected-components (SCC) analysis is concerned
265 rnBindSigs top_lev binders sigs `thenRn` \ siglist ->
266 flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
268 -- Do the SCC analysis
269 let edges = mkEdges (mbinds_info `zip` [(0::Int)..])
270 scc_result = stronglyConnComp edges
271 final_binds = foldr1 ThenBinds (map reconstructCycle scc_result)
273 -- Deal with bound and free-var calculation
274 rhs_fvs = unionManyNameSets [fvs | (_,fvs,_,_) <- mbinds_info]
276 returnRn (final_binds, rhs_fvs)
279 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
280 unique ``vertex tags'' on its output; minor plumbing required.
283 flattenMonoBinds :: [RenamedSig] -- Signatures
285 -> RnMS s [FlatMonoBindsInfo]
287 flattenMonoBinds sigs EmptyMonoBinds = returnRn []
289 flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
290 = flattenMonoBinds sigs bs1 `thenRn` \ flat1 ->
291 flattenMonoBinds sigs bs2 `thenRn` \ flat2 ->
292 returnRn (flat1 ++ flat2)
294 flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
295 = pushSrcLocRn locn $
296 rnPat pat `thenRn` \ pat' ->
297 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
299 -- Find which things are bound in this group
301 names_bound_here = mkNameSet (collectPatBinders pat')
302 sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
303 sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
307 fvs `unionNameSets` sigs_fvs,
308 PatMonoBind pat' grhss_and_binds' locn,
312 flattenMonoBinds sigs (FunMonoBind name inf matches locn)
313 = pushSrcLocRn locn $
314 mapRn (checkPrecMatch inf name) matches `thenRn_`
315 lookupBndrRn 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
324 fvs `unionNameSets` sigs_fvs,
325 FunMonoBind name' inf new_matches locn,
331 @rnMethodBinds@ is used for the method bindings of an instance
332 declaration. like @rnMonoBinds@ but without dependency analysis.
335 rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
337 rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
339 rnMethodBinds (AndMonoBinds mb1 mb2)
340 = andRn AndMonoBinds (rnMethodBinds mb1)
343 rnMethodBinds (FunMonoBind occname inf matches locn)
344 = pushSrcLocRn locn $
345 mapRn (checkPrecMatch inf occname) matches `thenRn_`
347 newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
348 -- Make a fresh local for the bound variable; it must be different
349 -- to occurrences of the same thing on the LHS, which refer to the global
352 mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
353 returnRn (FunMonoBind op_name inf new_matches locn)
355 rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
356 = pushSrcLocRn locn $
357 newLocalNames [(occname, locn)] `thenRn` \ [op_name] ->
358 rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
359 returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
361 -- Can't handle method pattern-bindings which bind multiple methods.
362 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
363 = pushSrcLocRn locn $
364 failWithRn EmptyMonoBinds (methodBindErr mbind)
368 -- If a SPECIALIZE pragma is of the "... = blah" form,
369 -- then we'd better make sure "blah" is taken into
370 -- acct in the dependency analysis (or we get an
371 -- unexpected out-of-scope error)! WDP 95/07
373 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
377 %************************************************************************
379 \subsection[reconstruct-deps]{Reconstructing dependencies}
381 %************************************************************************
383 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
384 as the two cases are similar.
387 reconstructCycle :: SCC FlatMonoBindsInfo
390 reconstructCycle (AcyclicSCC (_, _, binds, sigs))
391 = MonoBind binds sigs NonRecursive
393 reconstructCycle (CyclicSCC cycle)
394 = MonoBind this_gp_binds this_gp_sigs Recursive
396 this_gp_binds = foldr1 AndMonoBinds [binds | (_, _, binds, _) <- cycle]
397 this_gp_sigs = foldr1 (++) [sigs | (_, _, _, sigs) <- cycle]
400 %************************************************************************
402 %* Manipulating FlatMonoBindInfo *
404 %************************************************************************
406 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
407 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
408 a function binding, and has itself been dependency-analysed and
412 type FlatMonoBindsInfo
413 = (NameSet, -- Set of names defined in this vertex
414 NameSet, -- Set of names used in this vertex
416 [RenamedSig]) -- Signatures, if any, for this vertex
418 mkEdges :: [(FlatMonoBindsInfo, VertexTag)] -> [(FlatMonoBindsInfo, VertexTag, [VertexTag])]
421 = [ (info, tag, dest_vertices (nameSetToList names_used))
422 | (info@(names_defined, names_used, mbind, sigs), tag) <- flat_info
425 -- An edge (v,v') indicates that v depends on v'
426 dest_vertices src_mentions = [ target_vertex
427 | ((names_defined, _, _, _), target_vertex) <- flat_info,
428 mentioned_name <- src_mentions,
429 mentioned_name `elemNameSet` names_defined
434 %************************************************************************
436 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
438 %************************************************************************
440 @rnBindSigs@ checks for: (a)~more than one sig for one thing;
441 (b)~signatures given for things not bound here; (c)~with suitably
442 flaggery, that all top-level things have type signatures.
445 rnBindSigs :: TopLevelFlag
446 -> NameSet -- Set of names bound in this group
448 -> RnMS s [RenamedSig] -- List of Sig constructors
450 rnBindSigs top_lev binders sigs
451 = -- Rename the signatures
452 mapRn renameSig sigs `thenRn` \ sigs' ->
454 -- Check for (a) duplicate signatures
455 -- (b) signatures for things not in this group
456 -- (c) optionally, bindings with no signature
458 (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
459 not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
460 type_sig_vars = [n | Sig n _ _ <- goodies]
461 sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
462 un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
465 mapRn dupSigDeclErr dups `thenRn_`
466 mapRn unknownSigErr not_this_group `thenRn_`
467 mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
469 returnRn sigs' -- bad ones and all:
470 -- we need bindings of *some* sort for every name
473 renameSig (Sig v ty src_loc)
474 = pushSrcLocRn src_loc $
475 lookupBndrRn v `thenRn` \ new_v ->
476 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
477 returnRn (Sig new_v new_ty src_loc)
479 renameSig (SpecSig v ty using src_loc)
480 = pushSrcLocRn src_loc $
481 lookupBndrRn v `thenRn` \ new_v ->
482 rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
483 rn_using using `thenRn` \ new_using ->
484 returnRn (SpecSig new_v new_ty new_using src_loc)
486 rn_using Nothing = returnRn Nothing
487 rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
488 returnRn (Just new_x)
490 renameSig (InlineSig v src_loc)
491 = pushSrcLocRn src_loc $
492 lookupBndrRn v `thenRn` \ new_v ->
493 returnRn (InlineSig new_v src_loc)
495 renameSig (MagicUnfoldingSig v str src_loc)
496 = pushSrcLocRn src_loc $
497 lookupBndrRn v `thenRn` \ new_v ->
498 returnRn (MagicUnfoldingSig new_v str src_loc)
501 Checking for distinct signatures; oh, so boring
504 cmp_sig :: RenamedSig -> RenamedSig -> Ordering
505 cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
506 cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
507 cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2
508 cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
509 = -- may have many specialisations for one value;
510 -- but not ones that are exactly the same...
511 thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
513 cmp_sig other_1 other_2 -- Tags *must* be different
514 | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
517 sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
518 sig_tag (SpecSig n1 _ _ _) = ILIT(2)
519 sig_tag (InlineSig n1 _) = ILIT(3)
520 sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
521 sig_tag _ = panic# "tag(RnBinds)"
523 sig_name (Sig n _ _) = n
524 sig_name (ClassOpSig n _ _ _) = n
525 sig_name (SpecSig n _ _ _) = n
526 sig_name (InlineSig n _) = n
527 sig_name (MagicUnfoldingSig n _ _) = n
530 %************************************************************************
532 \subsection{Error messages}
534 %************************************************************************
537 dupSigDeclErr (sig:sigs)
539 addErrRn (sep [ptext SLIT("more than one"),
540 ptext what_it_is, ptext SLIT("given for"),
541 quotes (ppr (sig_name sig))])
543 (what_it_is, loc) = sig_doc sig
547 addErrRn (sep [ptext flavour, ptext SLIT("but no definition for"),
548 quotes (ppr (sig_name sig))])
550 (flavour, loc) = sig_doc sig
552 sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
553 sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
554 sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc)
555 sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
556 sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
559 = sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
562 = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))