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