compiler/coreSyn/CorePrep.lhs

   1 %
   2 % (c) The University of Glasgow, 1994-2006
   3 %
   4
   5 Core pass to saturate constructors and PrimOps
   6
   7 \begin{code}
   8 module CorePrep (
   9       corePrepPgm, corePrepExpr
  10   ) where
  11
  12 #include "HsVersions.h"
  13
  14 import PrelNames        ( lazyIdKey, hasKey )
  15 import CoreUtils
  16 import CoreArity
  17 import CoreFVs
  18 import CoreMonad        ( endPass, CoreToDo(..) )
  19 import CoreSyn
  20 import CoreSubst
  21 import OccurAnal        ( occurAnalyseExpr )
  22 import Type
  23 import Coercion
  24 import TyCon
  25 import Demand
  26 import Var
  27 import VarSet
  28 import VarEnv
  29 import Id
  30 import IdInfo
  31 import DataCon
  32 import PrimOp
  33 import BasicTypes
  34 import UniqSupply
  35 import Maybes
  36 import OrdList
  37 import ErrUtils
  38 import DynFlags
  39 import Util
  40 import Pair
  41 import Outputable
  42 import MonadUtils
  43 import FastString
  44 import Data.List        ( mapAccumL )
  45 import Control.Monad
  46 \end{code}
  47
  48 -- ---------------------------------------------------------------------------
  49 -- Overview
  50 -- ---------------------------------------------------------------------------
  51
  52 The goal of this pass is to prepare for code generation.
  53
  54 1.  Saturate constructor and primop applications.
  55
  56 2.  Convert to A-normal form; that is, function arguments
  57     are always variables.
  58
  59     * Use case for strict arguments:
  60         f E ==> case E of x -> f x
  61         (where f is strict)
  62
  63     * Use let for non-trivial lazy arguments
  64         f E ==> let x = E in f x
  65         (were f is lazy and x is non-trivial)
  66
  67 3.  Similarly, convert any unboxed lets into cases.
  68     [I'm experimenting with leaving 'ok-for-speculation'
  69      rhss in let-form right up to this point.]
  70
  71 4.  Ensure that *value* lambdas only occur as the RHS of a binding
  72     (The code generator can't deal with anything else.)
  73     Type lambdas are ok, however, because the code gen discards them.
  74
  75 5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
  76
  77 6.  Clone all local Ids.
  78     This means that all such Ids are unique, rather than the
  79     weaker guarantee of no clashes which the simplifier provides.
  80     And that is what the code generator needs.
  81
  82     We don't clone TyVars or CoVars. The code gen doesn't need that,
  83     and doing so would be tiresome because then we'd need
  84     to substitute in types and coercions.
  85
  86
  87 7.  Give each dynamic CCall occurrence a fresh unique; this is
  88     rather like the cloning step above.
  89
  90 8.  Inject bindings for the "implicit" Ids:
  91         * Constructor wrappers
  92         * Constructor workers
  93     We want curried definitions for all of these in case they
  94     aren't inlined by some caller.
  95
  96 9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.lhs
  97
  98 This is all done modulo type applications and abstractions, so that
  99 when type erasure is done for conversion to STG, we don't end up with
 100 any trivial or useless bindings.
 101
 102
 103 Invariants
 104 ~~~~~~~~~~
 105 Here is the syntax of the Core produced by CorePrep:
 106
 107     Trivial expressions
 108        triv ::= lit |  var
 109               | triv ty  |  /\a. triv
 110               | truv co  |  /\c. triv  |  triv |> co
 111
 112     Applications
 113        app ::= lit  |  var  |  app triv  |  app ty  | app co | app |> co
 114
 115     Expressions
 116        body ::= app
 117               | let(rec) x = rhs in body     -- Boxed only
 118               | case body of pat -> body
 119               | /\a. body | /\c. body
 120               | body |> co
 121
 122     Right hand sides (only place where value lambdas can occur)
 123        rhs ::= /\a.rhs  |  \x.rhs  |  body
 124
 125 We define a synonym for each of these non-terminals.  Functions
 126 with the corresponding name produce a result in that syntax.
 127
 128 \begin{code}
 129 type CpeTriv = CoreExpr    -- Non-terminal 'triv'
 130 type CpeApp  = CoreExpr    -- Non-terminal 'app'
 131 type CpeBody = CoreExpr    -- Non-terminal 'body'
 132 type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 133 \end{code}
 134
 135 %************************************************************************
 136 %*                                                                      *
 137                 Top level stuff
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
 143 corePrepPgm dflags binds data_tycons = do
 144     showPass dflags "CorePrep"
 145     us <- mkSplitUniqSupply 's'
 146
 147     let implicit_binds = mkDataConWorkers data_tycons
 148             -- NB: we must feed mkImplicitBinds through corePrep too
 149             -- so that they are suitably cloned and eta-expanded
 150
 151         binds_out = initUs_ us $ do
 152                       floats1 <- corePrepTopBinds binds
 153                       floats2 <- corePrepTopBinds implicit_binds
 154                       return (deFloatTop (floats1 `appendFloats` floats2))
 155
 156     endPass dflags CorePrep binds_out []
 157     return binds_out
 158
 159 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 160 corePrepExpr dflags expr = do
 161     showPass dflags "CorePrep"
 162     us <- mkSplitUniqSupply 's'
 163     let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr)
 164     dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
 165     return new_expr
 166
 167 corePrepTopBinds :: [CoreBind] -> UniqSM Floats
 168 -- Note [Floating out of top level bindings]
 169 corePrepTopBinds binds
 170   = go emptyCorePrepEnv binds
 171   where
 172     go _   []             = return emptyFloats
 173     go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind
 174                                binds' <- go env' binds
 175                                return (bind' `appendFloats` binds')
 176
 177 mkDataConWorkers :: [TyCon] -> [CoreBind]
 178 -- See Note [Data constructor workers]
 179 mkDataConWorkers data_tycons
 180   = [ NonRec id (Var id)        -- The ice is thin here, but it works
 181     | tycon <- data_tycons,     -- CorePrep will eta-expand it
 182       data_con <- tyConDataCons tycon,
 183       let id = dataConWorkId data_con ]
 184 \end{code}
 185
 186 Note [Floating out of top level bindings]
 187 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 188 NB: we do need to float out of top-level bindings
 189 Consider        x = length [True,False]
 190 We want to get
 191                 s1 = False : []
 192                 s2 = True  : s1
 193                 x  = length s2
 194
 195 We return a *list* of bindings, because we may start with
 196         x* = f (g y)
 197 where x is demanded, in which case we want to finish with
 198         a = g y
 199         x* = f a
 200 And then x will actually end up case-bound
 201
 202 Note [CafInfo and floating]
 203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 204 What happens when we try to float bindings to the top level?  At this
 205 point all the CafInfo is supposed to be correct, and we must make certain
 206 that is true of the new top-level bindings.  There are two cases
 207 to consider
 208
 209 a) The top-level binding is marked asCafRefs.  In that case we are
 210    basically fine.  The floated bindings had better all be lazy lets,
 211    so they can float to top level, but they'll all have HasCafRefs
 212    (the default) which is safe.
 213
 214 b) The top-level binding is marked NoCafRefs.  This really happens
 215    Example.  CoreTidy produces
 216       $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
 217    Now CorePrep has to eta-expand to
 218       $fApplicativeSTM = let sat = \xy. retry x y
 219                          in D:Alternative sat ...blah...
 220    So what we *want* is
 221       sat [NoCafRefs] = \xy. retry x y
 222       $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
 223
 224    So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
 225    *and* substutite the modified 'sat' into the old RHS.
 226
 227    It should be the case that 'sat' is itself [NoCafRefs] (a value, no
 228    cafs) else the original top-level binding would not itself have been
 229    marked [NoCafRefs].  The DEBUG check in CoreToStg for
 230    consistentCafInfo will find this.
 231
 232 This is all very gruesome and horrible. It would be better to figure
 233 out CafInfo later, after CorePrep.  We'll do that in due course.
 234 Meanwhile this horrible hack works.
 235
 236
 237 Note [Data constructor workers]
 238 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 239 Create any necessary "implicit" bindings for data con workers.  We
 240 create the rather strange (non-recursive!) binding
 241
 242         $wC = \x y -> $wC x y
 243
 244 i.e. a curried constructor that allocates.  This means that we can
 245 treat the worker for a constructor like any other function in the rest
 246 of the compiler.  The point here is that CoreToStg will generate a
 247 StgConApp for the RHS, rather than a call to the worker (which would
 248 give a loop).  As Lennart says: the ice is thin here, but it works.
 249
 250 Hmm.  Should we create bindings for dictionary constructors?  They are
 251 always fully applied, and the bindings are just there to support
 252 partial applications. But it's easier to let them through.
 253
 254
 255 Note [Dead code in CorePrep]
 256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 257 Imagine that we got an input program like this:
 258
 259   f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
 260   f x = (g True (Just x) + g () (Just x), g)
 261     where
 262       g :: Show a => a -> Maybe Int -> Int
 263       g _ Nothing = x
 264       g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
 265
 266 After specialisation and SpecConstr, we would get something like this:
 267
 268   f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
 269   f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
 270     where
 271       {-# RULES g $dBool = g$Bool
 272                 g $dUnit = g$Unit #-}
 273       g = ...
 274       {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
 275       g$Bool = ...
 276       {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
 277       g$Unit = ...
 278       g$Bool_True_Just = ...
 279       g$Unit_Unit_Just = ...
 280
 281 Note that the g$Bool and g$Unit functions are actually dead code: they are only kept
 282 alive by the occurrence analyser because they are referred to by the rules of g,
 283 which is being kept alive by the fact that it is used (unspecialised) in the returned pair.
 284
 285 However, at the CorePrep stage there is no way that the rules for g will ever fire,
 286 and it really seems like a shame to produce an output program that goes to the trouble
 287 of allocating a closure for the unreachable g$Bool and g$Unit functions.
 288
 289 The way we fix this is to:
 290  * In cloneBndr, drop all unfoldings/rules
 291  * In deFloatTop, run the occurrence analyser on each top-level RHS to drop
 292    the dead local bindings
 293
 294 The reason we don't just OccAnal the whole output of CorePrep is that the tidier
 295 ensures that all top-level binders are GlobalIds, so they don't show up in the free
 296 variables any longer. So if you run the occurrence analyser on the output of CoreTidy
 297 (or later) you e.g. turn this program:
 298
 299   Rec {
 300   f = ... f ...
 301   }
 302
 303 Into this one:
 304
 305   f = ... f ...
 306
 307 (Since f is not considered to be free in its own RHS.)
 308
 309
 310 %************************************************************************
 311 %*                                                                      *
 312                 The main code
 313 %*                                                                      *
 314 %************************************************************************
 315
 316 \begin{code}
 317 cpeBind :: TopLevelFlag
 318         -> CorePrepEnv -> CoreBind
 319         -> UniqSM (CorePrepEnv, Floats)
 320 cpeBind top_lvl env (NonRec bndr rhs)
 321   = do { (_, bndr1) <- cloneBndr env bndr
 322        ; let is_strict   = isStrictDmd (idDemandInfo bndr)
 323              is_unlifted = isUnLiftedType (idType bndr)
 324        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive
 325                                           (is_strict || is_unlifted)
 326                                           env bndr1 rhs
 327        ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2
 328
 329         -- We want bndr'' in the envt, because it records
 330         -- the evaluated-ness of the binder
 331        ; return (extendCorePrepEnv env bndr bndr2,
 332                  addFloat floats new_float) }
 333
 334 cpeBind top_lvl env (Rec pairs)
 335   = do { let (bndrs,rhss) = unzip pairs
 336        ; (env', bndrs1) <- cloneBndrs env (map fst pairs)
 337        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 338
 339        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
 340              all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)
 341                                            (concatFloats floats_s)
 342        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
 343                  unitFloat (FloatLet (Rec all_pairs))) }
 344   where
 345         -- Flatten all the floats, and the currrent
 346         -- group into a single giant Rec
 347     add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
 348     add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
 349     add_float b                       _    = pprPanic "cpeBind" (ppr b)
 350
 351 ---------------
 352 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
 353         -> CorePrepEnv -> Id -> CoreExpr
 354         -> UniqSM (Floats, Id, CpeRhs)
 355 -- Used for all bindings
 356 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
 357   = do { (floats1, rhs1) <- cpeRhsE env rhs
 358
 359        -- See if we are allowed to float this stuff out of the RHS
 360        ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
 361
 362        -- Make the arity match up
 363        ; (floats3, rhs')
 364             <- if manifestArity rhs1 <= arity
 365                then return (floats2, cpeEtaExpand arity rhs2)
 366                else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
 367                                -- Note [Silly extra arguments]
 368                     (do { v <- newVar (idType bndr)
 369                         ; let float = mkFloat False False v rhs2
 370                         ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
 371
 372         -- Record if the binder is evaluated
 373         -- and otherwise trim off the unfolding altogether
 374         -- It's not used by the code generator; getting rid of it reduces
 375         -- heap usage and, since we may be changing uniques, we'd have
 376         -- to substitute to keep it right
 377        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
 378                    | otherwise      = bndr `setIdUnfolding` noUnfolding
 379
 380        ; return (floats3, bndr', rhs') }
 381   where
 382     arity = idArity bndr        -- We must match this arity
 383
 384     ---------------------
 385     float_from_rhs floats rhs
 386       | isEmptyFloats floats = return (emptyFloats, rhs)
 387       | isTopLevel top_lvl    = float_top    floats rhs
 388       | otherwise             = float_nested floats rhs
 389
 390     ---------------------
 391     float_nested floats rhs
 392       | wantFloatNested is_rec is_strict_or_unlifted floats rhs
 393                   = return (floats, rhs)
 394       | otherwise = dont_float floats rhs
 395
 396     ---------------------
 397     float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]
 398       | mayHaveCafRefs (idCafInfo bndr)
 399       , allLazyTop floats
 400       = return (floats, rhs)
 401
 402       -- So the top-level binding is marked NoCafRefs
 403       | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
 404       = return (floats', rhs')
 405
 406       | otherwise
 407       = dont_float floats rhs
 408
 409     ---------------------
 410     dont_float floats rhs
 411       -- Non-empty floats, but do not want to float from rhs
 412       -- So wrap the rhs in the floats
 413       -- But: rhs1 might have lambdas, and we can't
 414       --      put them inside a wrapBinds
 415       = do { body <- rhsToBodyNF rhs
 416            ; return (emptyFloats, wrapBinds floats body) }
 417
 418 {- Note [Silly extra arguments]
 419 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 420 Suppose we had this
 421         f{arity=1} = \x\y. e
 422 We *must* match the arity on the Id, so we have to generate
 423         f' = \x\y. e
 424         f  = \x. f' x
 425
 426 It's a bizarre case: why is the arity on the Id wrong?  Reason
 427 (in the days of __inline_me__):
 428         f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
 429 When InlineMe notes go away this won't happen any more.  But
 430 it seems good for CorePrep to be robust.
 431 -}
 432
 433 -- ---------------------------------------------------------------------------
 434 --              CpeRhs: produces a result satisfying CpeRhs
 435 -- ---------------------------------------------------------------------------
 436
 437 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 438 -- If
 439 --      e  ===>  (bs, e')
 440 -- then
 441 --      e = let bs in e'        (semantically, that is!)
 442 --
 443 -- For example
 444 --      f (g x)   ===>   ([v = g x], f v)
 445
 446 cpeRhsE _env expr@(Type {})     = return (emptyFloats, expr)
 447 cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
 448 cpeRhsE _env expr@(Lit {})      = return (emptyFloats, expr)
 449 cpeRhsE env expr@(Var {})       = cpeApp env expr
 450
 451 cpeRhsE env (Var f `App` _ `App` arg)
 452   | f `hasKey` lazyIdKey          -- Replace (lazy a) by a
 453   = cpeRhsE env arg               -- See Note [lazyId magic] in MkId
 454
 455 cpeRhsE env expr@(App {}) = cpeApp env expr
 456
 457 cpeRhsE env (Let bind expr)
 458   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
 459        ; (floats, body) <- cpeRhsE env' expr
 460        ; return (new_binds `appendFloats` floats, body) }
 461
 462 cpeRhsE env (Note note expr)
 463   | ignoreNote note
 464   = cpeRhsE env expr
 465   | otherwise         -- Just SCCs actually
 466   = do { body <- cpeBodyNF env expr
 467        ; return (emptyFloats, Note note body) }
 468
 469 cpeRhsE env (Cast expr co)
 470    = do { (floats, expr') <- cpeRhsE env expr
 471         ; return (floats, Cast expr' co) }
 472
 473 cpeRhsE env expr@(Lam {})
 474    = do { let (bndrs,body) = collectBinders expr
 475         ; (env', bndrs') <- cloneBndrs env bndrs
 476         ; body' <- cpeBodyNF env' body
 477         ; return (emptyFloats, mkLams bndrs' body') }
 478
 479 cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)])
 480   | Just (TickBox {}) <- isTickBoxOp_maybe id
 481   = do { body <- cpeBodyNF env expr
 482        ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) }
 483
 484 cpeRhsE env (Case scrut bndr ty alts)
 485   = do { (floats, scrut') <- cpeBody env scrut
 486        ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding
 487             -- Record that the case binder is evaluated in the alternatives
 488        ; (env', bndr2) <- cloneBndr env bndr1
 489        ; alts' <- mapM (sat_alt env') alts
 490        ; return (floats, Case scrut' bndr2 ty alts') }
 491   where
 492     sat_alt env (con, bs, rhs)
 493        = do { (env2, bs') <- cloneBndrs env bs
 494             ; rhs' <- cpeBodyNF env2 rhs
 495             ; return (con, bs', rhs') }
 496
 497 -- ---------------------------------------------------------------------------
 498 --              CpeBody: produces a result satisfying CpeBody
 499 -- ---------------------------------------------------------------------------
 500
 501 cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
 502 cpeBodyNF env expr
 503   = do { (floats, body) <- cpeBody env expr
 504        ; return (wrapBinds floats body) }
 505
 506 --------
 507 cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
 508 cpeBody env expr
 509   = do { (floats1, rhs) <- cpeRhsE env expr
 510        ; (floats2, body) <- rhsToBody rhs
 511        ; return (floats1 `appendFloats` floats2, body) }
 512
 513 --------
 514 rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
 515 rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
 516                      ; return (wrapBinds floats body) }
 517
 518 --------
 519 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 520 -- Remove top level lambdas by let-binding
 521
 522 rhsToBody (Note n expr)
 523         -- You can get things like
 524         --      case e of { p -> coerce t (\s -> ...) }
 525   = do { (floats, expr') <- rhsToBody expr
 526        ; return (floats, Note n expr') }
 527
 528 rhsToBody (Cast e co)
 529   = do { (floats, e') <- rhsToBody e
 530        ; return (floats, Cast e' co) }
 531
 532 rhsToBody expr@(Lam {})
 533   | Just no_lam_result <- tryEtaReducePrep bndrs body
 534   = return (emptyFloats, no_lam_result)
 535   | all isTyVar bndrs           -- Type lambdas are ok
 536   = return (emptyFloats, expr)
 537   | otherwise                   -- Some value lambdas
 538   = do { fn <- newVar (exprType expr)
 539        ; let rhs   = cpeEtaExpand (exprArity expr) expr
 540              float = FloatLet (NonRec fn rhs)
 541        ; return (unitFloat float, Var fn) }
 542   where
 543     (bndrs,body) = collectBinders expr
 544
 545 rhsToBody expr = return (emptyFloats, expr)
 546
 547
 548
 549 -- ---------------------------------------------------------------------------
 550 --              CpeApp: produces a result satisfying CpeApp
 551 -- ---------------------------------------------------------------------------
 552
 553 cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 554 -- May return a CpeRhs because of saturating primops
 555 cpeApp env expr
 556   = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0
 557        ; MASSERT(null ss)       -- make sure we used all the strictness info
 558
 559         -- Now deal with the function
 560        ; case head of
 561            Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth
 562                            ; return (floats, sat_app) }
 563            _other    -> return (floats, app) }
 564
 565   where
 566     -- Deconstruct and rebuild the application, floating any non-atomic
 567     -- arguments to the outside.  We collect the type of the expression,
 568     -- the head of the application, and the number of actual value arguments,
 569     -- all of which are used to possibly saturate this application if it
 570     -- has a constructor or primop at the head.
 571
 572     collect_args
 573         :: CoreExpr
 574         -> Int                     -- Current app depth
 575         -> UniqSM (CpeApp,         -- The rebuilt expression
 576                    (CoreExpr,Int), -- The head of the application,
 577                                    -- and no. of args it was applied to
 578                    Type,           -- Type of the whole expr
 579                    Floats,         -- Any floats we pulled out
 580                    [Demand])       -- Remaining argument demands
 581
 582     collect_args (App fun arg@(Type arg_ty)) depth
 583       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
 584            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 585
 586     collect_args (App fun arg@(Coercion arg_co)) depth
 587       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
 588            ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
 589
 590     collect_args (App fun arg) depth
 591       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
 592            ; let
 593               (ss1, ss_rest)   = case ss of
 594                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 595                                    []            -> (lazyDmd, [])
 596               (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
 597                                  splitFunTy_maybe fun_ty
 598
 599            ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty
 600            ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) }
 601
 602     collect_args (Var v) depth
 603       = do { v1 <- fiddleCCall v
 604            ; let v2 = lookupCorePrepEnv env v1
 605            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
 606         where
 607           stricts = case idStrictness v of
 608                         StrictSig (DmdType _ demands _)
 609                             | listLengthCmp demands depth /= GT -> demands
 610                                     -- length demands <= depth
 611                             | otherwise                         -> []
 612                 -- If depth < length demands, then we have too few args to
 613                 -- satisfy strictness  info so we have to  ignore all the
 614                 -- strictness info, e.g. + (error "urk")
 615                 -- Here, we can't evaluate the arg strictly, because this
 616                 -- partial application might be seq'd
 617
 618     collect_args (Cast fun co) depth
 619       = do { let Pair _ty1 ty2 = coercionKind co
 620            ; (fun', hd, _, floats, ss) <- collect_args fun depth
 621            ; return (Cast fun' co, hd, ty2, floats, ss) }
 622
 623     collect_args (Note note fun) depth
 624       | ignoreNote note         -- Drop these notes altogether
 625       = collect_args fun depth  -- They aren't used by the code generator
 626
 627         -- N-variable fun, better let-bind it
 628     collect_args fun depth
 629       = do { (fun_floats, fun') <- cpeArg env True fun ty
 630                           -- The True says that it's sure to be evaluated,
 631                           -- so we'll end up case-binding it
 632            ; return (fun', (fun', depth), ty, fun_floats, []) }
 633         where
 634           ty = exprType fun
 635
 636 -- ---------------------------------------------------------------------------
 637 --      CpeArg: produces a result satisfying CpeArg
 638 -- ---------------------------------------------------------------------------
 639
 640 -- This is where we arrange that a non-trivial argument is let-bound
 641 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
 642        -> UniqSM (Floats, CpeTriv)
 643 cpeArg env is_strict arg arg_ty
 644   = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
 645        ; (floats2, arg2) <- if want_float floats1 arg1
 646                             then return (floats1, arg1)
 647                             else do { body1 <- rhsToBodyNF arg1
 648                                     ; return (emptyFloats, wrapBinds floats1 body1) }
 649                 -- Else case: arg1 might have lambdas, and we can't
 650                 --            put them inside a wrapBinds
 651
 652        ; if cpe_ExprIsTrivial arg2    -- Do not eta expand a trivial argument
 653          then return (floats2, arg2)
 654          else do
 655        { v <- newVar arg_ty
 656        ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
 657              arg_float = mkFloat is_strict is_unlifted v arg3
 658        ; return (addFloat floats2 arg_float, Var v) } }
 659   where
 660     is_unlifted = isUnLiftedType arg_ty
 661     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
 662 \end{code}
 663
 664 Note [Floating unlifted arguments]
 665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 666 Consider    C (let v* = expensive in v)
 667
 668 where the "*" indicates "will be demanded".  Usually v will have been
 669 inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we
 670 do *not* want to get
 671
 672      let v* = expensive in C v
 673
 674 because that has different strictness.  Hence the use of 'allLazy'.
 675 (NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
 676
 677
 678 ------------------------------------------------------------------------------
 679 -- Building the saturated syntax
 680 -- ---------------------------------------------------------------------------
 681
 682 maybeSaturate deals with saturating primops and constructors
 683 The type is the type of the entire application
 684
 685 \begin{code}
 686 maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
 687 maybeSaturate fn expr n_args
 688   | Just DataToTagOp <- isPrimOpId_maybe fn     -- DataToTag must have an evaluated arg
 689                                                 -- A gruesome special case
 690   = saturateDataToTag sat_expr
 691
 692   | hasNoBinding fn        -- There's no binding
 693   = return sat_expr
 694
 695   | otherwise
 696   = return expr
 697   where
 698     fn_arity     = idArity fn
 699     excess_arity = fn_arity - n_args
 700     sat_expr     = cpeEtaExpand excess_arity expr
 701
 702 -------------
 703 saturateDataToTag :: CpeApp -> UniqSM CpeApp
 704 -- See Note [dataToTag magic]
 705 saturateDataToTag sat_expr
 706   = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
 707        ; eta_body' <- eval_data2tag_arg eta_body
 708        ; return (mkLams eta_bndrs eta_body') }
 709   where
 710     eval_data2tag_arg :: CpeApp -> UniqSM CpeBody
 711     eval_data2tag_arg app@(fun `App` arg)
 712         | exprIsHNF arg         -- Includes nullary constructors
 713         = return app            -- The arg is evaluated
 714         | otherwise                     -- Arg not evaluated, so evaluate it
 715         = do { arg_id <- newVar (exprType arg)
 716              ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding
 717              ; return (Case arg arg_id1 (exprType app)
 718                             [(DEFAULT, [], fun `App` Var arg_id1)]) }
 719
 720     eval_data2tag_arg (Note note app)   -- Scc notes can appear
 721         = do { app' <- eval_data2tag_arg app
 722              ; return (Note note app') }
 723
 724     eval_data2tag_arg other     -- Should not happen
 725         = pprPanic "eval_data2tag" (ppr other)
 726 \end{code}
 727
 728 Note [dataToTag magic]
 729 ~~~~~~~~~~~~~~~~~~~~~~
 730 Horrid: we must ensure that the arg of data2TagOp is evaluated
 731   (data2tag x) -->  (case x of y -> data2tag y)
 732 (yuk yuk) take into account the lambdas we've now introduced
 733
 734 How might it not be evaluated?  Well, we might have floated it out
 735 of the scope of a `seq`, or dropped the `seq` altogether.
 736
 737
 738 %************************************************************************
 739 %*                                                                      *
 740                 Simple CoreSyn operations
 741 %*                                                                      *
 742 %************************************************************************
 743
 744 \begin{code}
 745         -- We don't ignore SCCs, since they require some code generation
 746 ignoreNote :: Note -> Bool
 747 -- Tells which notes to drop altogether; they are ignored by code generation
 748 -- Do not ignore SCCs!
 749 -- It's important that we do drop InlineMe notes; for example
 750 --    unzip = __inline_me__ (/\ab. foldr (..) (..))
 751 -- Here unzip gets arity 1 so we'll eta-expand it. But we don't
 752 -- want to get this:
 753 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 754 ignoreNote (CoreNote _) = True
 755 ignoreNote _other       = False
 756
 757
 758 cpe_ExprIsTrivial :: CoreExpr -> Bool
 759 -- Version that doesn't consider an scc annotation to be trivial.
 760 cpe_ExprIsTrivial (Var _)                  = True
 761 cpe_ExprIsTrivial (Type _)                 = True
 762 cpe_ExprIsTrivial (Coercion _)             = True
 763 cpe_ExprIsTrivial (Lit _)                  = True
 764 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 765 cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e
 766 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 767 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 768 cpe_ExprIsTrivial _                        = False
 769 \end{code}
 770
 771 -- -----------------------------------------------------------------------------
 772 --      Eta reduction
 773 -- -----------------------------------------------------------------------------
 774
 775 Note [Eta expansion]
 776 ~~~~~~~~~~~~~~~~~~~~~
 777 Eta expand to match the arity claimed by the binder Remember,
 778 CorePrep must not change arity
 779
 780 Eta expansion might not have happened already, because it is done by
 781 the simplifier only when there at least one lambda already.
 782
 783 NB1:we could refrain when the RHS is trivial (which can happen
 784     for exported things).  This would reduce the amount of code
 785     generated (a little) and make things a little words for
 786     code compiled without -O.  The case in point is data constructor
 787     wrappers.
 788
 789 NB2: we have to be careful that the result of etaExpand doesn't
 790    invalidate any of the assumptions that CorePrep is attempting
 791    to establish.  One possible cause is eta expanding inside of
 792    an SCC note - we're now careful in etaExpand to make sure the
 793    SCC is pushed inside any new lambdas that are generated.
 794
 795 Note [Eta expansion and the CorePrep invariants]
 796 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 797 It turns out to be much much easier to do eta expansion
 798 *after* the main CorePrep stuff.  But that places constraints
 799 on the eta expander: given a CpeRhs, it must return a CpeRhs.
 800
 801 For example here is what we do not want:
 802                 f = /\a -> g (h 3)      -- h has arity 2
 803 After ANFing we get
 804                 f = /\a -> let s = h 3 in g s
 805 and now we do NOT want eta expansion to give
 806                 f = /\a -> \ y -> (let s = h 3 in g s) y
 807
 808 Instead CoreArity.etaExpand gives
 809                 f = /\a -> \y -> let s = h 3 in g s y
 810
 811 \begin{code}
 812 cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
 813 cpeEtaExpand arity expr
 814   | arity == 0 = expr
 815   | otherwise  = etaExpand arity expr
 816 \end{code}
 817
 818 -- -----------------------------------------------------------------------------
 819 --      Eta reduction
 820 -- -----------------------------------------------------------------------------
 821
 822 Why try eta reduction?  Hasn't the simplifier already done eta?
 823 But the simplifier only eta reduces if that leaves something
 824 trivial (like f, or f Int).  But for deLam it would be enough to
 825 get to a partial application:
 826         case x of { p -> \xs. map f xs }
 827     ==> case x of { p -> map f }
 828
 829 \begin{code}
 830 tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
 831 tryEtaReducePrep bndrs expr@(App _ _)
 832   | ok_to_eta_reduce f &&
 833     n_remaining >= 0 &&
 834     and (zipWith ok bndrs last_args) &&
 835     not (any (`elemVarSet` fvs_remaining) bndrs)
 836   = Just remaining_expr
 837   where
 838     (f, args) = collectArgs expr
 839     remaining_expr = mkApps f remaining_args
 840     fvs_remaining = exprFreeVars remaining_expr
 841     (remaining_args, last_args) = splitAt n_remaining args
 842     n_remaining = length args - length bndrs
 843
 844     ok bndr (Var arg) = bndr == arg
 845     ok _    _         = False
 846
 847           -- we can't eta reduce something which must be saturated.
 848     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 849     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 850
 851 tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
 852   | not (any (`elemVarSet` fvs) bndrs)
 853   = case tryEtaReducePrep bndrs body of
 854         Just e -> Just (Let bind e)
 855         Nothing -> Nothing
 856   where
 857     fvs = exprFreeVars r
 858
 859 tryEtaReducePrep _ _ = Nothing
 860 \end{code}
 861
 862
 863 -- -----------------------------------------------------------------------------
 864 -- Demands
 865 -- -----------------------------------------------------------------------------
 866
 867 \begin{code}
 868 type RhsDemand = Bool  -- True => used strictly; hence not top-level, non-recursive
 869 \end{code}
 870
 871 %************************************************************************
 872 %*                                                                      *
 873                 Floats
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 \begin{code}
 878 data FloatingBind
 879   = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
 880                          -- They are always of lifted type;
 881                          -- unlifted ones are done with FloatCase
 882
 883  | FloatCase
 884       Id CpeBody
 885       Bool              -- The bool indicates "ok-for-speculation"
 886
 887 data Floats = Floats OkToSpec (OrdList FloatingBind)
 888
 889 instance Outputable FloatingBind where
 890   ppr (FloatLet b) = ppr b
 891   ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
 892
 893 instance Outputable Floats where
 894   ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
 895                          braces (vcat (map ppr (fromOL fs)))
 896
 897 instance Outputable OkToSpec where
 898   ppr OkToSpec    = ptext (sLit "OkToSpec")
 899   ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk")
 900   ppr NotOkToSpec = ptext (sLit "NotOkToSpec")
 901
 902 -- Can we float these binds out of the rhs of a let?  We cache this decision
 903 -- to avoid having to recompute it in a non-linear way when there are
 904 -- deeply nested lets.
 905 data OkToSpec
 906    = OkToSpec           -- Lazy bindings of lifted type
 907    | IfUnboxedOk        -- A mixture of lazy lifted bindings and n
 908                         -- ok-to-speculate unlifted bindings
 909    | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings
 910
 911 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
 912 mkFloat is_strict is_unlifted bndr rhs
 913   | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)
 914   | otherwise = FloatLet (NonRec bndr rhs)
 915   where
 916     use_case = is_unlifted || is_strict && not (exprIsHNF rhs)
 917                 -- Don't make a case for a value binding,
 918                 -- even if it's strict.  Otherwise we get
 919                 --      case (\x -> e) of ...!
 920
 921 emptyFloats :: Floats
 922 emptyFloats = Floats OkToSpec nilOL
 923
 924 isEmptyFloats :: Floats -> Bool
 925 isEmptyFloats (Floats _ bs) = isNilOL bs
 926
 927 wrapBinds :: Floats -> CpeBody -> CpeBody
 928 wrapBinds (Floats _ binds) body
 929   = foldrOL mk_bind body binds
 930   where
 931     mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 932     mk_bind (FloatLet bind)        body = Let bind body
 933
 934 addFloat :: Floats -> FloatingBind -> Floats
 935 addFloat (Floats ok_to_spec floats) new_float
 936   = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
 937   where
 938     check (FloatLet _) = OkToSpec
 939     check (FloatCase _ _ ok_for_spec)
 940         | ok_for_spec  =  IfUnboxedOk
 941         | otherwise    =  NotOkToSpec
 942         -- The ok-for-speculation flag says that it's safe to
 943         -- float this Case out of a let, and thereby do it more eagerly
 944         -- We need the top-level flag because it's never ok to float
 945         -- an unboxed binding to the top level
 946
 947 unitFloat :: FloatingBind -> Floats
 948 unitFloat = addFloat emptyFloats
 949
 950 appendFloats :: Floats -> Floats -> Floats
 951 appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
 952   = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
 953
 954 concatFloats :: [Floats] -> OrdList FloatingBind
 955 concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
 956
 957 combine :: OkToSpec -> OkToSpec -> OkToSpec
 958 combine NotOkToSpec _ = NotOkToSpec
 959 combine _ NotOkToSpec = NotOkToSpec
 960 combine IfUnboxedOk _ = IfUnboxedOk
 961 combine _ IfUnboxedOk = IfUnboxedOk
 962 combine _ _           = OkToSpec
 963
 964 deFloatTop :: Floats -> [CoreBind]
 965 -- For top level only; we don't expect any FloatCases
 966 deFloatTop (Floats _ floats)
 967   = foldrOL get [] floats
 968   where
 969     get (FloatLet b) bs = occurAnalyseRHSs b : bs
 970     get b            _  = pprPanic "corePrepPgm" (ppr b)
 971
 972     -- See Note [Dead code in CorePrep]
 973     occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e)
 974     occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
 975
 976 -------------------------------------------
 977 canFloatFromNoCaf ::  Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
 978        -- Note [CafInfo and floating]
 979 canFloatFromNoCaf (Floats ok_to_spec fs) rhs
 980   | OkToSpec <- ok_to_spec           -- Worth trying
 981   , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
 982   = Just (Floats OkToSpec fs', subst_expr subst rhs)
 983   | otherwise
 984   = Nothing
 985   where
 986     subst_expr = substExpr (text "CorePrep")
 987
 988     go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
 989        -> Maybe (Subst, OrdList FloatingBind)
 990
 991     go (subst, fbs_out) [] = Just (subst, fbs_out)
 992
 993     go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
 994       | rhs_ok r
 995       = go (subst', fbs_out `snocOL` new_fb) fbs_in
 996       where
 997         (subst', b') = set_nocaf_bndr subst b
 998         new_fb = FloatLet (NonRec b' (subst_expr subst r))
 999
1000     go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
1001       | all rhs_ok rs
1002       = go (subst', fbs_out `snocOL` new_fb) fbs_in
1003       where
1004         (bs,rs) = unzip prs
1005         (subst', bs') = mapAccumL set_nocaf_bndr subst bs
1006         rs' = map (subst_expr subst') rs
1007         new_fb = FloatLet (Rec (bs' `zip` rs'))
1008
1009     go _ _ = Nothing      -- Encountered a caffy binding
1010
1011     ------------
1012     set_nocaf_bndr subst bndr
1013       = (extendIdSubst subst bndr (Var bndr'), bndr')
1014       where
1015         bndr' = bndr `setIdCafInfo` NoCafRefs
1016
1017     ------------
1018     rhs_ok :: CoreExpr -> Bool
1019     -- We can only float to top level from a NoCaf thing if
1020     -- the new binding is static. However it can't mention
1021     -- any non-static things or it would *already* be Caffy
1022     rhs_ok = rhsIsStatic (\_ -> False)
1023
1024 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
1025 wantFloatNested is_rec strict_or_unlifted floats rhs
1026   =  isEmptyFloats floats
1027   || strict_or_unlifted
1028   || (allLazyNested is_rec floats && exprIsHNF rhs)
1029         -- Why the test for allLazyNested?
1030         --      v = f (x `divInt#` y)
1031         -- we don't want to float the case, even if f has arity 2,
1032         -- because floating the case would make it evaluated too early
1033
1034 allLazyTop :: Floats -> Bool
1035 allLazyTop (Floats OkToSpec _) = True
1036 allLazyTop _                   = False
1037
1038 allLazyNested :: RecFlag -> Floats -> Bool
1039 allLazyNested _      (Floats OkToSpec    _) = True
1040 allLazyNested _      (Floats NotOkToSpec _) = False
1041 allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
1042 \end{code}
1043
1044
1045 %************************************************************************
1046 %*                                                                      *
1047                 Cloning
1048 %*                                                                      *
1049 %************************************************************************
1050
1051 \begin{code}
1052 -- ---------------------------------------------------------------------------
1053 --                      The environment
1054 -- ---------------------------------------------------------------------------
1055
1056 data CorePrepEnv = CPE (IdEnv Id)       -- Clone local Ids
1057
1058 emptyCorePrepEnv :: CorePrepEnv
1059 emptyCorePrepEnv = CPE emptyVarEnv
1060
1061 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
1062 extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id')
1063
1064 extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
1065 extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs)
1066
1067 lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
1068 lookupCorePrepEnv (CPE env) id
1069   = case lookupVarEnv env id of
1070         Nothing  -> id
1071         Just id' -> id'
1072
1073 ------------------------------------------------------------------------------
1074 -- Cloning binders
1075 -- ---------------------------------------------------------------------------
1076
1077 cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])
1078 cloneBndrs env bs = mapAccumLM cloneBndr env bs
1079
1080 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
1081 cloneBndr env bndr
1082   | isLocalId bndr, not (isCoVar bndr)
1083   = do bndr' <- setVarUnique bndr <$> getUniqueM
1084
1085        -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
1086        -- so that we can drop more stuff as dead code.
1087        -- See also Note [Dead code in CorePrep]
1088        let bndr'' = bndr' `setIdUnfolding` noUnfolding
1089                           `setIdSpecialisation` emptySpecInfo
1090        return (extendCorePrepEnv env bndr bndr'', bndr'')
1091
1092   | otherwise   -- Top level things, which we don't want
1093                 -- to clone, have become GlobalIds by now
1094                 -- And we don't clone tyvars, or coercion variables
1095   = return (env, bndr)
1096
1097
1098 ------------------------------------------------------------------------------
1099 -- Cloning ccall Ids; each must have a unique name,
1100 -- to give the code generator a handle to hang it on
1101 -- ---------------------------------------------------------------------------
1102
1103 fiddleCCall :: Id -> UniqSM Id
1104 fiddleCCall id
1105   | isFCallId id = (id `setVarUnique`) <$> getUniqueM
1106   | otherwise    = return id
1107
1108 ------------------------------------------------------------------------------
1109 -- Generating new binders
1110 -- ---------------------------------------------------------------------------
1111
1112 newVar :: Type -> UniqSM Id
1113 newVar ty
1114  = seqType ty `seq` do
1115      uniq <- getUniqueM
1116      return (mkSysLocal (fsLit "sat") uniq ty)
1117 \end{code}