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     (other_alts, maybe_default) = findDefault alts
 658     Just default_rhs            = maybe_default
 659     new_bndr                    = setIdType bndr ty
 660         -- NB:  SeqOp :: forall a. a -> Int#
 661         -- So bndr has type Int#
 662         -- But now we are going to scrutinise the SeqOp's argument directly,
 663         -- so we must change the type of the case binder to match that
 664         -- of the argument expression e.  We can get this type from the argument
 665         -- type of the SeqOp.
 666
 667 coreExprToStgFloat env
 668         (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
 669   | maybeToBool maybe_default
 670   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 671     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 672     coreExprToStg env' default_rhs dem          `thenUs` \ default_rhs' ->
 673     returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs')))
 674   where
 675     (other_alts, maybe_default) = findDefault alts
 676     Just default_rhs            = maybe_default
 677 \end{code}
 678
 679 Now for normal case expressions...
 680
 681 \begin{code}
 682 coreExprToStgFloat env (Case scrut bndr alts) dem
 683   = coreExprToStgFloat env scrut (bdrDem bndr)  `thenUs` \ (binds, scrut') ->
 684     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 685     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 686     returnUs (binds, mkStgCase scrut' bndr' alts')
 687   where
 688     scrut_ty  = idType bndr
 689     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 690
 691     alts_to_stg env (alts, deflt)
 692       | prim_case
 693       = default_to_stg env deflt                `thenUs` \ deflt' ->
 694         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 695         returnUs (mkStgPrimAlts scrut_ty alts' deflt')
 696
 697       | otherwise
 698       = default_to_stg env deflt                `thenUs` \ deflt' ->
 699         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 700         returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 701
 702     alg_alt_to_stg env (DataCon con, bs, rhs)
 703           = newLocalIds NotTopLevel env (filter isId bs)        `thenUs` \ (env', stg_bs) ->
 704             coreExprToStg env' rhs dem                          `thenUs` \ stg_rhs ->
 705             returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
 706                 -- NB the filter isId.  Some of the binders may be
 707                 -- existential type variables, which STG doesn't care about
 708
 709     prim_alt_to_stg env (Literal lit, args, rhs)
 710           = ASSERT( null args )
 711             coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 712             returnUs (lit, stg_rhs)
 713
 714     default_to_stg env Nothing
 715       = returnUs StgNoDefault
 716
 717     default_to_stg env (Just rhs)
 718       = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
 719         returnUs (StgBindDefault stg_rhs)
 720                 -- The binder is used for prim cases and not otherwise
 721                 -- (hack for old code gen)
 722 \end{code}
 723
 724
 725 %************************************************************************
 726 %*                                                                      *
 727 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 728 %*                                                                      *
 729 %************************************************************************
 730
 731 There's not anything interesting we can ASSERT about \tr{var} if it
 732 isn't in the StgEnv. (WDP 94/06)
 733
 734 \begin{code}
 735 stgLookup :: StgEnv -> Id -> Id
 736 stgLookup env var = case (lookupVarEnv env var) of
 737                       Nothing  -> var
 738                       Just var -> var
 739 \end{code}
 740
 741 Invent a fresh @Id@:
 742 \begin{code}
 743 newStgVar :: Type -> UniqSM Id
 744 newStgVar ty
 745  = getUniqueUs                  `thenUs` \ uniq ->
 746    seqType ty                   `seq`
 747    returnUs (mkSysLocal SLIT("stg") uniq ty)
 748 \end{code}
 749
 750 \begin{code}
 751 {-      Now redundant, I believe
 752 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 753 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 754 -- some redundant cases (c.f. dataToTag# above).
 755
 756 newEvaldLocalId env id
 757   = getUniqueUs                 `thenUs` \ uniq ->
 758     let
 759       id'     = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
 760       new_env = extendVarEnv env id id'
 761     in
 762     returnUs (new_env, id')
 763 -}
 764
 765 newEvaldLocalId env id = newLocalId NotTopLevel env id
 766
 767 newLocalId TopLevel env id
 768   -- Don't clone top-level binders.  MkIface relies on their
 769   -- uniques staying the same, so it can snaffle IdInfo off the
 770   -- STG ids to put in interface files.
 771   = let
 772       name = idName id
 773       ty   = idType id
 774     in
 775     name                `seq`
 776     seqType ty          `seq`
 777     returnUs (env, mkVanillaId name ty)
 778
 779
 780 newLocalId NotTopLevel env id
 781   =     -- Local binder, give it a new unique Id.
 782     getUniqueUs                 `thenUs` \ uniq ->
 783     let
 784       name    = idName id
 785       ty      = idType id
 786       new_id  = mkVanillaId (setNameUnique name uniq) ty
 787       new_env = extendVarEnv env id new_id
 788     in
 789     name                `seq`
 790     seqType ty          `seq`
 791     returnUs (new_env, new_id)
 792
 793 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 794 newLocalIds top_lev env []
 795   = returnUs (env, [])
 796 newLocalIds top_lev env (b:bs)
 797   = newLocalId top_lev env b    `thenUs` \ (env', b') ->
 798     newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
 799     returnUs (env'', b':bs')
 800 \end{code}
 801
 802
 803 %************************************************************************
 804 %*                                                                      *
 805 \subsection{Building STG syn}
 806 %*                                                                      *
 807 %************************************************************************
 808
 809 \begin{code}
 810 mkStgAlgAlts  ty alts deflt = seqType ty `seq` StgAlgAlts  ty alts deflt
 811 mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
 812 mkStgCon con args ty        = seqType ty `seq` StgCon con args ty
 813 mkStgLam ty bndrs body      = seqType ty `seq` StgLam ty bndrs body
 814
 815 mkStgApp :: Id -> [StgArg] -> StgExpr
 816 mkStgApp fn args = fn `seq` StgApp fn args
 817         -- Force the lookup
 818 \end{code}
 819
 820 \begin{code}
 821 -- Stg doesn't have a lambda *expression*,
 822 deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
 823 deStgLam expr                   = returnUs expr
 824
 825 mkStgLamExpr ty bndrs body
 826   = ASSERT( not (null bndrs) )
 827     newStgVar ty                `thenUs` \ fn ->
 828     returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn []))
 829   where
 830     lam_closure = StgRhsClosure noCCS
 831                                 stgArgOcc
 832                                 noSRT
 833                                 bOGUS_FVs
 834                                 ReEntrant       -- binders is non-empty
 835                                 bndrs
 836                                 body
 837
 838 mkStgBinds :: [StgFloatBind]
 839            -> StgExpr           -- *Can* be a StgLam
 840            -> UniqSM StgExpr    -- *Can* be a StgLam
 841
 842 mkStgBinds []     body = returnUs body
 843 mkStgBinds (b:bs) body
 844   = deStgLam body               `thenUs` \ body' ->
 845     go (b:bs) body'
 846   where
 847     go []     body = returnUs body
 848     go (b:bs) body = go bs body         `thenUs` \ body' ->
 849                      mkStgBind  b body'
 850
 851 -- The 'body' arg of mkStgBind can't be a StgLam
 852 mkStgBind NoBindF    body = returnUs body
 853 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
 854
 855 mkStgBind (NonRecF bndr rhs dem floats) body
 856 #ifdef DEBUG
 857         -- We shouldn't get let or case of the form v=w
 858   = case rhs of
 859         StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
 860                        (mk_stg_let bndr rhs dem floats body)
 861         other       ->  mk_stg_let bndr rhs dem floats body
 862
 863 mk_stg_let bndr rhs dem floats body
 864 #endif
 865   | isUnLiftedType bndr_rep_ty                  -- Use a case/PrimAlts
 866   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 867     mkStgBinds floats $
 868     mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
 869
 870   | is_whnf
 871   = if is_strict then
 872         -- Strict let with WHNF rhs
 873         mkStgBinds floats $
 874         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
 875     else
 876         -- Lazy let with WHNF rhs; float until we find a strict binding
 877         let
 878             (floats_out, floats_in) = splitFloats floats
 879         in
 880         mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
 881         mkStgBinds floats_out $
 882         StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
 883
 884   | otherwise   -- Not WHNF
 885   = if is_strict then
 886         -- Strict let with non-WHNF rhs
 887         mkStgBinds floats $
 888         mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
 889     else
 890         -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
 891         mkStgBinds floats rhs           `thenUs` \ new_rhs ->
 892         returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
 893
 894   where
 895     bndr_rep_ty = repType (idType bndr)
 896     is_strict   = isStrictDem dem
 897     is_whnf     = case rhs of
 898                     StgCon _ _ _ -> True
 899                     StgLam _ _ _ -> True
 900                     other        -> False
 901
 902 -- Split at the first strict binding
 903 splitFloats fs@(NonRecF _ _ dem _ : _)
 904   | isStrictDem dem = ([], fs)
 905
 906 splitFloats (f : fs) = case splitFloats fs of
 907                              (fs_out, fs_in) -> (f : fs_out, fs_in)
 908
 909 splitFloats [] = ([], [])
 910
 911
 912 mkStgCase scrut bndr alts
 913   = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
 914         -- We should never find
 915         --      case (\x->e) of { ... }
 916         -- The simplifier eliminates such things
 917     StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 918 \end{code}