ghc/compiler/simplCore/SimplEnv.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1996
   3 %
   4 \section[SimplEnv]{Environment stuff for the simplifier}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module SimplEnv (
  10         nullSimplEnv, combineSimplEnv,
  11         pprSimplEnv, -- debugging only
  12
  13         extendTyEnv, extendTyEnvList,
  14         simplTy, simplTyInId,
  15
  16         extendIdEnvWithAtom, extendIdEnvWithAtoms,
  17         extendIdEnvWithClone, extendIdEnvWithClones,
  18         lookupId,
  19
  20
  21         markDangerousOccs,
  22         lookupRhsInfo, lookupOutIdEnv, isEvaluated,
  23         extendEnvGivenBinding, extendEnvGivenNewRhs,
  24         extendEnvForRecBinding, extendEnvGivenRhsInfo,
  25
  26         lookForConstructor,
  27
  28         getSwitchChecker, switchIsSet, getSimplIntSwitch, switchOffInlining,
  29
  30         setEnclosingCC, getEnclosingCC,
  31
  32         -- Types
  33         SYN_IE(SwitchChecker),
  34         SimplEnv,
  35         SYN_IE(InIdEnv), SYN_IE(InTypeEnv),
  36         UnfoldConApp,
  37         RhsInfo(..),
  38
  39         SYN_IE(InId),  SYN_IE(InBinder),  SYN_IE(InBinding),  SYN_IE(InType),
  40         SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType),
  41
  42         SYN_IE(InExpr),  SYN_IE(InAlts),  SYN_IE(InDefault),  SYN_IE(InArg),
  43         SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg)
  44     ) where
  45
  46 IMP_Ubiq(){-uitous-}
  47
  48 IMPORT_DELOOPER(SmplLoop)               -- breaks the MagicUFs / SimplEnv loop
  49
  50 import BinderInfo       ( orBinderInfo, andBinderInfo, noBinderInfo,
  51                           BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
  52                         )
  53 import CgCompInfo       ( uNFOLDING_CREATION_THRESHOLD )
  54 import CmdLineOpts      ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
  55 import CoreSyn
  56 import CoreUnfold       ( mkFormSummary, exprSmallEnoughToDup,
  57                           Unfolding(..), SimpleUnfolding(..), FormSummary(..),
  58                           mkSimpleUnfolding,
  59                           calcUnfoldingGuidance, UnfoldingGuidance(..)
  60                         )
  61 import CoreUtils        ( coreExprCc, unTagBinders )
  62 import CostCentre       ( CostCentre, noCostCentre, noCostCentreAttached )
  63 import FiniteMap        -- lots of things
  64 import Id               ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
  65                           applyTypeEnvToId,
  66                           nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
  67                           addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
  68                           SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
  69 import IdInfo           ( bottomIsGuaranteed, StrictnessInfo )
  70 import Literal          ( isNoRepLit, Literal{-instances-} )
  71 import Maybes           ( maybeToBool, expectJust )
  72 import Name             ( isLocallyDefined )
  73 import OccurAnal        ( occurAnalyseExpr )
  74 import Outputable       ( Outputable(..){-instances-} )
  75 import PprCore          -- various instances
  76 import PprStyle         ( PprStyle(..) )
  77 import PprType          ( GenType, GenTyVar )
  78 import Pretty
  79 import Type             ( eqTy, applyTypeEnvToTy )
  80 import TyVar            ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList,
  81                           SYN_IE(TyVarEnv), GenTyVar{-instance Eq-}
  82                         )
  83 import Unique           ( Unique{-instance Outputable-} )
  84 import UniqFM           ( addToUFM_C, ufmToList, eltsUFM
  85                         )
  86 --import UniqSet                -- lots of things
  87 import Usage            ( SYN_IE(UVar), GenUsage{-instances-} )
  88 import Util             ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic )
  89
  90 type TypeEnv = TyVarEnv Type
  91 cmpType = panic "cmpType (SimplEnv)"
  92 \end{code}
  93
  94 %************************************************************************
  95 %*                                                                      *
  96 \subsection[Simplify-types]{Type declarations}
  97 %*                                                                      *
  98 %************************************************************************
  99
 100 \begin{code}
 101 type InId      = Id                     -- Not yet cloned
 102 type InBinder  = (InId, BinderInfo)
 103 type InType    = Type                   -- Ditto
 104 type InBinding = SimplifiableCoreBinding
 105 type InExpr    = SimplifiableCoreExpr
 106 type InAlts    = SimplifiableCoreCaseAlts
 107 type InDefault = SimplifiableCoreCaseDefault
 108 type InArg     = SimplifiableCoreArg
 109
 110 type OutId      = Id                    -- Cloned
 111 type OutBinder  = Id
 112 type OutType    = Type                  -- Cloned
 113 type OutBinding = CoreBinding
 114 type OutExpr    = CoreExpr
 115 type OutAlts    = CoreCaseAlts
 116 type OutDefault = CoreCaseDefault
 117 type OutArg     = CoreArg
 118
 119 type SwitchChecker = SimplifierSwitch -> SwitchResult
 120 \end{code}
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsubsection{The @SimplEnv@ type}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128
 129 INVARIANT: we assume {\em no shadowing}.  (ToDo: How can we ASSERT
 130 this? WDP 94/06) This allows us to neglect keeping everything paired
 131 with its static environment.
 132
 133 The environment contains bindings for all
 134         {\em in-scope,}
 135         {\em locally-defined}
 136 things.
 137
 138 For such things, any unfolding is found in the environment, not in the
 139 Id.  Unfoldings in the Id itself are used only for imported things
 140 (otherwise we get trouble because we have to simplify the unfoldings
 141 inside the Ids, etc.).
 142
 143 \begin{code}
 144 data SimplEnv
 145   = SimplEnv
 146         SwitchChecker
 147         CostCentre              -- The enclosing cost-centre (when profiling)
 148         InTypeEnv               -- Maps old type variables to new clones
 149         InIdEnv                 -- Maps locally-bound Ids to new clones
 150         OutIdEnv                -- Info about the values of OutIds
 151         ConAppMap               -- Maps constructor applications back to OutIds
 152
 153
 154 nullSimplEnv :: SwitchChecker -> SimplEnv
 155
 156 nullSimplEnv sw_chkr
 157   = SimplEnv sw_chkr noCostCentre nullTyVarEnv nullIdEnv nullIdEnv nullConApps
 158
 159 combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv
 160 combineSimplEnv env@(SimplEnv chkr _       _      _         out_id_env con_apps)
 161             new_env@(SimplEnv _    encl_cc ty_env in_id_env _          _       )
 162   = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
 163
 164 pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv"
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsubsection{Command-line switches}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 \begin{code}
 175 getSwitchChecker :: SimplEnv -> SwitchChecker
 176 getSwitchChecker (SimplEnv chkr _ _ _ _ _) = chkr
 177
 178 switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
 179 switchIsSet (SimplEnv chkr _ _ _ _ _) switch
 180   = switchIsOn chkr switch
 181
 182 getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
 183 getSimplIntSwitch chkr switch
 184   = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch)
 185
 186         -- Crude, but simple
 187 switchOffInlining :: SimplEnv -> SimplEnv
 188 switchOffInlining (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 189   = SimplEnv chkr' encl_cc ty_env in_id_env out_id_env con_apps
 190   where
 191     chkr' EssentialUnfoldingsOnly = SwBool True
 192     chkr' other                   = chkr other
 193 \end{code}
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsubsection{The ``enclosing cost-centre''}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 \begin{code}
 202 setEnclosingCC :: SimplEnv -> CostCentre -> SimplEnv
 203
 204 setEnclosingCC (SimplEnv chkr _ ty_env in_id_env out_id_env con_apps) encl_cc
 205   = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps
 206
 207 getEnclosingCC :: SimplEnv -> CostCentre
 208 getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = encl_cc
 209 \end{code}
 210
 211 %************************************************************************
 212 %*                                                                      *
 213 \subsubsection{The @TypeEnv@ part}
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 \begin{code}
 218 type InTypeEnv = TypeEnv        -- Maps InTyVars to OutTypes
 219
 220 extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv
 221 extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty
 222   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 223   where
 224     new_ty_env = addOneToTyVarEnv ty_env tyvar ty
 225
 226 extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv
 227 extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs
 228   = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps
 229   where
 230     new_ty_env = growTyVarEnvList ty_env pairs
 231
 232 simplTy     (SimplEnv _ _ ty_env _ _ _) ty = applyTypeEnvToTy ty_env ty
 233 simplTyInId (SimplEnv _ _ ty_env _ _ _) id = applyTypeEnvToId ty_env id
 234 \end{code}
 235
 236 %************************************************************************
 237 %*                                                                      *
 238 \subsubsection{The ``Id env'' part}
 239 %*                                                                      *
 240 %************************************************************************
 241
 242 \begin{code}
 243 type InIdEnv = IdEnv OutArg     -- Maps InIds to their value
 244                                 -- Usually this is just the cloned Id, but if
 245                                 -- if the orig defn is a let-binding, and
 246                                 -- the RHS of the let simplifies to an atom,
 247                                 -- we just bind the variable to that atom, and
 248                                 -- elide the let.
 249 \end{code}
 250
 251 \begin{code}
 252 lookupId :: SimplEnv -> Id -> OutArg
 253
 254 lookupId (SimplEnv _ _ _ in_id_env _ _) id
 255   = case (lookupIdEnv in_id_env id) of
 256       Just atom -> atom
 257       Nothing   -> VarArg id
 258 \end{code}
 259
 260 \begin{code}
 261 extendIdEnvWithAtom
 262         :: SimplEnv
 263         -> InBinder
 264         -> OutArg{-Val args only, please-}
 265         -> SimplEnv
 266
 267 extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 268                     (in_id,occ_info) atom
 269   = SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
 270   where
 271     new_in_id_env  = addOneToIdEnv in_id_env in_id atom
 272     new_out_id_env = case atom of
 273                         LitArg _      -> out_id_env
 274                         VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
 275
 276 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
 277 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 278
 279
 280 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
 281
 282 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 283                      (in_id,_) out_id
 284   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 285   where
 286     new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
 287
 288 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
 289 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 290                       in_binders out_ids
 291   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 292   where
 293     new_in_id_env = growIdEnvList in_id_env bindings
 294     bindings      = zipEqual "extendIdEnvWithClones"
 295                              [id | (id,_) <- in_binders]
 296                              (map VarArg out_ids)
 297 \end{code}
 298
 299 %************************************************************************
 300 %*                                                                      *
 301 \subsubsection{The @OutIdEnv@}
 302 %*                                                                      *
 303 %************************************************************************
 304
 305
 306 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
 307 both locally-bound ones, and perhaps some imported ones too.
 308
 309 \begin{code}
 310 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
 311
 312 \end{code}
 313
 314 The "Id" part is just so that we can recover the domain of the mapping, which
 315 IdEnvs don't allow directly.
 316
 317 The @BinderInfo@ tells about the occurrences of the @OutId@.
 318 Anything that isn't in here should be assumed to occur many times.
 319 We keep this info so we can modify it when something changes.
 320
 321 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
 322
 323 \begin{code}
 324 data RhsInfo = NoRhsInfo
 325              | OtherLit [Literal]               -- It ain't one of these
 326              | OtherCon [Id]                    -- It ain't one of these
 327
 328              | InUnfolding SimplEnv             -- Un-simplified unfolding
 329                            SimpleUnfolding      -- (need to snag envts therefore)
 330
 331              | OutUnfolding CostCentre
 332                             SimpleUnfolding     -- Already-simplified unfolding
 333
 334 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
 335 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
 336
 337 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
 338 lookupRhsInfo env id
 339   = case lookupOutIdEnv env id of
 340         Just (_,_,info) -> info
 341         Nothing         -> NoRhsInfo
 342
 343 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
 344                  -> (OutId, BinderInfo, RhsInfo)
 345                  -> (OutId, BinderInfo, RhsInfo)
 346 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 347   = (id, occ, new_info)
 348   where
 349     new_info = case (info1, info2) of
 350                 (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
 351                 (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
 352                 (_,            NoRhsInfo)    -> info1
 353                 other                        -> info2
 354 \end{code}
 355
 356
 357 \begin{code}
 358 isEvaluated :: RhsInfo -> Bool
 359 isEvaluated (OtherLit _) = True
 360 isEvaluated (OtherCon _) = True
 361 isEvaluated (InUnfolding _  (SimpleUnfolding ValueForm _ expr)) = True
 362 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
 363 isEvaluated other = False
 364 \end{code}
 365
 366 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 367 of a new binding.  There is a horrid case we have to take care about,
 368 due to Andr\'e Santos:
 369 @
 370     type Array_type b   = Array Int b;
 371     type Descr_type     = (Int,Int);
 372
 373     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 374     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 375
 376     f_iaamain a_xs=
 377         let {
 378             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 379             f_aareorder a_index a_ar=
 380                 let {
 381                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 382                  } in  tabulate f_aareorder' (bounds a_ar);
 383             r_index=tabulate ((+) 1) (1,1);
 384             arr    = listArray (1,1) a_xs;
 385             arg    = f_aareorder r_index arr
 386          } in  elems arg
 387 @
 388 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 389 @
 390         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 391                in tabulate f_aareorder' (bounds arr)
 392 @
 393 Note that r_index is not inlined, because it was bound to a_index which
 394 occurs inside a lambda.
 395
 396 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 397 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 398 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 399 will get inlined inside the lambda.  AARGH.
 400
 401 Solution: when we occurrence-analyse the new RHS we have to go back
 402 and modify the info recorded in the UnfoldEnv for the free vars
 403 of the RHS.  In the example we'd go back and record that r_index is now used
 404 inside a lambda.
 405
 406 \begin{code}
 407 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 408 extendEnvGivenNewRhs env out_id rhs
 409   = extendEnvGivenBinding env noBinderInfo out_id rhs
 410
 411 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 412 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 413                       occ_info out_id rhs
 414   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
 415   where
 416     new_con_apps   = extendConApps con_apps out_id rhs
 417     new_out_id_env = case guidance of
 418                         UnfoldNever -> out_id_env               -- No new stuff to put in
 419                         other       -> out_id_env_with_unfolding
 420
 421         -- If there is an unfolding, we add rhs-info for out_id,
 422         -- *and* modify the occ info for rhs's interesting free variables.
 423         --
 424         -- If the out_id is already in the OutIdEnv, then just replace the
 425         -- unfolding, leaving occurrence info alone (this must then
 426         -- be a call via extendEnvGivenNewRhs).
 427     out_id_env_with_unfolding = foldl modifyOccInfo env1 full_fv_occ_info
 428                 -- full_fv_occ_info combines the occurrence of the current binder
 429                 -- with the occurrences of its RHS's free variables.
 430     full_fv_occ_info          = [ (uniq, fv_occ `andBinderInfo` occ_info)
 431                                 | (uniq,fv_occ) <- ufmToList fv_occ_info
 432                                 ]
 433     env1                      = addToUFM_C modifyOutEnvItem out_id_env out_id
 434                                            (out_id, occ_info, rhs_info)
 435
 436         -- Occurrence-analyse the RHS
 437         -- The "interesting" free variables we want occurrence info for are those
 438         -- in the OutIdEnv that have only a single occurrence right now.
 439     (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
 440     interesting_fvs         = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
 441
 442         -- Compute unfolding details
 443     rhs_info     = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
 444     form_summary = mkFormSummary rhs
 445
 446     guidance = mkSimplUnfoldingGuidance chkr out_id rhs
 447
 448         -- Compute cost centre for thing
 449     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 450             | otherwise                    = expr_cc
 451             where
 452               expr_cc =  coreExprCc rhs
 453
 454 {-      We need to be pretty careful when extending
 455         the environment with RHS info in recursive groups.
 456
 457 Here's a nasty example:
 458
 459         letrec  r = f x
 460                 t = r
 461                 x = ...t...
 462         in
 463         ...t...
 464
 465 Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
 466 But the pre-simplified t's rhs is an atom, r, so we may also decide to
 467 inline t everywhere.  But if we do *both* these reasonable things we get
 468
 469         letrec  r = f x
 470                 t = f x
 471                 x = ...r...
 472         in
 473         ...t...
 474
 475 (The t in the body doesn't get inlined because by the time the recursive
 476 group is done we see that t's RHS isn't an atom.)
 477
 478 Bad news!  (f x) is duplicated!  Our solution is to only be prepared to
 479 inline RHSs in their own RHSs if they are *values* (lambda or constructor).
 480
 481 This means that silly x=y  bindings in recursive group will never go away. Sigh.  ToDo!
 482 -}
 483
 484 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 485                        (out_id, ((_,occ_info), old_rhs))
 486   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 487   where
 488     new_out_id_env = case (form_summary, guidance) of
 489                         (ValueForm, UnfoldNever) -> out_id_env          -- No new stuff to put in
 490                         (ValueForm, _)           -> out_id_env_with_unfolding
 491                         other                    -> out_id_env          -- Not a value
 492
 493         -- If there is an unfolding, we add rhs-info for out_id,
 494         -- No need to modify occ info because RHS is pre-simplification
 495     out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
 496                                 (out_id, occ_info, rhs_info)
 497
 498         -- Compute unfolding details
 499     rhs_info     = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
 500     form_summary = mkFormSummary old_rhs
 501     guidance     = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
 502
 503
 504 mkSimplUnfoldingGuidance chkr out_id rhs
 505   | not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
 506   = UnfoldAlways
 507
 508   | otherwise
 509   = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
 510   where
 511     bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
 512
 513 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
 514 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 515                       out_id occ_info rhs_info
 516   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 517   where
 518     new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
 519                                 (out_id, occ_info, rhs_info)
 520 \end{code}
 521
 522
 523 \begin{code}
 524 modifyOccInfo out_id_env (uniq, new_occ)
 525   = modifyIdEnv_Directly modify_fn out_id_env uniq
 526   where
 527     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 528
 529 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
 530   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 531   where
 532     new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
 533     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 534 \end{code}
 535
 536
 537
 538 %************************************************************************
 539 %*                                                                      *
 540 \subsubsection{The @ConAppMap@ type}
 541 %*                                                                      *
 542 %************************************************************************
 543
 544 The @ConAppMap@ maps applications of constructors (to value atoms)
 545 back to an association list that says "if the constructor was applied
 546 to one of these lists-of-Types, then this OutId is your man (in a
 547 non-gender-specific sense)".  I.e., this is a reversed mapping for
 548 (part of) the main OutIdEnv
 549
 550 \begin{code}
 551 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 552
 553 data UnfoldConApp
 554   = UCA         OutId                   -- data constructor
 555                 [OutArg]                -- *value* arguments; see use below
 556 \end{code}
 557
 558 \begin{code}
 559 nullConApps = emptyFM
 560
 561 extendConApps con_apps id (Con con args)
 562   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 563   where
 564     val_args = filter isValArg args             -- Literals and Ids
 565     ty_args  = [ty | TyArg ty <- args]          -- Just types
 566
 567 extendConApps con_apps id other_rhs = con_apps
 568 \end{code}
 569
 570 \begin{code}
 571 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
 572   = case lookupFM con_apps (UCA con val_args) of
 573         Nothing     -> Nothing
 574
 575         Just assocs -> case [id | (tys, id) <- assocs,
 576                                   and (zipWith eqTy tys ty_args)]
 577                        of
 578                           []     -> Nothing
 579                           (id:_) -> Just id
 580   where
 581     val_args = filter isValArg args             -- Literals and Ids
 582     ty_args  = [ty | TyArg ty <- args]          -- Just types
 583
 584 \end{code}
 585
 586 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 587 for nullary constructors, but now we only do constructor re-use in
 588 let-bindings the special case isn't necessary any more.
 589
 590 \begin{verbatim}
 591   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 592         -- let
 593         --        a = leInt#! p q
 594         -- in
 595         -- case a of
 596         --    True  -> ...
 597         --    False -> False
 598         --
 599         -- Here the False in the second case will get replace by "a", hardly
 600         -- a good idea
 601     Nothing
 602 \end{verbatim}
 603
 604
 605 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 606 it, so we can use it for a @FiniteMap@ key.
 607
 608 \begin{code}
 609 instance Eq  UnfoldConApp where
 610     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 611     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 612
 613 instance Ord UnfoldConApp where
 614     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 615     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 616     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 617     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 618     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 619
 620 instance Ord3 UnfoldConApp where
 621     cmp = cmp_app
 622
 623 cmp_app (UCA c1 as1) (UCA c2 as2)
 624   = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 625   where
 626     -- ToDo: make an "instance Ord3 CoreArg"???
 627
 628     cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
 629     cmp_arg (LitArg   x) (LitArg   y) = x `cmp` y
 630     cmp_arg (TyArg    x) (TyArg    y) = panic# "SimplEnv.cmp_app:TyArgs"
 631     cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
 632     cmp_arg x y
 633       | tag x _LT_ tag y = LT_
 634       | otherwise        = GT_
 635       where
 636         tag (VarArg   _) = ILIT(1)
 637         tag (LitArg   _) = ILIT(2)
 638         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 639         tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
 640 \end{code}
 641
 642
 643