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 -- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
 279 --      addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
 280         {-not so-}happy_answer
 281   where
 282     f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
 283
 284     f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
 285
 286     inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
 287       = case [(n, locn) | (InlineSig n _ locn) <- sigs ] of
 288           []   -> Nothing
 289           sigh ->
 290 #if OMIT_DEFORESTER
 291                 Just sigh
 292 #else
 293                 -- Allow INLINEd recursive functions if they are
 294                 -- designated DEFORESTable too.
 295                 case [(n, locn) | (DeforestSig n locn) <- sigs ] of
 296                         []   -> Just sigh
 297                         sigh -> Nothing
 298 #endif
 299
 300     inline_sigs_in_recursive_binds (ThenBinds b1 b2)
 301       = case (inline_sigs_in_recursive_binds b1) of
 302           Nothing -> inline_sigs_in_recursive_binds b2
 303           Just  x -> Just x -- NB: won't report error(s) in b2
 304
 305     inline_sigs_in_recursive_binds anything_else = Nothing
 306 \end{code}
 307
 308 @flattenMonoBinds@ is ever-so-slightly magical in that it sticks
 309 unique ``vertex tags'' on its output; minor plumbing required.
 310
 311 \begin{code}
 312 flattenMonoBinds :: Int                         -- Next free vertex tag
 313                  -> [RenamedSig]                -- Signatures
 314                  -> ProtoNameMonoBinds
 315                  -> Rn4M (Int, FlatMonoBindsInfo)
 316
 317 flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn4 (uniq, [])
 318
 319 flattenMonoBinds uniq sigs (AndMonoBinds mB1 mB2)
 320   = flattenMonoBinds uniq sigs mB1      `thenRn4` \ (uniq1, flat1) ->
 321     flattenMonoBinds uniq1 sigs mB2     `thenRn4` \ (uniq2, flat2) ->
 322     returnRn4 (uniq2, flat1 ++ flat2)
 323
 324 flattenMonoBinds uniq sigs (PatMonoBind pat grhss_and_binds locn)
 325   = pushSrcLocRn4 locn                            (
 326     rnPat4 pat                          `thenRn4` \ pat' ->
 327     rnGRHSsAndBinds4 grhss_and_binds    `thenRn4` \ (grhss_and_binds', fvs) ->
 328
 329          -- Find which things are bound in this group
 330     let
 331         names_bound_here = collectPatBinders pat'
 332
 333         sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
 334                                   [] sigs
 335
 336         sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
 337
 338         is_elem = isIn "flattenMonoBinds"
 339     in
 340     returnRn4 (
 341         uniq + 1,
 342         [(uniq,
 343           mkUniqSet names_bound_here,
 344            fvs `unionUniqSets` sigs_fvs,
 345            PatMonoBind pat' grhss_and_binds' locn,
 346            sigs_etc_for_here
 347          )]
 348     ))
 349
 350 flattenMonoBinds uniq sigs (FunMonoBind name matches locn)
 351   = pushSrcLocRn4 locn                            (
 352     lookupValue name                    `thenRn4` \ name' ->
 353     mapAndUnzipRn4 rnMatch4 matches     `thenRn4` \ (new_matches, fv_lists) ->
 354     let
 355         fvs = unionManyUniqSets fv_lists
 356
 357         sigs_for_me = foldl (sig_for_here (\ n -> n `eqName` name')) [] sigs
 358
 359         sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
 360     in
 361     returnRn4 (
 362       uniq + 1,
 363       [(uniq,
 364         singletonUniqSet name',
 365         fvs `unionUniqSets` sigs_fvs,
 366         FunMonoBind name' new_matches locn,
 367         sigs_for_me
 368         )]
 369     ))
 370 \end{code}
 371
 372 Grab type-signatures/user-pragmas of interest:
 373 \begin{code}
 374 sig_for_here want_me acc s@(Sig n _ _ _)     | want_me n = s:acc
 375 sig_for_here want_me acc s@(InlineSig n _ _) | want_me n = s:acc
 376 sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
 377 sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
 378 sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
 379                                              | want_me n = s:acc
 380 sig_for_here want_me acc other_wise                      = acc
 381
 382 -- If a SPECIALIZE pragma is of the "... = blah" form,
 383 -- then we'd better make sure "blah" is taken into
 384 -- acct in the dependency analysis (or we get an
 385 -- unexpected out-of-scope error)! WDP 95/07
 386
 387 sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` singletonUniqSet blah
 388 sig_fv _                           acc = acc
 389 \end{code}
 390
 391 %************************************************************************
 392 %*                                                                      *
 393 \subsection[reconstruct-deps]{Reconstructing dependencies}
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 This @MonoBinds@- and @ClassDecls@-specific code is segregated here,
 398 as the two cases are similar.
 399
 400 \begin{code}
 401 reconstructRec  :: [Cycle]              -- Result of SCC analysis; at least one
 402                 -> [Edge]               -- Original edges
 403                 -> FlatMonoBindsInfo
 404                 -> RenamedBinds
 405
 406 reconstructRec cycles edges mbi
 407   = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
 408   where
 409     reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedBinds
 410
 411     reconstructCycle mbi2 cycle
 412       = BIND [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
 413                   _TO_ relevant_binds_and_sigs ->
 414
 415         BIND (unzip relevant_binds_and_sigs) _TO_ (binds, sig_lists) ->
 416
 417         BIND (foldr AndMonoBinds EmptyMonoBinds binds) _TO_ this_gp_binds ->
 418         let
 419             this_gp_sigs        = foldr1 (++) sig_lists
 420             have_sigs           = not (null sig_lists)
 421                 -- ToDo: this might not be the right
 422                 -- thing to call this predicate;
 423                 -- e.g. "have_sigs [[], [], []]" ???????????
 424         in
 425         mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
 426         BEND BEND BEND
 427       where
 428         is_elem = isIn "reconstructRec"
 429
 430         mk_binds :: RenamedMonoBinds -> [RenamedSig]
 431                  -> Bool -> Bool -> RenamedBinds
 432
 433         mk_binds bs ss True  False              = SingleBind (RecBind    bs)
 434         mk_binds bs ss True  True{-have sigs-}  = BindWith   (RecBind    bs) ss
 435         mk_binds bs ss False False              = SingleBind (NonRecBind bs)
 436         mk_binds bs ss False True{-have sigs-}  = BindWith   (NonRecBind bs) ss
 437
 438         -- moved from Digraph, as this is the only use here
 439         -- (avoid overloading cost).  We have to use elem
 440         -- (not FiniteMaps or whatever), because there may be
 441         -- many edges out of one vertex.  We give it its own
 442         -- "elem" just for speed.
 443
 444         isCyclic es []  = panic "isCyclic: empty component"
 445         isCyclic es [v] = (v,v) `elem` es
 446         isCyclic es vs  = True
 447
 448         elem _ []       = False
 449         elem x (y:ys)   = x==y || elem x ys
 450 \end{code}
 451
 452 %************************************************************************
 453 %*                                                                      *
 454 %*      Manipulating FlatMonoBindInfo                                   *
 455 %*                                                                      *
 456 %************************************************************************
 457
 458 During analysis a @MonoBinds@ is flattened to a @FlatMonoBindsInfo@.
 459 The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
 460 a function binding, and has itself been dependency-analysed and
 461 renamed.
 462
 463 \begin{code}
 464 type FlatMonoBindsInfo
 465   = [(VertexTag,                -- Identifies the vertex
 466       UniqSet Name,             -- Set of names defined in this vertex
 467       UniqSet Name,             -- Set of names used in this vertex
 468       RenamedMonoBinds,         -- Binding for this vertex (always just one binding, either fun or pat)
 469       [RenamedSig])             -- Signatures, if any, for this vertex
 470     ]
 471
 472 mkVertices :: FlatMonoBindsInfo -> [VertexTag]
 473 mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
 474
 475 mkEdges :: [VertexTag] -> FlatMonoBindsInfo -> [Edge]
 476
 477 mkEdges vertices flat_info
 478  -- An edge (v,v') indicates that v depends on v'
 479  = [ (source_vertex, target_vertex)
 480    | (source_vertex, _, used_names, _, _) <- flat_info,
 481      target_name   <- uniqSetToList used_names,
 482      target_vertex <- vertices_defining target_name flat_info
 483    ]
 484    where
 485    -- If each name only has one binding in this group, then
 486    -- vertices_defining will always return the empty list, or a
 487    -- singleton.  The case when there is more than one binding (an
 488    -- error) needs more thought.
 489
 490    vertices_defining name flat_info2
 491     = [ vertex |  (vertex, names_defined, _, _, _) <- flat_info2,
 492                 name `elementOfUniqSet` names_defined
 493       ]
 494 \end{code}
 495
 496
 497 %************************************************************************
 498 %*                                                                      *
 499 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 500 %*                                                                      *
 501 %************************************************************************
 502
 503 @rnBindSigs4@ checks for: (a)~more than one sig for one thing;
 504 (b)~signatures given for things not bound here; (c)~with suitably
 505 flaggery, that all top-level things have type signatures.
 506
 507 \begin{code}
 508 rnBindSigs4 :: Bool                 -- True <=> top-level binders
 509             -> [ProtoName]          -- Binders for this decl group
 510             -> [ProtoNameSig]
 511             -> Rn4M [RenamedSig]    -- List of Sig constructors
 512
 513 rnBindSigs4 is_toplev binder_pnames sigs
 514   =
 515          -- Rename the signatures
 516          -- Will complain about sigs for variables not in this group
 517     mapRn4 rename_sig sigs   `thenRn4` \ sigs_maybe ->
 518     let
 519         sigs' = catMaybes sigs_maybe
 520
 521          -- Discard unbound ones we've already complained about, so we
 522          -- complain about duplicate ones.
 523
 524         (goodies, dups) = removeDups cmp (filter not_unbound sigs')
 525     in
 526     mapRn4 (addErrRn4 . dupSigDeclErr) dups `thenRn4_`
 527
 528     getSwitchCheckerRn4         `thenRn4` \ sw_chkr ->
 529     getSrcLocRn4                `thenRn4` \ locn ->
 530
 531     (if (is_toplev && sw_chkr SigsRequired) then
 532         let
 533             sig_frees = catMaybes (map (sig_free sigs) binder_pnames)
 534         in
 535         mapRn4 (addErrRn4 . missingSigErr locn) sig_frees
 536      else
 537         returnRn4 []
 538     )                                       `thenRn4_`
 539
 540     returnRn4 sigs' -- bad ones and all:
 541                     -- we need bindings of *some* sort for every name
 542   where
 543     rename_sig (Sig v ty pragma src_loc)
 544       = pushSrcLocRn4 src_loc   (
 545
 546         if not (v `elemByLocalNames` binder_pnames) then
 547            addErrRn4 (unknownSigDeclErr "type signature" v src_loc) `thenRn4_`
 548            returnRn4 Nothing
 549         else
 550            lookupValue v                                `thenRn4` \ new_v ->
 551            rnPolyType4 False True nullTyVarNamesEnv ty  `thenRn4` \ new_ty ->
 552            recoverQuietlyRn4 NoGenPragmas (
 553                 rnGenPragmas4 pragma
 554            )                                        `thenRn4` \ new_pragma ->
 555            returnRn4 (Just (Sig new_v new_ty new_pragma src_loc))
 556         )
 557
 558     -- and now, the various flavours of value-modifying user-pragmas:
 559
 560     rename_sig (SpecSig v ty using src_loc)
 561       = pushSrcLocRn4 src_loc   (
 562
 563         if not (v `elemByLocalNames` binder_pnames) then
 564            addErrRn4 (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn4_`
 565            returnRn4 Nothing
 566         else
 567            lookupValue v                                `thenRn4` \ new_v ->
 568            rnPolyType4 False True nullTyVarNamesEnv ty  `thenRn4` \ new_ty ->
 569            rn_using using                               `thenRn4` \ new_using ->
 570            returnRn4 (Just (SpecSig new_v new_ty new_using src_loc))
 571         )
 572       where
 573         rn_using Nothing  = returnRn4 Nothing
 574         rn_using (Just x) = lookupValue x `thenRn4` \ new_x ->
 575                             returnRn4 (Just new_x)
 576
 577     rename_sig (InlineSig v howto src_loc)
 578       = pushSrcLocRn4 src_loc   (
 579
 580         if not (v `elemByLocalNames` binder_pnames) then
 581            addErrRn4 (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn4_`
 582            returnRn4 Nothing
 583         else
 584            lookupValue v        `thenRn4` \ new_v ->
 585            returnRn4 (Just (InlineSig new_v howto src_loc))
 586         )
 587
 588     rename_sig (DeforestSig v src_loc)
 589       = pushSrcLocRn4 src_loc   (
 590
 591         if not (v `elemByLocalNames` binder_pnames) then
 592            addErrRn4 (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn4_`
 593            returnRn4 Nothing
 594         else
 595            lookupValue v        `thenRn4` \ new_v ->
 596            returnRn4 (Just (DeforestSig new_v src_loc))
 597         )
 598
 599     rename_sig (MagicUnfoldingSig v str src_loc)
 600       = pushSrcLocRn4 src_loc   (
 601
 602         if not (v `elemByLocalNames` binder_pnames) then
 603            addErrRn4 (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn4_`
 604            returnRn4 Nothing
 605         else
 606            lookupValue v        `thenRn4` \ new_v ->
 607            returnRn4 (Just (MagicUnfoldingSig new_v str src_loc))
 608         )
 609
 610     not_unbound :: RenamedSig -> Bool
 611
 612     not_unbound (Sig n _ _ _)             = not (isUnboundName n)
 613     not_unbound (SpecSig n _ _ _)         = not (isUnboundName n)
 614     not_unbound (InlineSig n _ _)         = not (isUnboundName n)
 615     not_unbound (DeforestSig n _)         = not (isUnboundName n)
 616     not_unbound (MagicUnfoldingSig n _ _) = not (isUnboundName n)
 617
 618     -------------------------------------
 619     sig_free :: [ProtoNameSig] -> ProtoName -> Maybe ProtoName
 620         -- Return "Just x" if "x" has no type signature in
 621         -- sigs.  Nothing, otherwise.
 622
 623     sig_free [] ny = Just ny
 624     sig_free (Sig nx _ _ _ : rest) ny
 625       = if (nx `eqByLocalName` ny) then Nothing else sig_free rest ny
 626     sig_free (_ : rest) ny = sig_free rest ny
 627
 628     -------------------------------------
 629     cmp :: RenamedSig -> RenamedSig -> TAG_
 630
 631     cmp (Sig n1 _ _ _)             (Sig n2 _ _ _)             = n1 `cmpName` n2
 632     cmp (InlineSig n1 _ _)         (InlineSig n2 _ _)         = n1 `cmpName` n2
 633     cmp (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmpName` n2
 634     cmp (SpecSig n1 ty1 _ _)       (SpecSig n2 ty2 _ _)
 635       = -- may have many specialisations for one value;
 636         -- but not ones that are exactly the same...
 637         case (n1 `cmpName` n2) of
 638           EQ_   -> cmpPolyType cmpName ty1 ty2
 639           other -> other
 640
 641     cmp other_1 other_2 -- tags *must* be different
 642       = let tag1 = tag other_1
 643             tag2 = tag other_2
 644         in
 645         if tag1 _LT_ tag2 then LT_ else GT_
 646
 647     tag (Sig n1 _ _ _)             = (ILIT(1) :: FAST_INT)
 648     tag (SpecSig n1 _ _ _)         = ILIT(2)
 649     tag (InlineSig n1 _ _)         = ILIT(3)
 650     tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
 651     tag (DeforestSig n1 _)         = ILIT(5)
 652     tag _ = case (panic "tag(RenameBinds4)") of { s -> tag s } -- BUG avoidance
 653 \end{code}