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