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