ghc/compiler/stgSyn/CoreToStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[CoreToStg]{Converting core syntax to STG syntax}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
  11
  12 \begin{code}
  13 module CoreToStg ( topCoreBindsToStg, coreToStgExpr ) where
  14
  15 #include "HsVersions.h"
  16
  17 import CoreSyn          -- input
  18 import StgSyn           -- output
  19
  20 import CoreUtils        ( exprType )
  21 import SimplUtils       ( findDefault )
  22 import CostCentre       ( noCCS )
  23 import Id               ( Id, mkSysLocal, idType, idStrictness, isExportedId,
  24                           mkVanillaId, idName, idDemandInfo, idArity, setIdType,
  25                           idFlavour
  26                         )
  27 import Module           ( Module )
  28 import IdInfo           ( StrictnessInfo(..), IdFlavour(..) )
  29 import DataCon          ( dataConWrapId, dataConTyCon )
  30 import TyCon            ( isAlgTyCon )
  31 import Demand           ( Demand, isStrict, wwLazy )
  32 import Name             ( setNameUnique, globaliseName, isLocalName )
  33 import VarEnv
  34 import PrimOp           ( PrimOp(..), setCCallUnique )
  35 import Type             ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
  36                           applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
  37                           splitRepFunTys, mkFunTys,
  38                           uaUTy, usOnce, usMany, isTyVarTy
  39                         )
  40 import UniqSupply       -- all of it, really
  41 import UniqSet          ( emptyUniqSet )
  42 import ErrUtils         ( showPass, dumpIfSet_dyn )
  43 import CmdLineOpts      ( DynFlags, DynFlag(..) )
  44 import Maybes
  45 import Outputable
  46 \end{code}
  47
  48
  49         *************************************************
  50         ***************  OVERVIEW   *********************
  51         *************************************************
  52
  53
  54 The business of this pass is to convert Core to Stg.  On the way it
  55 does some important transformations:
  56
  57 1.  We discard type lambdas and applications. In so doing we discard
  58     "trivial" bindings such as
  59         x = y t1 t2
  60     where t1, t2 are types
  61
  62 2.  We get the program into "A-normal form".  In particular:
  63
  64         f E        ==>  let x = E in f x
  65                 OR ==>  case E of x -> f x
  66
  67     where E is a non-trivial expression.
  68     Which transformation is used depends on whether f is strict or not.
  69     [Previously the transformation to case used to be done by the
  70      simplifier, but it's better done here.  It does mean that f needs
  71      to have its strictness info correct!.]
  72
  73     Similarly, convert any unboxed let's into cases.
  74     [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
  75      right up to this point.]
  76
  77 3.  We clone all local binders.  The code generator uses the uniques to
  78     name chunks of code for thunks, so it's important that the names used
  79     are globally unique, not simply not-in-scope, which is all that
  80     the simplifier ensures.
  81
  82 4.  If we are going to do object-file splitting, we make ALL top-level
  83     names into Globals.  Why?
  84
  85     In certain (prelude only) modules we split up the .hc file into
  86     lots of separate little files, which are separately compiled by the C
  87     compiler.  That gives lots of little .o files.  The idea is that if
  88     you happen to mention one of them you don't necessarily pull them all
  89     in.  (Pulling in a piece you don't need can be v bad, because it may
  90     mention other pieces you don't need either, and so on.)
  91
  92     Sadly, splitting up .hc files means that local names (like s234) are
  93     now globally visible, which can lead to clashes between two .hc
  94     files. So we make them all Global, so they are printed complete
  95     with their module name.
  96
  97     We don't want to do this in CoreTidy, because at that stage we use
  98     Global to mean "external" and hence "should appear in interface files".
  99     This object-file splitting thing is a code generator matter that we
 100     don't want to pollute earlier phases.
 101
 102 NOTE THAT:
 103
 104 * We don't pin on correct arities any more, because they can be mucked up
 105   by the lambda lifter.  In particular, the lambda lifter can take a local
 106   letrec-bound variable and make it a lambda argument, which shouldn't have
 107   an arity.  So SetStgVarInfo sets arities now.
 108
 109 * We do *not* pin on the correct free/live var info; that's done later.
 110   Instead we use bOGUS_LVS and _FVS as a placeholder.
 111
 112 [Quite a bit of stuff that used to be here has moved
 113  to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
 114
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 \subsection[coreToStg-programs]{Converting a core program and core bindings}
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 March 98: We keep a small environment to give all locally bound
 123 Names new unique ids, since the code generator assumes that binders
 124 are unique across a module. (Simplifier doesn't maintain this
 125 invariant any longer.)
 126
 127 A binder to be floated out becomes an @StgFloatBind@.
 128
 129 \begin{code}
 130 type StgEnv = IdEnv Id
 131
 132 data StgFloatBind = NoBindF
 133                   | RecF [(Id, StgRhs)]
 134                   | NonRecF
 135                         Id
 136                         StgExpr         -- *Can* be a StgLam
 137                         RhsDemand
 138                         [StgFloatBind]
 139
 140 -- The interesting one is the NonRecF
 141 --      NonRecF x rhs demand binds
 142 -- means
 143 --      x = let binds in rhs
 144 -- (or possibly case etc if x demand is strict)
 145 -- The binds are kept separate so they can be floated futher
 146 -- if appropriate
 147 \end{code}
 148
 149 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
 150 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
 151 otherwise.
 152
 153 \begin{code}
 154 data RhsDemand  = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
 155                               isOnceDem   :: Bool   -- True => used at most once
 156                             }
 157
 158 mkDem :: Demand -> Bool -> RhsDemand
 159 mkDem strict once = RhsDemand (isStrict strict) once
 160
 161 mkDemTy :: Demand -> Type -> RhsDemand
 162 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
 163
 164 isOnceTy :: Type -> Bool
 165 isOnceTy ty
 166   =
 167 #ifdef USMANY
 168     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 169 #endif
 170     once
 171   where
 172     u = uaUTy ty
 173     once | u == usOnce  = True
 174          | u == usMany  = False
 175          | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
 176
 177 bdrDem :: Id -> RhsDemand
 178 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
 179
 180 safeDem, onceDem :: RhsDemand
 181 safeDem = RhsDemand False False  -- always safe to use this
 182 onceDem = RhsDemand False True   -- used at most once
 183 \end{code}
 184
 185 No free/live variable information is pinned on in this pass; it's added
 186 later.  For this pass
 187 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
 188
 189 When printing out the Stg we need non-bottom values in these
 190 locations.
 191
 192 \begin{code}
 193 bOGUS_LVs :: StgLiveVars
 194 bOGUS_LVs = emptyUniqSet
 195
 196 bOGUS_FVs :: [Id]
 197 bOGUS_FVs = []
 198 \end{code}
 199
 200 \begin{code}
 201 topCoreBindsToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
 202 topCoreBindsToStg dflags mod core_binds
 203   = do showPass dflags "Core2Stg"
 204        us <- mkSplitUniqSupply 'c'
 205        return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
 206   where
 207     top_flag = Top mod
 208
 209     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 210
 211     coreBindsToStg env [] = returnUs []
 212     coreBindsToStg env (b:bs)
 213       = coreBindToStg  top_flag env b   `thenUs` \ (bind_spec, new_env) ->
 214         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 215         case bind_spec of
 216           NonRecF bndr rhs dem floats
 217                 -> ASSERT2( not (isStrictDem dem) &&
 218                             not (isUnLiftedType (idType bndr)),
 219                             ppr b )             -- No top-level cases!
 220
 221                    mkStgBinds floats rhs        `thenUs` \ new_rhs ->
 222                    returnUs (StgNonRec bndr (exprToRhs dem top_flag new_rhs)
 223                              : new_bs)
 224                                         -- Keep all the floats inside...
 225                                         -- Some might be cases etc
 226                                         -- We might want to revisit this decision
 227
 228           RecF prs -> returnUs (StgRec prs : new_bs)
 229           NoBindF  -> pprTrace "topCoreBindsToStg" (ppr b) $
 230                       returnUs new_bs
 231 \end{code}
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
 241 coreToStgExpr dflags core_expr
 242   = do showPass dflags "Core2Stg"
 243        us <- mkSplitUniqSupply 'c'
 244        let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
 245        dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
 246        return stg_expr
 247 \end{code}
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection[coreToStg-binds]{Converting bindings}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 \begin{code}
 256 coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
 257
 258 coreBindToStg top_lev env (NonRec binder rhs)
 259   = coreExprToStgFloat env rhs                  `thenUs` \ (floats, stg_rhs) ->
 260     case (floats, stg_rhs) of
 261         ([], StgApp var []) | not (isExportedId binder)
 262                      -> returnUs (NoBindF, extendVarEnv env binder var)
 263                 -- A trivial binding let x = y in ...
 264                 -- can arise if postSimplExpr floats a NoRep literal out
 265                 -- so it seems sensible to deal with it well.
 266                 -- But we don't want to discard exported things.  They can
 267                 -- occur; e.g. an exported user binding f = g
 268
 269         other -> newBinder top_lev env binder           `thenUs` \ (new_env, new_binder) ->
 270                  returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
 271   where
 272     dem = bdrDem binder
 273
 274
 275 coreBindToStg top_lev env (Rec pairs)
 276   = newBinders top_lev env binders      `thenUs` \ (env', binders') ->
 277     mapUs (do_rhs env') pairs           `thenUs` \ stg_rhss ->
 278     returnUs (RecF (binders' `zip` stg_rhss), env')
 279   where
 280     binders = map fst pairs
 281     do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs          `thenUs` \ (floats, stg_expr) ->
 282                             mkStgBinds floats stg_expr          `thenUs` \ stg_expr' ->
 283                                 -- NB: stg_expr' might still be a StgLam (and we want that)
 284                             returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
 285 \end{code}
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsection[coreToStg-rhss]{Converting right hand sides}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 exprToRhs :: RhsDemand -> TopLvl -> StgExpr -> StgRhs
 296 exprToRhs dem _ (StgLam _ bndrs body)
 297   = ASSERT( not (null bndrs) )
 298     StgRhsClosure noCCS
 299                   stgArgOcc
 300                   noSRT
 301                   bOGUS_FVs
 302                   ReEntrant     -- binders is non-empty
 303                   bndrs
 304                   body
 305
 306 {-
 307   We reject the following candidates for 'static constructor'dom:
 308
 309     - any dcon that takes a lit-lit as an arg.
 310     - [Win32 DLLs only]: any dcon that resides in a DLL
 311       (or takes as arg something that is.)
 312
 313   These constraints are necessary to ensure that the code
 314   generated in the end for the static constructors, which
 315   live in the data segment, remain valid - i.e., it has to
 316   be constant. For obvious reasons, that's hard to guarantee
 317   with lit-lits. The second case of a constructor referring
 318   to static closures hiding out in some DLL is an artifact
 319   of the way Win32 DLLs handle global DLL variables. A (data)
 320   symbol exported from a DLL  has to be accessed through a
 321   level of indirection at the site of use, so whereas
 322
 323      extern StgClosure y_closure;
 324      extern StgClosure z_closure;
 325      x = { ..., &y_closure, &z_closure };
 326
 327   is legal when the symbols are in scope at link-time, it is
 328   not when y_closure is in a DLL. So, any potential static
 329   closures that refers to stuff that's residing in a DLL
 330   will be put in an (updateable) thunk instead.
 331
 332   An alternative strategy is to support the generation of
 333   constructors (ala C++ static class constructors) which will
 334   then be run at load time to fix up static closures.
 335 -}
 336 exprToRhs dem toplev (StgConApp con args)
 337   | isNotTop toplev || not (isDllConApp con args)
 338         -- isDllConApp checks for LitLit args too
 339   = StgRhsCon noCCS con args
 340
 341 exprToRhs dem toplev expr
 342   = upd `seq`
 343     StgRhsClosure       noCCS           -- No cost centre (ToDo?)
 344                         stgArgOcc       -- safe
 345                         noSRT           -- figure out later
 346                         bOGUS_FVs
 347                         upd
 348                         []
 349                         expr
 350   where
 351     upd = if isOnceDem dem
 352           then (if isNotTop toplev
 353                 then SingleEntry              -- HA!  Paydirt for "dem"
 354                 else
 355 #ifdef DEBUG
 356                      trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
 357 #endif
 358                      Updatable)
 359           else Updatable
 360         -- For now we forbid SingleEntry CAFs; they tickle the
 361         -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
 362         -- and I don't understand why.  There's only one SE_CAF (well,
 363         -- only one that tickled a great gaping bug in an earlier attempt
 364         -- at ClosureInfo.getEntryConvention) in the whole of nofib,
 365         -- specifically Main.lvl6 in spectral/cryptarithm2.
 366         -- So no great loss.  KSW 2000-07.
 367 \end{code}
 368
 369
 370 %************************************************************************
 371 %*                                                                      *
 372 \subsection[coreToStg-atoms{Converting atoms}
 373 %*                                                                      *
 374 %************************************************************************
 375
 376 \begin{code}
 377 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
 378 -- Arguments are all value arguments (tyargs already removed), paired with their demand
 379
 380 coreArgsToStg env []
 381   = returnUs ([], [])
 382
 383 coreArgsToStg env (ad:ads)
 384   = coreArgToStg env ad         `thenUs` \ (bs1, a') ->
 385     coreArgsToStg env ads       `thenUs` \ (bs2, as') ->
 386     returnUs (bs1 ++ bs2, a' : as')
 387
 388
 389 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
 390 -- This is where we arrange that a non-trivial argument is let-bound
 391
 392 coreArgToStg env (arg,dem)
 393   = coreExprToStgFloat env arg          `thenUs` \ (floats, arg') ->
 394     case arg' of
 395         StgApp v []      -> returnUs (floats, StgVarArg v)
 396         StgLit lit       -> returnUs (floats, StgLitArg lit)
 397
 398         StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
 399                 -- A nullary constructor can be replaced with
 400                 -- a ``call'' to its wrapper
 401
 402         other            -> newStgVar arg_ty    `thenUs` \ v ->
 403                             returnUs ([NonRecF v arg' dem floats], StgVarArg v)
 404   where
 405     arg_ty = exprType arg
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection[coreToStg-exprs]{Converting core expressions}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 \begin{code}
 416 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
 417 coreExprToStg env expr
 418   = coreExprToStgFloat env expr         `thenUs` \ (binds,stg_expr) ->
 419     mkStgBinds binds stg_expr           `thenUs` \ stg_expr' ->
 420     deStgLam stg_expr'
 421 \end{code}
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 \begin{code}
 430 coreExprToStgFloat :: StgEnv -> CoreExpr
 431                    -> UniqSM ([StgFloatBind], StgExpr)
 432 -- Transform an expression to STG.  The 'floats' are
 433 -- any bindings we had to create for function arguments.
 434 \end{code}
 435
 436 Simple cases first
 437
 438 \begin{code}
 439 coreExprToStgFloat env (Var var)
 440   = mkStgApp env var [] (idType var)    `thenUs` \ app ->
 441     returnUs ([], app)
 442
 443 coreExprToStgFloat env (Lit lit)
 444   = returnUs ([], StgLit lit)
 445
 446 coreExprToStgFloat env (Let bind body)
 447   = coreBindToStg NotTop env bind       `thenUs` \ (new_bind, new_env) ->
 448     coreExprToStgFloat new_env body     `thenUs` \ (floats, stg_body) ->
 449     returnUs (new_bind:floats, stg_body)
 450 \end{code}
 451
 452 Convert core @scc@ expression directly to STG @scc@ expression.
 453
 454 \begin{code}
 455 coreExprToStgFloat env (Note (SCC cc) expr)
 456   = coreExprToStg env expr      `thenUs` \ stg_expr ->
 457     returnUs ([], StgSCC cc stg_expr)
 458
 459 coreExprToStgFloat env (Note other_note expr)
 460   = coreExprToStgFloat env expr
 461 \end{code}
 462
 463 \begin{code}
 464 coreExprToStgFloat env expr@(Type _)
 465   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 coreExprToStgFloat env expr@(Lam _ _)
 477   = let
 478         expr_ty         = exprType expr
 479         (binders, body) = collectBinders expr
 480         id_binders      = filter isId binders
 481     in
 482     if null id_binders then     -- It was all type binders; tossed
 483         coreExprToStgFloat env body
 484     else
 485         -- At least some value binders
 486     newLocalBinders env id_binders      `thenUs` \ (env', binders') ->
 487     coreExprToStgFloat env' body        `thenUs` \ (floats, stg_body) ->
 488     mkStgBinds floats stg_body          `thenUs` \ stg_body' ->
 489
 490     case stg_body' of
 491       StgLam ty lam_bndrs lam_body ->
 492                 -- If the body reduced to a lambda too, join them up
 493           returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
 494
 495       other ->
 496                 -- Body didn't reduce to a lambda, so return one
 497           returnUs ([], mkStgLam expr_ty binders' stg_body')
 498 \end{code}
 499
 500
 501 %************************************************************************
 502 %*                                                                      *
 503 \subsubsection[coreToStg-applications]{Applications}
 504 %*                                                                      *
 505 %************************************************************************
 506
 507 \begin{code}
 508 coreExprToStgFloat env expr@(App _ _)
 509   = let
 510         (fun,rads,ty,ss)      = collect_args expr
 511         ads                   = reverse rads
 512         final_ads | null ss   = ads
 513                   | otherwise = zap ads -- Too few args to satisfy strictness info
 514                                         -- so we have to ignore all the strictness info
 515                                         -- e.g. + (error "urk")
 516                                         -- Here, we can't evaluate the arg strictly,
 517                                         -- because this partial application might be seq'd
 518     in
 519     coreArgsToStg env final_ads         `thenUs` \ (arg_floats, stg_args) ->
 520
 521         -- Now deal with the function
 522     case (fun, stg_args) of
 523       (Var fn_id, _) ->         -- A function Id, so do an StgApp; it's ok if
 524                                 -- there are no arguments.
 525                             mkStgApp env fn_id stg_args ty      `thenUs` \ app ->
 526                             returnUs (arg_floats, app)
 527
 528       (non_var_fun, []) ->      -- No value args, so recurse into the function
 529                             ASSERT( null arg_floats )
 530                             coreExprToStgFloat env non_var_fun
 531
 532       other ->  -- A non-variable applied to things; better let-bind it.
 533                 newStgVar (exprType fun)                `thenUs` \ fn_id ->
 534                 coreExprToStgFloat env fun              `thenUs` \ (fun_floats, stg_fun) ->
 535                 mkStgApp env fn_id stg_args ty          `thenUs` \ app ->
 536                 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
 537                           app)
 538
 539   where
 540         -- Collect arguments and demands (*in reverse order*)
 541         -- collect_args e = (f, args_w_demands, ty, stricts)
 542         --  => e = f tys args,  (i.e. args are just the value args)
 543         --     e :: ty
 544         --     stricts is the leftover demands of e on its further args
 545         -- If stricts runs out, we zap all the demands in args_w_demands
 546         -- because partial applications are lazy
 547
 548     collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
 549
 550     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
 551                                           in  (the_fun,ads,ty,ss)
 552     collect_args (Note InlineCall    e) = collect_args e
 553
 554     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
 555                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)
 556     collect_args (App fun arg)
 557         = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
 558         where
 559           (ss1, ss_rest)             = case ss of
 560                                          (ss1:ss_rest) -> (ss1, ss_rest)
 561                                          []            -> (wwLazy, [])
 562           (the_fun, ads, fun_ty, ss) = collect_args fun
 563           (arg_ty, res_ty)           = expectJust "coreExprToStgFloat:collect_args" $
 564                                        splitFunTy_maybe fun_ty
 565
 566     collect_args (Var v)
 567         = (Var v, [], idType v, stricts)
 568         where
 569           stricts = case idStrictness v of
 570                         StrictnessInfo demands _ -> demands
 571                         other                    -> repeat wwLazy
 572
 573     collect_args fun = (fun, [], exprType fun, repeat wwLazy)
 574
 575     -- "zap" nukes the strictness info for a partial application
 576     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 577 \end{code}
 578
 579
 580 %************************************************************************
 581 %*                                                                      *
 582 \subsubsection[coreToStg-cases]{Case expressions}
 583 %*                                                                      *
 584 %************************************************************************
 585
 586 \begin{code}
 587 coreExprToStgFloat env (Case scrut bndr alts)
 588   = coreExprToStgFloat env scrut                `thenUs` \ (binds, scrut') ->
 589     newLocalBinder env bndr                     `thenUs` \ (env', bndr') ->
 590     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 591     mkStgCase scrut' bndr' alts'                `thenUs` \ expr' ->
 592     returnUs (binds, expr')
 593   where
 594     scrut_ty  = idType bndr
 595     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 596
 597     alts_to_stg env (alts, deflt)
 598       | prim_case
 599       = default_to_stg env deflt                `thenUs` \ deflt' ->
 600         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 601         returnUs (mkStgPrimAlts scrut_ty alts' deflt')
 602
 603       | otherwise
 604       = default_to_stg env deflt                `thenUs` \ deflt' ->
 605         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 606         returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 607
 608     alg_alt_to_stg env (DataAlt con, bs, rhs)
 609           = newLocalBinders env (filter isId bs)        `thenUs` \ (env', stg_bs) ->
 610             coreExprToStg env' rhs                      `thenUs` \ stg_rhs ->
 611             returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
 612                 -- NB the filter isId.  Some of the binders may be
 613                 -- existential type variables, which STG doesn't care about
 614
 615     prim_alt_to_stg env (LitAlt lit, args, rhs)
 616           = ASSERT( null args )
 617             coreExprToStg env rhs       `thenUs` \ stg_rhs ->
 618             returnUs (lit, stg_rhs)
 619
 620     default_to_stg env Nothing
 621       = returnUs StgNoDefault
 622
 623     default_to_stg env (Just rhs)
 624       = coreExprToStg env rhs   `thenUs` \ stg_rhs ->
 625         returnUs (StgBindDefault stg_rhs)
 626 \end{code}
 627
 628
 629 %************************************************************************
 630 %*                                                                      *
 631 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 632 %*                                                                      *
 633 %************************************************************************
 634
 635 There's not anything interesting we can ASSERT about \tr{var} if it
 636 isn't in the StgEnv. (WDP 94/06)
 637
 638 Invent a fresh @Id@:
 639 \begin{code}
 640 newStgVar :: Type -> UniqSM Id
 641 newStgVar ty
 642  = getUniqueUs                  `thenUs` \ uniq ->
 643    seqType ty                   `seq`
 644    returnUs (mkSysLocal SLIT("stg") uniq ty)
 645 \end{code}
 646
 647 \begin{code}
 648 ----------------------------
 649 data TopLvl = Top Module | NotTop
 650
 651 isNotTop NotTop  = True
 652 isNotTop (Top _) = False
 653
 654 ----------------------------
 655 newBinder :: TopLvl -> StgEnv -> Id -> UniqSM (StgEnv, Id)
 656 newBinder (Top mod) env id = returnUs (env, newTopBinder mod id)
 657 newBinder NotTop    env id = newLocalBinder env id
 658
 659 newBinders (Top mod) env ids = returnUs (env, map (newTopBinder mod) ids)
 660 newBinders NotTop    env ids = newLocalBinders env ids
 661
 662
 663 ----------------------------
 664 newTopBinder mod id
 665   -- Don't clone top-level binders.  MkIface relies on their
 666   -- uniques staying the same, so it can snaffle IdInfo off the
 667   -- STG ids to put in interface files.
 668   = name'               `seq`
 669     seqType ty          `seq`
 670     mkVanillaId name' ty
 671   where
 672       name  = idName id
 673       name' | isLocalName name = globaliseName name mod
 674             | otherwise        = name
 675       ty    = idType id
 676
 677 ----------------------------
 678 newLocalBinder :: StgEnv -> Id -> UniqSM (StgEnv, Id)
 679 newLocalBinder env id
 680   =     -- Local binder, give it a new unique Id.
 681     getUniqueUs                 `thenUs` \ uniq ->
 682     let
 683       name    = idName id
 684       ty      = idType id
 685       new_id  = mkVanillaId (setNameUnique name uniq) ty
 686       new_env = extendVarEnv env id new_id
 687     in
 688     name                `seq`
 689     seqType ty          `seq`
 690     returnUs (new_env, new_id)
 691
 692 ----------------------------
 693 newLocalBinders :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 694 newLocalBinders env []
 695   = returnUs (env, [])
 696
 697 newLocalBinders env (b:bs)
 698   = newLocalBinder  env b       `thenUs` \ (env', b') ->
 699     newLocalBinders env' bs     `thenUs` \ (env'', bs') ->
 700     returnUs (env'', b':bs')
 701 \end{code}
 702
 703
 704 %************************************************************************
 705 %*                                                                      *
 706 \subsection{Building STG syn}
 707 %*                                                                      *
 708 %************************************************************************
 709
 710 \begin{code}
 711 -- There are two things going on in mkStgAlgAlts
 712 -- a)   We pull out the type constructor for the case, from the data
 713 --      constructor, if there is one.  See notes with the StgAlgAlts data type
 714 -- b)   We force the type constructor to avoid space leaks
 715
 716 mkStgAlgAlts ty alts deflt
 717   = case alts of
 718                 -- Get the tycon from the data con
 719         (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
 720
 721                 -- Otherwise just do your best
 722         [] -> case splitTyConApp_maybe (repType ty) of
 723                 Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
 724                 other                       -> StgAlgAlts Nothing alts deflt
 725
 726 mkStgPrimAlts ty alts deflt
 727   = case splitTyConApp ty of
 728         (tc,_) -> StgPrimAlts tc alts deflt
 729
 730 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
 731
 732 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
 733         -- The type is the type of the entire application
 734 mkStgApp env fn args ty
 735  = case idFlavour fn_alias of
 736       DataConId dc
 737         -> saturate fn_alias args ty    $ \ args' ty' ->
 738            returnUs (StgConApp dc args')
 739
 740       PrimOpId (CCallOp ccall)
 741                 -- Sigh...make a guaranteed unique name for a dynamic ccall
 742                 -- Done here, not earlier, because it's a code-gen thing
 743         -> saturate fn_alias args ty    $ \ args' ty' ->
 744            getUniqueUs                  `thenUs` \ uniq ->
 745            let ccall' = setCCallUnique ccall uniq in
 746            returnUs (StgPrimApp (CCallOp ccall') args' ty')
 747
 748
 749       PrimOpId op
 750         -> saturate fn_alias args ty    $ \ args' ty' ->
 751            returnUs (StgPrimApp op args' ty')
 752
 753       other -> returnUs (StgApp fn_alias args)
 754                         -- Force the lookup
 755   where
 756     fn_alias = case (lookupVarEnv env fn) of    -- In case it's been cloned
 757                       Nothing  -> fn
 758                       Just fn' -> fn'
 759
 760 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
 761         -- The type should be the type of (id args)
 762 saturate fn args ty thing_inside
 763   | excess_arity == 0   -- Saturated, so nothing to do
 764   = thing_inside args ty
 765
 766   | otherwise   -- An unsaturated constructor or primop; eta expand it
 767   = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
 768              ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
 769     mapUs newStgVar extra_arg_tys                               `thenUs` \ arg_vars ->
 770     thing_inside (args ++ map StgVarArg arg_vars) final_res_ty  `thenUs` \ body ->
 771     returnUs (StgLam ty arg_vars body)
 772   where
 773     fn_arity            = idArity fn
 774     excess_arity        = fn_arity - length args
 775     (arg_tys, res_ty)   = splitRepFunTys ty
 776     extra_arg_tys       = take excess_arity arg_tys
 777     final_res_ty        = mkFunTys (drop excess_arity arg_tys) res_ty
 778 \end{code}
 779
 780 \begin{code}
 781 -- Stg doesn't have a lambda *expression*
 782 deStgLam (StgLam ty bndrs body)
 783         -- Try for eta reduction
 784   = ASSERT( not (null bndrs) )
 785     case eta body of
 786         Just e  ->      -- Eta succeeded
 787                     returnUs e
 788
 789         Nothing ->      -- Eta failed, so let-bind the lambda
 790                     newStgVar ty                `thenUs` \ fn ->
 791                     returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
 792   where
 793     lam_closure = StgRhsClosure noCCS
 794                                 stgArgOcc
 795                                 noSRT
 796                                 bOGUS_FVs
 797                                 ReEntrant       -- binders is non-empty
 798                                 bndrs
 799                                 body
 800
 801     eta (StgApp f args)
 802         | n_remaining >= 0 &&
 803           and (zipWith ok bndrs last_args) &&
 804           notInExpr bndrs remaining_expr
 805         = Just remaining_expr
 806         where
 807           remaining_expr = StgApp f remaining_args
 808           (remaining_args, last_args) = splitAt n_remaining args
 809           n_remaining = length args - length bndrs
 810
 811     eta (StgLet bind@(StgNonRec b r) body)
 812         | notInRhs bndrs r = case eta body of
 813                                 Just e -> Just (StgLet bind e)
 814                                 Nothing -> Nothing
 815
 816     eta _ = Nothing
 817
 818     ok bndr (StgVarArg arg) = bndr == arg
 819     ok bndr other           = False
 820
 821 deStgLam expr = returnUs expr
 822
 823
 824 --------------------------------------------------
 825 notInExpr :: [Id] -> StgExpr -> Bool
 826 notInExpr vs (StgApp f args)               = notInId vs f && notInArgs vs args
 827 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
 828 notInExpr vs other                         = False      -- Safe
 829
 830 notInRhs :: [Id] -> StgRhs -> Bool
 831 notInRhs vs (StgRhsCon _ _ args)             = notInArgs vs args
 832 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
 833         -- Conservative: we could delete the binders from vs, but
 834         -- cloning means this will never help
 835
 836 notInArgs :: [Id] -> [StgArg] -> Bool
 837 notInArgs vs args = all ok args
 838                   where
 839                     ok (StgVarArg v) = notInId vs v
 840                     ok (StgLitArg l) = True
 841
 842 notInId :: [Id] -> Id -> Bool
 843 notInId vs v = not (v `elem` vs)
 844
 845
 846
 847 mkStgBinds :: [StgFloatBind]
 848            -> StgExpr           -- *Can* be a StgLam
 849            -> UniqSM StgExpr    -- *Can* be a StgLam
 850
 851 mkStgBinds []     body = returnUs body
 852 mkStgBinds (b:bs) body
 853   = deStgLam body               `thenUs` \ body' ->
 854     go (b:bs) body'
 855   where
 856     go []     body = returnUs body
 857     go (b:bs) body = go bs body         `thenUs` \ body' ->
 858                      mkStgBind  b body'
 859
 860 -- The 'body' arg of mkStgBind can't be a StgLam
 861 mkStgBind NoBindF    body = returnUs body
 862 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 863
 864 mkStgBind (NonRecF bndr rhs dem floats) body
 865 #ifdef DEBUG
 866         -- We shouldn't get let or case of the form v=w
 867   = case rhs of
 868         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 869                        (mk_stg_let bndr rhs dem floats body)
 870         other       ->  mk_stg_let bndr rhs dem floats body
 871
 872 mk_stg_let bndr rhs dem floats body
 873 #endif
 874   | isUnLiftedType bndr_rep_ty                  -- Use a case/PrimAlts
 875   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 876     mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body))     `thenUs` \ expr' ->
 877     mkStgBinds floats expr'
 878
 879   | is_whnf
 880   = if is_strict then
 881         -- Strict let with WHNF rhs
 882         mkStgBinds floats $
 883         StgLet (StgNonRec bndr (exprToRhs dem NotTop rhs)) body
 884     else
 885         -- Lazy let with WHNF rhs; float until we find a strict binding
 886         let
 887             (floats_out, floats_in) = splitFloats floats
 888         in
 889         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 890         mkStgBinds floats_out $
 891         StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body
 892
 893   | otherwise   -- Not WHNF
 894   = if is_strict then
 895         -- Strict let with non-WHNF rhs
 896         mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body))  `thenUs` \ expr' ->
 897         mkStgBinds floats expr'
 898     else
 899         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 900         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 901         returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body)
 902
 903   where
 904     bndr_rep_ty = repType (idType bndr)
 905     is_strict   = isStrictDem dem
 906     is_whnf     = case rhs of
 907                     StgConApp _ _ -> True
 908                     StgLam _ _ _  -> True
 909                     other         -> False
 910
 911 -- Split at the first strict binding
 912 splitFloats fs@(NonRecF _ _ dem _ : _)
 913   | isStrictDem dem = ([], fs)
 914
 915 splitFloats (f : fs) = case splitFloats fs of
 916                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 917
 918 splitFloats [] = ([], [])
 919 \end{code}
 920
 921
 922 Making an STG case
 923 ~~~~~~~~~~~~~~~~~~
 924
 925 First, two special cases.  We mangle cases involving
 926                 par# and seq#
 927 inthe scrutinee.
 928
 929 Up to this point, seq# will appear like this:
 930
 931           case seq# e of
 932                 0# -> seqError#
 933                 _  -> <stuff>
 934
 935 This code comes from an unfolding for 'seq' in Prelude.hs.
 936 The 0# branch is purely to bamboozle the strictness analyser.
 937 For example, if <stuff> is strict in x, and there was no seqError#
 938 branch, the strictness analyser would conclude that the whole expression
 939 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
 940
 941 Now that the evaluation order is safe, we translate this into
 942
 943           case e of
 944                 _ -> ...
 945
 946 This used to be done in the post-simplification phase, but we need
 947 unfoldings involving seq# to appear unmangled in the interface file,
 948 hence we do this mangling here.
 949
 950 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
 951 up like this:
 952
 953         case par# e of
 954           0# -> rhs
 955           _  -> parError#
 956
 957
 958     ==>
 959         case par# e of
 960           _ -> rhs
 961
 962 fork# isn't handled like this - it's an explicit IO operation now.
 963 The reason is that fork# returns a ThreadId#, which gets in the
 964 way of the above scheme.  And anyway, IO is the only guaranteed
 965 way to enforce ordering  --SDM.
 966
 967
 968 \begin{code}
 969 -- Discard alernatives in case (par# ..) of
 970 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
 971           (StgPrimAlts tycon _ deflt@(StgBindDefault _))
 972   = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
 973
 974 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
 975           (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
 976   = mkStgCase scrut_expr new_bndr new_alts
 977   where
 978     new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
 979              | otherwise               = mkStgAlgAlts scrut_ty [] deflt
 980     scrut_ty = stgArgType scrut
 981     new_bndr = setIdType bndr scrut_ty
 982         -- NB:  SeqOp :: forall a. a -> Int#
 983         -- So bndr has type Int#
 984         -- But now we are going to scrutinise the SeqOp's argument directly,
 985         -- so we must change the type of the case binder to match that
 986         -- of the argument expression e.
 987
 988     scrut_expr = case scrut of
 989                    StgVarArg v -> StgApp v []
 990                    -- Others should not happen because
 991                    -- seq of a value should have disappeared
 992                    StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
 993
 994 mkStgCase scrut bndr alts
 995   = deStgLam scrut      `thenUs` \ scrut' ->
 996         -- It is (just) possible to get a lambda as a srutinee here
 997         -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
 998         -- gives:       case ...Bool == Int->Int... of
 999         --                 True -> case coerce Bool (\x -> + 1 x) of
1000         --                              True -> ...
1001         --                              False -> ...
1002         --                 False -> ...
1003         -- The True branch of the outer case will never happen, of course.
1004
1005     returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)
1006 \end{code}