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 CmdLineOpts      ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
  54                           SimplifierSwitch(..), SwitchResult(..)
  55                         )
  56 import CoreSyn
  57 import CoreUnfold       ( mkFormSummary, exprSmallEnoughToDup,
  58                           Unfolding(..), UfExpr, RdrName,
  59                           SimpleUnfolding(..), FormSummary(..),
  60                           calcUnfoldingGuidance, UnfoldingGuidance(..)
  61                         )
  62 import CoreUtils        ( coreExprCc, unTagBinders )
  63 import CostCentre       ( CostCentre, noCostCentre, noCostCentreAttached )
  64 import FiniteMap        -- lots of things
  65 import Id               ( idType, getIdUnfolding, getIdStrictness, idWantsToBeINLINEd,
  66                           applyTypeEnvToId,
  67                           nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
  68                           addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
  69                           SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
  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   = case atom of
 270      LitArg _      -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 271      VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env
 272                                (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps
 273 --SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps
 274   where
 275     new_in_id_env  = addOneToIdEnv in_id_env in_id atom
 276 {-
 277     new_out_id_env = case atom of
 278                         LitArg _      -> out_id_env
 279                         VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info)
 280 -}
 281
 282 extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv
 283 extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val)
 284
 285
 286 extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv
 287
 288 extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 289                      (in_id,_) out_id
 290   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 291   where
 292     new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id)
 293
 294 extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv
 295 extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 296                       in_binders out_ids
 297   = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps
 298   where
 299     new_in_id_env = growIdEnvList in_id_env bindings
 300     bindings      = zipEqual "extendIdEnvWithClones"
 301                              [id | (id,_) <- in_binders]
 302                              (map VarArg out_ids)
 303 \end{code}
 304
 305 %************************************************************************
 306 %*                                                                      *
 307 \subsubsection{The @OutIdEnv@}
 308 %*                                                                      *
 309 %************************************************************************
 310
 311
 312 The domain of @OutIdInfo@ is some, but not necessarily all, in-scope @OutId@s;
 313 both locally-bound ones, and perhaps some imported ones too.
 314
 315 \begin{code}
 316 type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo)
 317
 318 \end{code}
 319
 320 The "Id" part is just so that we can recover the domain of the mapping, which
 321 IdEnvs don't allow directly.
 322
 323 The @BinderInfo@ tells about the occurrences of the @OutId@.
 324 Anything that isn't in here should be assumed to occur many times.
 325 We keep this info so we can modify it when something changes.
 326
 327 The @RhsInfo@ part tells about the value to which the @OutId@ is bound.
 328
 329 \begin{code}
 330 data RhsInfo = NoRhsInfo
 331              | OtherLit [Literal]               -- It ain't one of these
 332              | OtherCon [Id]                    -- It ain't one of these
 333
 334              | InUnfolding SimplEnv             -- Un-simplified unfolding
 335                            SimpleUnfolding      -- (need to snag envts therefore)
 336
 337              | OutUnfolding CostCentre
 338                             SimpleUnfolding     -- Already-simplified unfolding
 339
 340 lookupOutIdEnv :: SimplEnv -> OutId -> Maybe (OutId,BinderInfo,RhsInfo)
 341 lookupOutIdEnv (SimplEnv _ _ _ _ out_id_env _) id = lookupIdEnv out_id_env id
 342
 343 lookupRhsInfo :: SimplEnv -> OutId -> RhsInfo
 344 lookupRhsInfo env id
 345   = case lookupOutIdEnv env id of
 346         Just (_,_,info) -> info
 347         Nothing         -> NoRhsInfo
 348
 349 modifyOutEnvItem :: (OutId, BinderInfo, RhsInfo)
 350                  -> (OutId, BinderInfo, RhsInfo)
 351                  -> (OutId, BinderInfo, RhsInfo)
 352 modifyOutEnvItem (id, occ, info1) (_, _, info2)
 353   = case (info1, info2) of
 354                 (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
 355                 (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
 356                 (_,            NoRhsInfo)    -> (id,occ, info1)
 357                 other                        -> (id,occ, info2)
 358
 359 --(id, occ, new_info)
 360 {-
 361   where
 362     new_info = case (info1, info2) of
 363                 (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
 364                 (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
 365                 (_,            NoRhsInfo)    -> info1
 366                 other                        -> info2
 367 -}
 368 \end{code}
 369
 370
 371 \begin{code}
 372 isEvaluated :: RhsInfo -> Bool
 373 isEvaluated (OtherLit _) = True
 374 isEvaluated (OtherCon _) = True
 375 isEvaluated (InUnfolding _  (SimpleUnfolding ValueForm _ expr)) = True
 376 isEvaluated (OutUnfolding _ (SimpleUnfolding ValueForm _ expr)) = True
 377 isEvaluated other = False
 378 \end{code}
 379
 380 @extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS
 381 of a new binding.  There is a horrid case we have to take care about,
 382 due to Andr\'e Santos:
 383 @
 384     type Array_type b   = Array Int b;
 385     type Descr_type     = (Int,Int);
 386
 387     tabulate      :: (Int -> x) -> Descr_type -> Array_type x;
 388     tabulate      f (l,u)             = listArray (l,u) [f i | i <- [l..u]];
 389
 390     f_iaamain a_xs=
 391         let {
 392             f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1;
 393             f_aareorder a_index a_ar=
 394                 let {
 395                     f_aareorder' a_i= a_ar ! (a_index ! a_i)
 396                  } in  tabulate f_aareorder' (bounds a_ar);
 397             r_index=tabulate ((+) 1) (1,1);
 398             arr    = listArray (1,1) a_xs;
 399             arg    = f_aareorder r_index arr
 400          } in  elems arg
 401 @
 402 Now, when the RHS of arg gets simplified, we inline f_aareorder to get
 403 @
 404         arg  = let f_aareorder' a_i = arr ! (r_index ! a_i)
 405                in tabulate f_aareorder' (bounds arr)
 406 @
 407 Note that r_index is not inlined, because it was bound to a_index which
 408 occurs inside a lambda.
 409
 410 Alas, if elems is inlined, so that (elems arg) becomes (case arg of ...),
 411 then arg is inlined. IF WE USE THE NEW VERSION OF arg, and re-occurrence
 412 analyse it, we won't spot the inside-lambda property of r_index, so r_index
 413 will get inlined inside the lambda.  AARGH.
 414
 415 Solution: when we occurrence-analyse the new RHS we have to go back
 416 and modify the info recorded in the UnfoldEnv for the free vars
 417 of the RHS.  In the example we'd go back and record that r_index is now used
 418 inside a lambda.
 419
 420 \begin{code}
 421 extendEnvGivenNewRhs :: SimplEnv -> OutId -> OutExpr -> SimplEnv
 422 extendEnvGivenNewRhs env out_id rhs
 423   = extendEnvGivenBinding env noBinderInfo out_id rhs
 424
 425 extendEnvGivenBinding :: SimplEnv -> BinderInfo -> OutId -> OutExpr -> SimplEnv
 426 extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 427                       occ_info out_id rhs
 428   = let
 429      s_env = SimplEnv chkr encl_cc ty_env in_id_env out_id_env new_con_apps
 430      s_env_uf = SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding new_con_apps
 431     in
 432     case guidance of
 433        -- Cheap and nasty hack to force strict insertion.
 434      UnfoldNever ->
 435          if isEmptyFM new_con_apps then s_env else s_env
 436      other       ->
 437          if isEmptyFM new_con_apps then s_env_uf else s_env_uf
 438   where
 439     new_con_apps = extendConApps con_apps out_id rhs
 440 {-
 441     new_out_id_env = case guidance of
 442                         UnfoldNever -> out_id_env               -- No new stuff to put in
 443                         other       -> out_id_env_with_unfolding
 444 -}
 445         -- If there is an unfolding, we add rhs-info for out_id,
 446         -- *and* modify the occ info for rhs's interesting free variables.
 447         --
 448         -- If the out_id is already in the OutIdEnv, then just replace the
 449         -- unfolding, leaving occurrence info alone (this must then
 450         -- be a call via extendEnvGivenNewRhs).
 451     out_id_env_with_unfolding = foldl modifyOccInfo env1 full_fv_occ_info
 452                 -- full_fv_occ_info combines the occurrence of the current binder
 453                 -- with the occurrences of its RHS's free variables.
 454     full_fv_occ_info          = [ (uniq, fv_occ `andBinderInfo` occ_info)
 455                                 | (uniq,fv_occ) <- ufmToList fv_occ_info
 456                                 ]
 457     env1                      = addToUFM_C modifyOutEnvItem out_id_env out_id
 458                                            (out_id, occ_info, rhs_info)
 459
 460         -- Occurrence-analyse the RHS
 461         -- The "interesting" free variables we want occurrence info for are those
 462         -- in the OutIdEnv that have only a single occurrence right now.
 463     (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs
 464     interesting_fvs         = mkIdSet [id | (id,OneOcc _ _ _ _ _,_) <- eltsUFM out_id_env]
 465
 466         -- Compute unfolding details
 467     rhs_info     = OutUnfolding unf_cc (SimpleUnfolding form_summary guidance template)
 468     form_summary = mkFormSummary rhs
 469
 470     guidance = mkSimplUnfoldingGuidance chkr out_id rhs
 471
 472         -- Compute cost centre for thing
 473     unf_cc  | noCostCentreAttached expr_cc = encl_cc
 474             | otherwise                    = expr_cc
 475             where
 476               expr_cc =  coreExprCc rhs
 477 \end{code}
 478
 479
 480
 481 Recursive bindings
 482 ~~~~~~~~~~~~~~~~~~
 483 We need to be pretty careful when extending
 484 the environment with RHS info in recursive groups.
 485
 486 Here's a nasty example:
 487
 488         letrec  r = f x
 489                 t = r
 490                 x = ...t...
 491         in
 492         ...t...
 493
 494 Here, r occurs exactly once, so we may reasonably inline r in t's RHS.
 495 But the pre-simplified t's rhs is an atom, r, so we may also decide to
 496 inline t everywhere.  But if we do *both* these reasonable things we get
 497
 498         letrec  r = f x
 499                 t = f x
 500                 x = ...r...
 501         in
 502         ...t...
 503
 504 Bad news!  (f x) is duplicated!  (The t in the body doesn't get
 505 inlined because by the time the recursive group is done we see that
 506 t's RHS isn't an atom.)
 507
 508 Our solution is this:
 509         (a) we inline un-simplified RHSs, and then simplify
 510             them in a clone-only environment.
 511         (b) we inline only variables and values
 512 This means that
 513
 514
 515         r = f x         ==>  r = f x
 516         t = r           ==>  t = r
 517         x = ...t...     ==>  x = ...r...
 518      in                    in
 519         t                    r
 520
 521 Now t is dead, and we're home.
 522
 523 Most silly x=y  bindings in recursive group will go away.  But not all:
 524
 525         let y = 1:x
 526             x = y
 527
 528 Here, we can't inline x because it's in an argument position. so we'll just replace
 529 with a clone of y.  Instead we'll probably inline y (a small value) to give
 530
 531         let y = 1:x
 532             x = 1:y
 533
 534 which is OK if not clever.
 535
 536 \begin{code}
 537 extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 538                        (out_id, ((_,occ_info), old_rhs))
 539   = case (form_summary, guidance) of
 540      (_, UnfoldNever)   -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps -- No new stuff to put in
 541      (ValueForm, _)     -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
 542      (VarForm, _)       -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env_with_unfolding con_apps
 543      other              -> SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps   -- Not a value or variable
 544
 545 -- SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 546   where
 547 {-
 548     new_out_id_env = case (form_summary, guidance) of
 549                         (_, UnfoldNever)        -> out_id_env           -- No new stuff to put in
 550                         (ValueForm, _)          -> out_id_env_with_unfolding
 551                         (VarForm, _)            -> out_id_env_with_unfolding
 552                         other                   -> out_id_env           -- Not a value or variable
 553 -}
 554         -- If there is an unfolding, we add rhs-info for out_id,
 555         -- No need to modify occ info because RHS is pre-simplification
 556     out_id_env_with_unfolding = addOneToIdEnv out_id_env out_id
 557                                 (out_id, occ_info, rhs_info)
 558
 559         -- Compute unfolding details
 560         -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
 561         -- in the InUnfolding.  So if we ever use the InUnfolding we'll just inline once.
 562         -- Only if the thing is still small enough next time round will we inline again.
 563     rhs_info     = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
 564     form_summary = mkFormSummary old_rhs
 565     guidance     = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
 566
 567
 568 mkSimplUnfoldingGuidance chkr out_id rhs
 569   = case calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs of
 570      UnfoldNever -> UnfoldNever
 571      v           -> v
 572   where
 573     inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
 574
 575 extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
 576 extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
 577                       out_id occ_info rhs_info
 578   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 579   where
 580     new_out_id_env = addToUFM_C modifyOutEnvItem out_id_env out_id
 581                                 (out_id, occ_info, rhs_info)
 582 \end{code}
 583
 584
 585 \begin{code}
 586 modifyOccInfo out_id_env (uniq, new_occ)
 587   = modifyIdEnv_Directly modify_fn out_id_env uniq
 588   where
 589     modify_fn (id,occ,rhs) = (id, orBinderInfo occ new_occ, rhs)
 590
 591 markDangerousOccs (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) atoms
 592   = SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
 593   where
 594     new_out_id_env = foldl (modifyIdEnv modify_fn) out_id_env [v | VarArg v <- atoms]
 595     modify_fn (id,occ,rhs) = (id, noBinderInfo, rhs)
 596 \end{code}
 597
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsubsection{The @ConAppMap@ type}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 The @ConAppMap@ maps applications of constructors (to value atoms)
 607 back to an association list that says "if the constructor was applied
 608 to one of these lists-of-Types, then this OutId is your man (in a
 609 non-gender-specific sense)".  I.e., this is a reversed mapping for
 610 (part of) the main OutIdEnv
 611
 612 \begin{code}
 613 type ConAppMap = FiniteMap UnfoldConApp [([Type], OutId)]
 614
 615 data UnfoldConApp
 616   = UCA         OutId                   -- data constructor
 617                 [OutArg]                -- *value* arguments; see use below
 618 \end{code}
 619
 620 \begin{code}
 621 nullConApps = emptyFM
 622
 623 extendConApps con_apps id (Con con args)
 624   = addToFM_C (\old new -> new++old) con_apps (UCA con val_args) [(ty_args,id)]
 625   where
 626     val_args = filter isValArg args             -- Literals and Ids
 627     ty_args  = [ty | TyArg ty <- args]          -- Just types
 628
 629 extendConApps con_apps id other_rhs = con_apps
 630 \end{code}
 631
 632 \begin{code}
 633 lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
 634   = case lookupFM con_apps (UCA con val_args) of
 635         Nothing     -> Nothing
 636
 637         Just assocs -> case [id | (tys, id) <- assocs,
 638                                   and (zipWith eqTy tys ty_args)]
 639                        of
 640                           []     -> Nothing
 641                           (id:_) -> Just id
 642   where
 643     val_args = filter isValArg args             -- Literals and Ids
 644     ty_args  = [ty | TyArg ty <- args]          -- Just types
 645
 646 \end{code}
 647
 648 NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
 649 for nullary constructors, but now we only do constructor re-use in
 650 let-bindings the special case isn't necessary any more.
 651
 652 \begin{verbatim}
 653   =     -- Don't re-use nullary constructors; it's a waste.  Consider
 654         -- let
 655         --        a = leInt#! p q
 656         -- in
 657         -- case a of
 658         --    True  -> ...
 659         --    False -> False
 660         --
 661         -- Here the False in the second case will get replace by "a", hardly
 662         -- a good idea
 663     Nothing
 664 \end{verbatim}
 665
 666
 667 The main thing about @UnfoldConApp@ is that it has @Ord@ defined on
 668 it, so we can use it for a @FiniteMap@ key.
 669
 670 \begin{code}
 671 instance Eq  UnfoldConApp where
 672     a == b = case (a `cmp` b) of { EQ_ -> True;   _ -> False }
 673     a /= b = case (a `cmp` b) of { EQ_ -> False;  _ -> True  }
 674
 675 instance Ord UnfoldConApp where
 676     a <= b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> True;  GT__ -> False }
 677     a <  b = case (a `cmp` b) of { LT_ -> True;  EQ_ -> False; GT__ -> False }
 678     a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True;  GT__ -> True  }
 679     a >  b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True  }
 680     _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
 681
 682 instance Ord3 UnfoldConApp where
 683     cmp = cmp_app
 684
 685 cmp_app (UCA c1 as1) (UCA c2 as2)
 686   = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2
 687   where
 688     -- ToDo: make an "instance Ord3 CoreArg"???
 689
 690     cmp_arg (VarArg   x) (VarArg   y) = x `cmp` y
 691     cmp_arg (LitArg   x) (LitArg   y) = x `cmp` y
 692     cmp_arg (TyArg    x) (TyArg    y) = panic# "SimplEnv.cmp_app:TyArgs"
 693     cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
 694     cmp_arg x y
 695       | tag x _LT_ tag y = LT_
 696       | otherwise        = GT_
 697       where
 698         tag (VarArg   _) = ILIT(1)
 699         tag (LitArg   _) = ILIT(2)
 700         tag (TyArg    _) = panic# "SimplEnv.cmp_app:TyArg"
 701         tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg"
 702 \end{code}
 703
 704
 705