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