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