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,
  24                           externallyVisibleId, setIdUnique, idName, getIdDemandInfo
  25                         )
  26 import Var              ( modifyIdInfo )
  27 import IdInfo           ( setDemandInfo )
  28 import DataCon          ( DataCon, dataConName, dataConId )
  29 import Name             ( Name, nameModule, isLocallyDefinedName )
  30 import Module           ( isDynamicModule )
  31 import Const            ( Con(..), Literal, isLitLitLit )
  32 import VarEnv
  33 import Const            ( Con(..), isWHNFCon, Literal(..) )
  34 import PrimOp           ( PrimOp(..) )
  35 import Type             ( isUnLiftedType, isUnboxedTupleType, Type )
  36 import TysPrim          ( intPrimTy )
  37 import Demand
  38 import Unique           ( Unique, Uniquable(..) )
  39 import UniqSupply       -- all of it, really
  40 import Outputable
  41 \end{code}
  42
  43
  44         ***************  OVERVIEW   *********************
  45
  46
  47 The business of this pass is to convert Core to Stg.  On the way:
  48
  49 * We discard type lambdas and applications. In so doing we discard
  50   "trivial" bindings such as
  51         x = y t1 t2
  52   where t1, t2 are types
  53
  54 * We don't pin on correct arities any more, because they can be mucked up
  55   by the lambda lifter.  In particular, the lambda lifter can take a local
  56   letrec-bound variable and make it a lambda argument, which shouldn't have
  57   an arity.  So SetStgVarInfo sets arities now.
  58
  59 * We do *not* pin on the correct free/live var info; that's done later.
  60   Instead we use bOGUS_LVS and _FVS as a placeholder.
  61
  62 [Quite a bit of stuff that used to be here has moved
  63  to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
  64
  65
  66 %************************************************************************
  67 %*                                                                      *
  68 \subsection[coreToStg-programs]{Converting a core program and core bindings}
  69 %*                                                                      *
  70 %************************************************************************
  71
  72 March 98: We keep a small environment to give all locally bound
  73 Names new unique ids, since the code generator assumes that binders
  74 are unique across a module. (Simplifier doesn't maintain this
  75 invariant any longer.)
  76
  77 \begin{code}
  78 type StgEnv = IdEnv Id
  79
  80 data StgFloatBind
  81    = LetBind Id StgExpr
  82    | CaseBind Id StgExpr
  83 \end{code}
  84
  85 No free/live variable information is pinned on in this pass; it's added
  86 later.  For this pass
  87 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
  88
  89 \begin{code}
  90 bOGUS_LVs :: StgLiveVars
  91 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
  92
  93 bOGUS_FVs :: [Id]
  94 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
  95 \end{code}
  96
  97 \begin{code}
  98 topCoreBindsToStg :: UniqSupply -- name supply
  99                   -> [CoreBind] -- input
 100                   -> [StgBinding]       -- output
 101
 102 topCoreBindsToStg us core_binds
 103   = initUs us (coreBindsToStg emptyVarEnv core_binds)
 104   where
 105     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 106
 107     coreBindsToStg env [] = returnUs []
 108     coreBindsToStg env (b:bs)
 109       = coreBindToStg  env b            `thenUs` \ (new_b, new_env) ->
 110         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 111         returnUs (new_b ++ new_bs)
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection[coreToStg-binds]{Converting bindings}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 coreBindToStg :: StgEnv
 122               -> CoreBind
 123               -> UniqSM ([StgBinding],  -- Empty or singleton
 124                          StgEnv)        -- Floats
 125
 126 coreBindToStg env (NonRec binder rhs)
 127   = coreRhsToStg env rhs        `thenUs` \ stg_rhs ->
 128     newLocalId env binder       `thenUs` \ (new_env, new_binder) ->
 129     returnUs ([StgNonRec new_binder stg_rhs], new_env)
 130
 131 coreBindToStg env (Rec pairs)
 132   = newLocalIds env binders             `thenUs` \ (env', binders') ->
 133     mapUs (coreRhsToStg env') rhss      `thenUs` \ stg_rhss ->
 134     returnUs ([StgRec (binders' `zip` stg_rhss)], env')
 135   where
 136     (binders, rhss) = unzip pairs
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection[coreToStg-rhss]{Converting right hand sides}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 \begin{code}
 147 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
 148
 149 coreRhsToStg env core_rhs
 150   = coreExprToStg env core_rhs  `thenUs` \ stg_expr ->
 151     returnUs (exprToRhs stg_expr)
 152
 153 exprToRhs (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
 154   | var1 == var2
 155   = rhs
 156         -- This curious stuff is to unravel what a lambda turns into
 157         -- We have to do it this way, rather than spot a lambda in the
 158         -- incoming rhs.  Why?  Because trivial bindings might conceal
 159         -- what the rhs is actually like.
 160
 161 {-
 162   We reject the following candidates for 'static constructor'dom:
 163
 164     - any dcon that takes a lit-lit as an arg.
 165     - [Win32 DLLs only]: any dcon that is (or takes as arg)
 166       that's living in a DLL.
 167
 168   These constraints are necessary to ensure that the code
 169   generated in the end for the static constructors, which
 170   live in the data segment, remain valid - i.e., it has to
 171   be constant. For obvious reasons, that's hard to guarantee
 172   with lit-lits. The second case of a constructor referring
 173   to static closures hiding out in some DLL is an artifact
 174   of the way Win32 DLLs handle global DLL variables. A (data)
 175   symbol exported from a DLL  has to be accessed through a
 176   level of indirection at the site of use, so whereas
 177
 178      extern StgClosure y_closure;
 179      extern StgClosure z_closure;
 180      x = { ..., &y_closure, &z_closure };
 181
 182   is legal when the symbols are in scope at link-time, it is
 183   not when y_closure is in a DLL. So, any potential static
 184   closures that refers to stuff that's residing in a DLL
 185   will be put in an (updateable) thunk instead.
 186
 187   An alternative strategy is to support the generation of
 188   constructors (ala C++ static class constructors) which will
 189   then be run at load time to fix up static closures.
 190 -}
 191 exprToRhs (StgCon (DataCon con) args _)
 192   | not is_dynamic  &&
 193     all  (not.is_lit_lit) args  = StgRhsCon noCCS con args
 194  where
 195   is_dynamic = isDynCon con || any (isDynArg) args
 196
 197   is_lit_lit (StgVarArg _) = False
 198   is_lit_lit (StgConArg x) =
 199      case x of
 200        Literal l -> isLitLitLit l
 201        _         -> False
 202
 203 exprToRhs expr
 204         = StgRhsClosure noCCS           -- No cost centre (ToDo?)
 205                         stgArgOcc       -- safe
 206                         noSRT           -- figure out later
 207                         bOGUS_FVs
 208
 209                         Updatable       -- Be pessimistic
 210                         []
 211                         expr
 212
 213 isDynCon :: DataCon -> Bool
 214 isDynCon con = isDynName (dataConName con)
 215
 216 isDynArg :: StgArg -> Bool
 217 isDynArg (StgVarArg v)   = isDynName (idName v)
 218 isDynArg (StgConArg con) =
 219   case con of
 220     DataCon dc -> isDynCon dc
 221     Literal l  -> isLitLitLit l
 222     _          -> False
 223
 224 isDynName :: Name -> Bool
 225 isDynName nm =
 226       not (isLocallyDefinedName nm) &&
 227       isDynamicModule (nameModule nm)
 228
 229
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection[coreToStg-atoms{Converting atoms}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 \begin{code}
 240 coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([StgFloatBind], [StgArg])
 241
 242 coreArgsToStg env []
 243   = returnUs ([], [])
 244
 245 coreArgsToStg env (Type ty : as)        -- Discard type arguments
 246   = coreArgsToStg env as
 247
 248 coreArgsToStg env (a:as)
 249   = coreArgToStg env a          `thenUs` \ (bs1, a') ->
 250     coreArgsToStg env as        `thenUs` \ (bs2, as') ->
 251     returnUs (bs1 ++ bs2, a' : as')
 252
 253 -- This is where we arrange that a non-trivial argument is let-bound
 254
 255 coreArgToStg :: StgEnv -> CoreArg -> UniqSM ([StgFloatBind], StgArg)
 256
 257 coreArgToStg env arg
 258   = coreExprToStgFloat env arg  `thenUs` \ (binds, arg') ->
 259     case (binds, arg') of
 260         ([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
 261         ([], StgApp v [])                     -> returnUs ([], StgVarArg v)
 262
 263         -- A non-trivial argument: we must let (or case-bind)
 264         -- We don't do the case part here... we leave that to mkStgBinds
 265
 266         -- Further complication: if we're converting this binding into
 267         -- a case,  then try to avoid generating any case-of-case
 268         -- expressions by pulling out the floats.
 269         (_, other) ->
 270                  newStgVar ty   `thenUs` \ v ->
 271                  if isUnLiftedType ty
 272                    then returnUs (binds ++ [CaseBind v arg'], StgVarArg v)
 273                    else returnUs ([LetBind v (mkStgBinds binds arg')], StgVarArg v)
 274           where
 275                 ty = coreExprType arg
 276
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection[coreToStg-exprs]{Converting core expressions}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 \begin{code}
 287 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
 288
 289 coreExprToStg env (Var var)
 290   = returnUs (StgApp (stgLookup env var) [])
 291
 292 \end{code}
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 \begin{code}
 301 coreExprToStg env expr@(Lam _ _)
 302   = let
 303         (binders, body) = collectBinders expr
 304         id_binders      = filter isId binders
 305     in
 306     newLocalIds env id_binders          `thenUs` \ (env', binders') ->
 307     coreExprToStg env' body             `thenUs` \ stg_body ->
 308
 309     if null id_binders then -- it was all type/usage binders; tossed
 310         returnUs stg_body
 311     else
 312     case stg_body of
 313
 314       -- if the body reduced to a lambda too...
 315       (StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body))
 316               (StgApp var' []))
 317        | var == var' ->
 318         returnUs (StgLet (StgNonRec var
 319                             (StgRhsClosure noCCS
 320                                 stgArgOcc
 321                                 noSRT
 322                                 bOGUS_FVs
 323                                 ReEntrant
 324                                 (binders' ++ args)
 325                                 body))
 326                 (StgApp var []))
 327
 328       other ->
 329
 330         -- We must let-bind the lambda
 331         newStgVar (coreExprType expr)   `thenUs` \ var ->
 332         returnUs
 333           (StgLet (StgNonRec var (StgRhsClosure noCCS
 334                                   stgArgOcc
 335                                   noSRT
 336                                   bOGUS_FVs
 337                                   ReEntrant     -- binders is non-empty
 338                                   binders'
 339                                   stg_body))
 340            (StgApp var []))
 341 \end{code}
 342
 343 %************************************************************************
 344 %*                                                                      *
 345 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 346 %*                                                                      *
 347 %************************************************************************
 348
 349 \begin{code}
 350 coreExprToStg env (Let bind body)
 351   = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env) ->
 352     coreExprToStg new_env body   `thenUs` \ stg_body ->
 353     returnUs (foldr StgLet stg_body stg_binds)
 354 \end{code}
 355
 356
 357 %************************************************************************
 358 %*                                                                      *
 359 \subsubsection[coreToStg-scc]{SCC expressions}
 360 %*                                                                      *
 361 %************************************************************************
 362
 363 Covert core @scc@ expression directly to STG @scc@ expression.
 364 \begin{code}
 365 coreExprToStg env (Note (SCC cc) expr)
 366   = coreExprToStg env expr   `thenUs` \ stg_expr ->
 367     returnUs (StgSCC cc stg_expr)
 368 \end{code}
 369
 370 \begin{code}
 371 coreExprToStg env (Note other_note expr) = coreExprToStg env expr
 372 \end{code}
 373
 374 The rest are handled by coreExprStgFloat.
 375
 376 \begin{code}
 377 coreExprToStg env expr
 378   = coreExprToStgFloat env expr  `thenUs` \ (binds,stg_expr) ->
 379     returnUs (mkStgBinds binds stg_expr)
 380 \end{code}
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsubsection[coreToStg-applications]{Applications}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 \begin{code}
 389 coreExprToStgFloat env expr@(App _ _)
 390   = let
 391         (fun,args)    = collect_args expr []
 392     in
 393     coreArgsToStg env args              `thenUs` \ (binds, stg_args) ->
 394
 395         -- Now deal with the function
 396     case (fun, stg_args) of
 397       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 398                                 -- there are no arguments.
 399                             returnUs (binds,
 400                                    StgApp (stgLookup env fun_id) stg_args)
 401
 402       (non_var_fun, []) ->      -- No value args, so recurse into the function
 403                             ASSERT( null binds )
 404                             coreExprToStg env non_var_fun `thenUs` \e ->
 405                             returnUs ([], e)
 406
 407       other ->  -- A non-variable applied to things; better let-bind it.
 408                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 409                 coreExprToStg env fun           `thenUs` \ (stg_fun) ->
 410                 let
 411                    fun_rhs = StgRhsClosure noCCS    -- No cost centre (ToDo?)
 412                                            stgArgOcc
 413                                            noSRT
 414                                            bOGUS_FVs
 415                                            SingleEntry  -- Only entered once
 416                                            []
 417                                            stg_fun
 418                 in
 419                 returnUs (binds,
 420                           StgLet (StgNonRec fun_id fun_rhs) $
 421                           StgApp fun_id stg_args)
 422   where
 423         -- Collect arguments
 424     collect_args (App fun arg)            args = collect_args fun (arg:args)
 425     collect_args (Note (Coerce _ _) expr) args = collect_args expr args
 426     collect_args (Note InlineCall   expr) args = collect_args expr args
 427     collect_args fun                      args = (fun, args)
 428 \end{code}
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsubsection[coreToStg-con]{Constructors}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436 \begin{code}
 437 coreExprToStgFloat env expr@(Con (PrimOp (CCallOp (Right _) a b c)) args)
 438   = getUniqueUs                 `thenUs` \ u ->
 439     coreArgsToStg env args      `thenUs` \ (binds, stg_atoms) ->
 440     let con' = PrimOp (CCallOp (Right u) a b c) in
 441     returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
 442
 443 coreExprToStgFloat env expr@(Con con args)
 444   = coreArgsToStg env args      `thenUs` \ (binds, stg_atoms) ->
 445     returnUs (binds, StgCon con stg_atoms (coreExprType expr))
 446 \end{code}
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsubsection[coreToStg-cases]{Case expressions}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 \begin{code}
 455 coreExprToStgFloat env expr@(Case scrut bndr alts)
 456   = coreExprToStgFloat env scrut                `thenUs` \ (binds, scrut') ->
 457     newEvaldLocalId env bndr                    `thenUs` \ (env', bndr') ->
 458     alts_to_stg env' (findDefault alts)         `thenUs` \ alts' ->
 459     returnUs (binds, mkStgCase scrut' bndr' alts')
 460   where
 461     scrut_ty  = idType bndr
 462     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
 463
 464     alts_to_stg env (alts, deflt)
 465       | prim_case
 466       = default_to_stg env deflt                `thenUs` \ deflt' ->
 467         mapUs (prim_alt_to_stg env) alts        `thenUs` \ alts' ->
 468         returnUs (StgPrimAlts scrut_ty alts' deflt')
 469
 470       | otherwise
 471       = default_to_stg env deflt                `thenUs` \ deflt' ->
 472         mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
 473         returnUs (StgAlgAlts scrut_ty alts' deflt')
 474
 475     alg_alt_to_stg env (DataCon con, bs, rhs)
 476           = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 477             returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 478                 -- NB the filter isId.  Some of the binders may be
 479                 -- existential type variables, which STG doesn't care about
 480
 481     prim_alt_to_stg env (Literal lit, args, rhs)
 482           = ASSERT( null args )
 483             coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 484             returnUs (lit, stg_rhs)
 485
 486     default_to_stg env Nothing
 487       = returnUs StgNoDefault
 488
 489     default_to_stg env (Just rhs)
 490       = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 491         returnUs (StgBindDefault stg_rhs)
 492                 -- The binder is used for prim cases and not otherwise
 493                 -- (hack for old code gen)
 494 \end{code}
 495
 496 \begin{code}
 497 coreExprToStgFloat env expr
 498   = coreExprToStg env expr `thenUs` \stg_expr ->
 499     returnUs ([], stg_expr)
 500 \end{code}
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 There's not anything interesting we can ASSERT about \tr{var} if it
 509 isn't in the StgEnv. (WDP 94/06)
 510
 511 \begin{code}
 512 stgLookup :: StgEnv -> Id -> Id
 513 stgLookup env var = case (lookupVarEnv env var) of
 514                       Nothing  -> var
 515                       Just var -> var
 516 \end{code}
 517
 518 Invent a fresh @Id@:
 519 \begin{code}
 520 newStgVar :: Type -> UniqSM Id
 521 newStgVar ty
 522  = getUniqueUs                  `thenUs` \ uniq ->
 523    returnUs (mkSysLocal SLIT("stg") uniq ty)
 524 \end{code}
 525
 526 \begin{code}
 527 newLocalId env id
 528   | externallyVisibleId id
 529   = returnUs (env, id)
 530
 531   | otherwise
 532   =     -- Local binder, give it a new unique Id.
 533     getUniqueUs                 `thenUs` \ uniq ->
 534     let
 535       id'     = setIdUnique id uniq
 536       new_env = extendVarEnv env id id'
 537     in
 538     returnUs (new_env, id')
 539
 540 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
 541 -- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
 542 -- some redundant cases (c.f. dataToTag# above).
 543
 544 newEvaldLocalId env id
 545   = getUniqueUs                 `thenUs` \ uniq ->
 546     let
 547       id'     = setIdUnique id uniq `modifyIdInfo` setDemandInfo wwStrict
 548       new_env = extendVarEnv env id id'
 549     in
 550     returnUs (new_env, id')
 551
 552 newLocalIds :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
 553 newLocalIds env []
 554   = returnUs (env, [])
 555 newLocalIds env (b:bs)
 556   = newLocalId env b    `thenUs` \ (env', b') ->
 557     newLocalIds env' bs `thenUs` \ (env'', bs') ->
 558     returnUs (env'', b':bs')
 559 \end{code}
 560
 561
 562 \begin{code}
 563 mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr
 564 mkStgBinds binds body = foldr mkStgBind body binds
 565
 566 mkStgBind (CaseBind bndr rhs) body
 567   | isUnLiftedType bndr_ty
 568   = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
 569   | otherwise
 570   = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
 571   where
 572     bndr_ty = idType bndr
 573
 574 mkStgBind (LetBind bndr rhs) body
 575   | isUnboxedTupleType bndr_ty
 576   = panic "mkStgBinds: unboxed tuple"
 577   | isUnLiftedType bndr_ty
 578   = mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
 579
 580   | otherwise
 581   = StgLet (StgNonRec bndr (exprToRhs rhs)) body
 582   where
 583     bndr_ty = idType bndr
 584
 585 mkStgCase (StgLet bind expr) bndr alts
 586   = StgLet bind (mkStgCase expr bndr alts)
 587 mkStgCase scrut bndr alts
 588   = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
 589 \end{code}