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