ghc/compiler/rename/RenameBinds4.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[RenameBinds4]{Renaming and dependency analysis of bindings}
   5
   6 This module does renaming and dependency analysis on value bindings in
   7 @AbsSyntax@ programs.  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).
  10
  11 \begin{code}
  12 #include "HsVersions.h"
  13
  14 module RenameBinds4 (
  15         rnTopBinds4, rnMethodBinds4,
  16         rnBinds4,
  17         FreeVars(..), DefinedVars(..),
  18
  19         -- and to make the interface self-sufficient...
  20         Bag, Binds, MonoBinds, InPat, Name, ProtoName,
  21         GlobalNameFun(..), Maybe, UniqSet(..), UniqFM, SrcLoc, Unique,
  22         SplitUniqSupply, Error(..), Pretty(..), PprStyle,
  23         PrettyRep
  24    ) where
  25
  26 import AbsSyn
  27 import CmdLineOpts      ( GlobalSwitch(..) )
  28 import Digraph          ( stronglyConnComp {- MOVED HERE: , isCyclic -} )
  29 import Errors           -- ( unknownSigDeclErr, dupSigDeclErr, methodBindErr )
  30 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  31 import Maybes           ( catMaybes, Maybe(..) )
  32 import Name             ( eqName, cmpName, isUnboundName )
  33 import ProtoName        ( elemByLocalNames, eqByLocalName )
  34 import Rename4          ( rnPolyType4, rnGenPragmas4 )
  35 import RenameAuxFuns    ( GlobalNameFuns(..) )
  36 import RenameMonad4
  37 import RenameExpr4      ( rnMatch4, rnGRHSsAndBinds4, rnPat4 )
  38 import UniqSet
  39 import Util
  40 \end{code}
  41
  42 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
  43 -- place and can be used when complaining.
  44
  45 The code tree received by the function @rnBinds4@ contains definitions
  46 in where-clauses which are all apparently mutually recursive, but which may
  47 not really depend upon each other. For example, in the top level program
  48 \begin{verbatim}
  49 f x = y where a = x
  50               y = x
  51 \end{verbatim}
  52 the definitions of @a@ and @y@ do not depend on each other at all.
  53 Unfortunately, the typechecker cannot always check such definitions.
  54 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
  55 definitions. In Proceedings of the International Symposium on Programming,
  56 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
  57 However, the typechecker usually can check definitions in which only the
  58 strongly connected components have been collected into recursive bindings.
  59 This is precisely what the function @rnBinds4@ does.
  60
  61 ToDo: deal with case where a single monobinds binds the same variable
  62 twice.
  63
  64 Sets of variable names are represented as sets explicitly, rather than lists.
  65
  66 \begin{code}
  67 type DefinedVars = UniqSet Name
  68 type FreeVars    = UniqSet Name
  69 \end{code}
  70
  71 i.e., binders.
  72
  73 The vertag tag is a unique @Int@; the tags only need to be unique
  74 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
  75 (heavy monad machinery not needed).
  76
  77 \begin{code}
  78 type VertexTag  = Int
  79 type Cycle      = [VertexTag]
  80 type Edge       = (VertexTag, VertexTag)
  81 \end{code}
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 %* naming conventions                                                   *
  86 %*                                                                      *
  87 %************************************************************************
  88 \subsection[name-conventions]{Name conventions}
  89
  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 (Binds) 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.
  96
  97 Conventions for variable names are as follows:
  98 \begin{itemize}
  99 \item
 100 new code is given a prime to distinguish it from the old.
 101
 102 \item
 103 a set of variables defined in @Exp@ is written @dvExp@
 104
 105 \item
 106 a set of variables free in @Exp@ is written @fvExp@
 107 \end{itemize}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 %* analysing polymorphic bindings (Binds, Bind, MonoBinds)              *
 112 %*                                                                      *
 113 %************************************************************************
 114 \subsubsection[dep-Binds]{Polymorphic bindings}
 115
 116 Non-recursive expressions are reconstructed without any changes at top
 117 level, although their component expressions may have to be altered.
 118 However, non-recursive expressions are currently not expected as
 119 \Haskell{} programs, and this code should not be executed.
 120
 121 Monomorphic bindings contain information that is returned in a tuple
 122 (a @FlatMonoBindsInfo@) containing:
 123
 124 \begin{enumerate}
 125 \item
 126 a unique @Int@ that serves as the ``vertex tag'' for this binding.
 127
 128 \item
 129 the name of a function or the names in a pattern. These are a set
 130 referred to as @dvLhs@, the defined variables of the left hand side.
 131
 132 \item
 133 the free variables of the body. These are referred to as @fvBody@.
 134
 135 \item
 136 the definition's actual code. This is referred to as just @code@.
 137 \end{enumerate}
 138
 139 The function @nonRecDvFv@ returns two sets of variables. The first is
 140 the set of variables defined in the set of monomorphic bindings, while the
 141 second is the set of free variables in those bindings.
 142
 143 The set of variables defined in a non-recursive binding is just the
 144 union of all of them, as @union@ removes duplicates. However, the
 145 free variables in each successive set of cumulative bindings is the
 146 union of those in the previous set plus those of the newest binding after
 147 the defined variables of the previous set have been removed.
 148
 149 @rnMethodBinds4@ deals only with the declarations in class and
 150 instance declarations.  It expects only to see @FunMonoBind@s, and
 151 it expects the global environment to contain bindings for the binders
 152 (which are all class operations).
 153
 154 \begin{code}
 155 rnTopBinds4     :: ProtoNameBinds -> Rn4M RenamedBinds
 156 rnMethodBinds4  :: Name{-class-} -> ProtoNameMonoBinds -> Rn4M RenamedMonoBinds
 157 rnBinds4        :: ProtoNameBinds -> Rn4M (RenamedBinds, FreeVars, [Name])
 158
 159 rnTopBinds4 EmptyBinds                     = returnRn4 EmptyBinds
 160 rnTopBinds4 (SingleBind (RecBind bind))    = rnTopMonoBinds4 bind []
 161 rnTopBinds4 (BindWith (RecBind bind) sigs) = rnTopMonoBinds4 bind sigs
 162   -- the parser doesn't produce other forms
 163
 164 -- ********************************************************************
 165
 166 rnMethodBinds4 class_name EmptyMonoBinds = returnRn4 EmptyMonoBinds
 167
 168 rnMethodBinds4 class_name (AndMonoBinds mb1 mb2)
 169   = andRn4 AndMonoBinds (rnMethodBinds4 class_name mb1)
 170                         (rnMethodBinds4 class_name mb2)
 171
 172 rnMethodBinds4 class_name (FunMonoBind pname matches locn)
 173   = pushSrcLocRn4 locn                            (
 174     lookupClassOp class_name pname      `thenRn4` \ op_name ->
 175     mapAndUnzipRn4 rnMatch4 matches     `thenRn4` \ (new_matches, _) ->
 176     returnRn4 (FunMonoBind op_name new_matches locn)
 177     )
 178
 179 rnMethodBinds4 class_name (PatMonoBind (VarPatIn pname) grhss_and_binds locn)
 180   = pushSrcLocRn4 locn                            (
 181     lookupClassOp class_name pname      `thenRn4` \ op_name ->
 182     rnGRHSsAndBinds4 grhss_and_binds    `thenRn4` \ (grhss_and_binds', _) ->
 183     returnRn4 (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
 184     )
 185
 186 -- Can't handle method pattern-bindings which bind multiple methods.
 187 rnMethodBinds4 _ mbind@(PatMonoBind other_pat _ locn)
 188   = failButContinueRn4 EmptyMonoBinds (methodBindErr mbind locn)
 189
 190 -- ********************************************************************
 191
 192 rnBinds4 EmptyBinds                     = returnRn4 (EmptyBinds,emptyUniqSet,[])
 193 rnBinds4 (SingleBind (RecBind bind))    = rnNestedMonoBinds4 bind []
 194 rnBinds4 (BindWith (RecBind bind) sigs) = rnNestedMonoBinds4 bind sigs
 195   -- the parser doesn't produce other forms
 196 \end{code}
 197
 198 @rnNestedMonoBinds4@
 199         - collects up the binders for this declaration group,
 200         - checkes that they form a set
 201         - extends the environment to bind them to new local names
 202         - calls @rnMonoBinds4@ to do the real work
 203
 204 In contrast, @rnTopMonoBinds4@ doesn't extend the environment, because that's
 205 already done in pass3.  All it does is call @rnMonoBinds4@ and discards
 206 the free var info.
 207
 208 \begin{code}
 209 rnTopMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig] -> Rn4M RenamedBinds
 210
 211 rnTopMonoBinds4 EmptyMonoBinds sigs = returnRn4 EmptyBinds
 212
 213 rnTopMonoBinds4 mbs sigs
 214  = rnBindSigs4 True{-top-level-} (collectMonoBinders mbs) sigs `thenRn4` \ siglist ->
 215    rnMonoBinds4 mbs siglist `thenRn4` \ (new_binds, fv_set) ->
 216    returnRn4 new_binds
 217
 218
 219 rnNestedMonoBinds4 :: ProtoNameMonoBinds -> [ProtoNameSig]
 220                       -> Rn4M (RenamedBinds, FreeVars, [Name])
 221
 222 rnNestedMonoBinds4 EmptyMonoBinds sigs
 223   = returnRn4 (EmptyBinds, emptyUniqSet, [])
 224
 225 rnNestedMonoBinds4 mbinds sigs  -- Non-empty monobinds
 226   =
 227         -- Extract all the binders in this group,
 228         -- and extend current scope, inventing new names for the new binders
 229         -- This also checks that the names form a set
 230     let
 231         mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
 232         mbinders           = map fst mbinders_w_srclocs
 233     in
 234     namesFromProtoNames
 235         "variable" -- in binding group
 236         mbinders_w_srclocs              `thenRn4` \ new_mbinders ->
 237
 238     extendSS2 new_mbinders (
 239          rnBindSigs4 False{-not top- level-} mbinders sigs `thenRn4` \ siglist ->
 240          rnMonoBinds4 mbinds  siglist
 241     )                                   `thenRn4` \ (new_binds, fv_set) ->
 242     returnRn4 (new_binds, fv_set, new_mbinders)
 243 \end{code}
 244
 245 @rnMonoBinds4@ is used by *both* top-level and nested bindings.  It
 246 assumes that all variables bound in this group are already in scope.
 247 This is done *either* by pass 3 (for the top-level bindings),
 248 *or* by @rnNestedMonoBinds4@ (for the nested ones).
 249
 250 \begin{code}
 251 rnMonoBinds4 :: ProtoNameMonoBinds
 252              -> [RenamedSig]    -- Signatures attached to this group
 253              -> Rn4M (RenamedBinds, FreeVars)
 254
 255 rnMonoBinds4 mbinds siglist
 256   =
 257          -- Rename the bindings, returning a MonoBindsInfo
 258          -- which is a list of indivisible vertices so far as
 259          -- the SCC analysis is concerned
 260     flattenMonoBinds 0 siglist mbinds   `thenRn4` \ (_, mbinds_info) ->
 261
 262          -- Do the SCC analysis
 263     let vertices = mkVertices mbinds_info
 264         edges   = mkEdges vertices mbinds_info
 265
 266         scc_result = stronglyConnComp (==) edges vertices
 267
 268          -- Deal with bound and free-var calculation
 269         rhs_free_vars = foldr f emptyUniqSet mbinds_info
 270
 271         final_binds = reconstructRec scc_result edges mbinds_info
 272
 273         happy_answer = returnRn4 (final_binds, rhs_free_vars)
 274     in
 275     case (inline_sigs_in_recursive_binds final_binds) of
 276       Nothing -> happy_answer
 277       Just names_n_locns ->
 278         addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
 279         {-not so-}happy_answer
 280   where
 281     f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
 282
 283     f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
 284
 285     inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
 286       = case [(n, locn) | (InlineSig n _ locn) <- sigs ] of
 287           []   -> Nothing
 288           sigh ->
 289 #if OMIT_DEFORESTER
 290                 Just sigh
 291 #else
 292                 -- Allow INLINEd recursive functions if they are
 293                 -- designated DEFORESTable too.
 294                 case [(n, locn) | (DeforestSig n locn) <- sigs ] of
 295                         []   -> Just sigh
 296                         sigh -> Nothing
 297 #endif
 298
 299     inline_sigs_in_recursive_binds (ThenBinds b1 b2)
 300       = case (inline_sigs_in_recursive_binds b1) of
 301           Nothing -> inline_sigs_in_recursive_binds b2
 302           Just  x -> Just x -- NB: won't report error(s) in b2
 303
 304     inline_sigs_in_recursive_binds anything_else = Nothing
 305 \end{code}
 306
 307 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
 308 unique ``vertex tags'' on its output; minor plumbing required.
 309
 310 \begin{code}
 311 flattenMonoBinds :: Int                         -- Next free vertex tag
 312                  -> [RenamedSig]                -- Signatures
 313                  -> ProtoNameMonoBinds
 314                  -> Rn4M (Int, FlatMonoBindsInfo)
 315
 316 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, [])
 317
 318 flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
 319   = flattenMonoBinds uniq sigs mB1      `thenRn4` \ (uniq1, flat1) ->
 320     flattenMonoBinds uniq1 sigs mB2     `thenRn4` \ (uniq2, flat2) ->
 321     returnRn4 (uniq2, flat1 ++ flat2)
 322
 323 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 324   = pushSrcLocRn4 locn                            (
 325     rnPat4 pat                          `thenRn4` \ pat' ->
 326     rnGRHSsAndBinds4 grhss_and_binds    `thenRn4` \ (grhss_and_binds', fvs) ->
 327
 328          -- Find which things are bound in this group
 329     let
 330         names_bound_here = collectPatBinders pat'
 331
 332         sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
 333                                   [] sigs
 334
 335         sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
 336
 337         is_elem = isIn "flattenMonoBinds"
 338     in
 339     returnRn4 (
 340         uniq + 1,
 341         [(uniq,
 342           mkUniqSet names_bound_here,
 343            fvs `unionUniqSets` sigs_fvs,
 344            PatMonoBind pat' grhss_and_binds' locn,
 345            sigs_etc_for_here
 346          )]
 347     ))
 348
 349 flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
 350   = pushSrcLocRn4 locn                            (
 351     lookupValue name                    `thenRn4` \ name' ->
 352     mapAndUnzipRn4 rnMatch4 matches     `thenRn4` \ (new_matches, fv_lists) ->
 353     let
 354         fvs = unionManyUniqSets fv_lists
 355
 356         sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs
 357
 358         sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
 359     in
 360     returnRn4 (
 361       uniq + 1,
 362       [(uniq,
 363         singletonUniqSet name',
 364         fvs `unionUniqSets` sigs_fvs,
 365         FunMonoBind name' new_matches locn,
 366         sigs_for_me
 367         )]
 368     ))
 369 \end{code}
 370
 371 Grab type-signatures/user-pragmas of interest:
 372 \begin{code}
 373 sig_for_here want_me acc s@(Sig n _ _ _)     | want_me n = s:acc
 374 sig_for_here want_me acc s@(InlineSig n _ _) | want_me n = s:acc
 375 sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
 376 sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
 377 sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
 378                                              | want_me n = s:acc
 379 sig_for_here want_me acc other_wise                      = acc
 380
 381 -- If a SPECIALIZE pragma is of the "... = blah" form,
 382 -- then we'd better make sure "blah" is taken into
 383 -- acct in the dependency analysis (or we get an
 384 -- unexpected out-of-scope error)! WDP 95/07
 385
 386 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` singletonUniqSet blah
 387 sig_fv _                           acc = acc
 388 \end{code}
 389
 390 %************************************************************************
 391 %*                                                                      *
 392 \subsection[reconstruct-deps]{Reconstructing dependencies}
 393 %*                                                                      *
 394 %************************************************************************
 395
 396 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 397 as the two cases are similar.
 398
 399 \begin{code}
 400 reconstructRec  :: [Cycle]              -- Result of SCC analysis; at least one
 401                 -> [Edge]               -- Original edges
 402                 -> FlatMonoBindsInfo
 403                 -> RenamedBinds
 404
 405 reconstructRec cycles edges mbi
 406   = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
 407   where
 408     reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds
 409
 410     reconstructCycle mbi2 cycle
 411       = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
 412                   _TO_ relevant_binds_and_sigs ->
 413
 414         BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
 415
 416         BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
 417         let
 418             this_gp_sigs        = foldr1 (++) sig_lists
 419             have_sigs           = not (null sig_lists)
 420                 -- ToDo: this might not be the right
 421                 -- thing to call this predicate;
 422                 -- e.g. "have_sigs [[], [], []]" ???????????
 423         in
 424         mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
 425         BEND BEND BEND
 426       where
 427         is_elem = isIn "reconstructRec"
 428
 429         mk_binds :: RenamedMonoBinds -> [RenamedSig]
 430                  -> Bool -> Bool -> RenamedBinds
 431
 432         mk_binds bs ss True  False              = SingleBind (RecBind    bs)
 433         mk_binds bs ss True  True{-have sigs-}  = BindWith   (RecBind    bs) ss
 434         mk_binds bs ss False False              = SingleBind (NonRecBind bs)
 435         mk_binds bs ss False True{-have sigs-}  = BindWith   (NonRecBind bs) ss
 436
 437         -- moved from Digraph, as this is the only use here
 438         -- (avoid overloading cost).  We have to use elem
 439         -- (not FiniteMaps or whatever), because there may be
 440         -- many edges out of one vertex.  We give it its own
 441         -- "elem" just for speed.
 442
 443         isCyclic es []  = panic "isCyclic: empty component"
 444         isCyclic es [v] = (v,v) `elem` es
 445         isCyclic es vs  = True
 446
 447         elem _ []       = False
 448         elem x (y:ys)   = x==y || elem x ys
 449 \end{code}
 450
 451 %************************************************************************
 452 %*                                                                      *
 453 %*      Manipulating FlatMonoBindInfo                                   *
 454 %*                                                                      *
 455 %************************************************************************
 456
 457 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
 458 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
 459 a function binding, and has itself been dependency-analysed and
 460 renamed.
 461
 462 \begin{code}
 463 type FlatMonoBindsInfo
 464   = [(VertexTag,                -- Identifies the vertex
 465       UniqSet Name,             -- Set of names defined in this vertex
 466       UniqSet Name,             -- Set of names used in this vertex
 467       RenamedMonoBinds,         -- Binding for this vertex (always just one binding, either fun or pat)
 468       [RenamedSig])             -- Signatures, if any, for this vertex
 469     ]
 470
 471 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
 472 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 473
 474 mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
 475
 476 mkEdges vertices flat_info
 477  -- An edge (v,v') indicates that v depends on v'
 478  = [ (source_vertex, target_vertex)
 479    | (source_vertex, _, used_names, _, _) <- flat_info,
 480      target_name   <- uniqSetToList used_names,
 481      target_vertex <- vertices_defining target_name flat_info
 482    ]
 483    where
 484    -- If each name only has one binding in this group, then
 485    -- vertices_defining will always return the empty list, or a
 486    -- singleton.  The case when there is more than one binding (an
 487    -- error) needs more thought.
 488
 489    vertices_defining name flat_info2
 490     = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
 491                 name `elementOfUniqSet` names_defined
 492       ]
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 @rnBindSigs4@ checks for: (a)~more than one sig for one thing;
 503 (b)~signatures given for things not bound here; (c)~with suitably
 504 flaggery, that all top-level things have type signatures.
 505
 506 \begin{code}
 507 rnBindSigs4 :: Bool                 -- True <=> top-level binders
 508             -> [ProtoName]          -- Binders for this decl group
 509             -> [ProtoNameSig]
 510             -> Rn4M [RenamedSig]    -- List of Sig constructors
 511
 512 rnBindSigs4 is_toplev binder_pnames sigs
 513   =
 514          -- Rename the signatures
 515          -- Will complain about sigs for variables not in this group
 516     mapRn4 rename_sig sigs   `thenRn4` \ sigs_maybe ->
 517     let
 518         sigs' = catMaybes sigs_maybe
 519
 520          -- Discard unbound ones we've already complained about, so we
 521          -- complain about duplicate ones.
 522
 523         (goodies, dups) = removeDups cmp (filter not_unbound sigs')
 524     in
 525     mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
 526
 527     getSwitchCheckerRn4         `thenRn4` \ sw_chkr ->
 528     getSrcLocRn4                `thenRn4` \ locn ->
 529
 530     (if (is_toplev && sw_chkr SigsRequired) then
 531         let
 532             sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
 533         in
 534         mapRn4 (addErrRn4 . missingSigErr locn) sig_frees
 535      else
 536         returnRn4 []
 537     )                                       `thenRn4_`
 538
 539     returnRn4 sigs' -- bad ones and all:
 540                     -- we need bindings of *some* sort for every name
 541   where
 542     rename_sig (Sig v ty pragma src_loc)
 543       = pushSrcLocRn4 src_loc   (
 544
 545         if not (v `elemByLocalNames` binder_pnames) then
 546            addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_`
 547            returnRn4 Nothing
 548         else
 549            lookupValue v                                `thenRn4` \ new_v ->
 550            rnPolyType4 False True nullTyVarNamesEnv ty  `thenRn4` \ new_ty ->
 551            recoverQuietlyRn4 NoGenPragmas (
 552                 rnGenPragmas4 pragma
 553            )                                        `thenRn4` \ new_pragma ->
 554            returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
 555         )
 556
 557     -- and now, the various flavours of value-modifying user-pragmas:
 558
 559     rename_sig (SpecSig v ty using src_loc)
 560       = pushSrcLocRn4 src_loc   (
 561
 562         if not (v `elemByLocalNames` binder_pnames) then
 563            addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_`
 564            returnRn4 Nothing
 565         else
 566            lookupValue v                                `thenRn4` \ new_v ->
 567            rnPolyType4 False True nullTyVarNamesEnv ty  `thenRn4` \ new_ty ->
 568            rn_using using                               `thenRn4` \ new_using ->
 569            returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
 570         )
 571       where
 572         rn_using Nothing  = returnRn4 Nothing
 573         rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
 574                             returnRn4 (Just new_x)
 575
 576     rename_sig (InlineSig v howto src_loc)
 577       = pushSrcLocRn4 src_loc   (
 578
 579         if not (v `elemByLocalNames` binder_pnames) then
 580            addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_`
 581            returnRn4 Nothing
 582         else
 583            lookupValue v        `thenRn4` \ new_v ->
 584            returnRn4 (Just (InlineSig new_v howto src_loc))
 585         )
 586
 587     rename_sig (DeforestSig v src_loc)
 588       = pushSrcLocRn4 src_loc   (
 589
 590         if not (v `elemByLocalNames` binder_pnames) then
 591            addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_`
 592            returnRn4 Nothing
 593         else
 594            lookupValue v        `thenRn4` \ new_v ->
 595            returnRn4 (Just (DeforestSig new_v src_loc))
 596         )
 597
 598     rename_sig (MagicUnfoldingSig v str src_loc)
 599       = pushSrcLocRn4 src_loc   (
 600
 601         if not (v `elemByLocalNames` binder_pnames) then
 602            addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_`
 603            returnRn4 Nothing
 604         else
 605            lookupValue v        `thenRn4` \ new_v ->
 606            returnRn4 (Just (MagicUnfoldingSig new_v str src_loc))
 607         )
 608
 609     not_unbound :: RenamedSig -> Bool
 610
 611     not_unbound (Sig n _ _ _)             = not (isUnboundName n)
 612     not_unbound (SpecSig n _ _ _)         = not (isUnboundName n)
 613     not_unbound (InlineSig n _ _)         = not (isUnboundName n)
 614     not_unbound (DeforestSig n _)         = not (isUnboundName n)
 615     not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
 616
 617     -------------------------------------
 618     sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName
 619         -- Return "Just x" if "x" has no type signature in
 620         -- sigs.  Nothing, otherwise.
 621
 622     sig_free [] ny = Just ny
 623     sig_free (Sig nx _ _ _ : rest) ny
 624       = if (nx `eqByLocalName` ny) then Nothing else sig_free rest ny
 625     sig_free (_ : rest) ny = sig_free rest ny
 626
 627     -------------------------------------
 628     cmp :: RenamedSig -> RenamedSig -> TAG_
 629
 630     cmp (Sig n1 _ _ _)             (Sig n2 _ _ _)             = n1 `cmpName` n2
 631     cmp (InlineSig n1 _ _)         (InlineSig n2 _ _)         = n1 `cmpName` n2
 632     cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2
 633     cmp (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
 634       = -- may have many specialisations for one value;
 635         -- but not ones that are exactly the same...
 636         case (n1 `cmpName` n2) of
 637           EQ_   -> cmpPolyType cmpName ty1 ty2
 638           other -> other
 639
 640     cmp other_1 other_2 -- tags *must* be different
 641       = let tag1 = tag other_1
 642             tag2 = tag other_2
 643         in
 644         if tag1 _LT_ tag2 then LT_ else GT_
 645
 646     tag (Sig n1 _ _ _)             = (ILIT(1) :: FAST_INT)
 647     tag (SpecSig n1 _ _ _)         = ILIT(2)
 648     tag (InlineSig n1 _ _)         = ILIT(3)
 649     tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
 650     tag (DeforestSig n1 _)         = ILIT(5)
 651     tag _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance
 652 \end{code}