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