ghc/compiler/stgSyn/CoreToStg.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 CostCentre       ( noCostCentre )
  22 import MkId             ( mkSysLocal )
  23 import Id               ( externallyVisibleId, mkIdWithNewUniq,
  24                           nullIdEnv, addOneToIdEnv, lookupIdEnv,
  25                           IdEnv, Id
  26                         )
  27 import SrcLoc           ( noSrcLoc )
  28 import Type             ( splitAlgTyConApp, Type )
  29 import UniqSupply       ( UniqSupply, UniqSM,
  30                           returnUs, thenUs, initUs,
  31                           mapUs, getUnique
  32                         )
  33 import PrimOp           ( PrimOp(..) )
  34
  35 import Outputable       ( panic )
  36
  37 isLeakFreeType x y = False -- safe option; ToDo
  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 Because we're going to come across ``boring'' bindings like
  70 \tr{let x = /\ tyvars -> y in ...}, we want to keep a small
  71 environment, so we can just replace all occurrences of \tr{x}
  72 with \tr{y}.
  73
  74 March 98: We also use this environment to give all locally bound
  75 Names new unique ids, since the code generator assumes that binders
  76 are unique across a module. (Simplifier doesn't maintain this
  77 invariant any longer.)
  78
  79 \begin{code}
  80 type StgEnv = IdEnv StgArg
  81 \end{code}
  82
  83 No free/live variable information is pinned on in this pass; it's added
  84 later.  For this pass
  85 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
  86
  87 \begin{code}
  88 bOGUS_LVs :: StgLiveVars
  89 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
  90
  91 bOGUS_FVs :: [Id]
  92 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
  93 \end{code}
  94
  95 \begin{code}
  96 topCoreBindsToStg :: UniqSupply -- name supply
  97                   -> [CoreBinding]      -- input
  98                   -> [StgBinding]       -- output
  99
 100 topCoreBindsToStg us core_binds
 101   = initUs us (coreBindsToStg nullIdEnv core_binds)
 102   where
 103     coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
 104
 105     coreBindsToStg env [] = returnUs []
 106     coreBindsToStg env (b:bs)
 107       = coreBindToStg  env b            `thenUs` \ (new_b, new_env) ->
 108         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 109         returnUs (new_b ++ new_bs)
 110 \end{code}
 111
 112 %************************************************************************
 113 %*                                                                      *
 114 \subsection[coreToStg-binds]{Converting bindings}
 115 %*                                                                      *
 116 %************************************************************************
 117
 118 \begin{code}
 119 coreBindToStg :: StgEnv
 120               -> CoreBinding
 121               -> UniqSM ([StgBinding],  -- Empty or singleton
 122                          StgEnv)        -- Floats
 123
 124 coreBindToStg env (NonRec binder rhs)
 125   = coreRhsToStg env rhs        `thenUs` \ stg_rhs ->
 126     let
 127         -- Binds to return if RHS is trivial
 128         triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs]    -- Retain it
 129                    | otherwise                  = []                            -- Discard it
 130     in
 131     case stg_rhs of
 132       StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
 133                 -- Trivial RHS, so augment envt, and ditch the binding
 134                 returnUs (triv_binds, new_env)
 135            where
 136                 new_env = addOneToIdEnv env binder atom
 137
 138       StgRhsCon cc con_id [] ->
 139                 -- Trivial RHS, so augment envt, and ditch the binding
 140                 returnUs (triv_binds, new_env)
 141            where
 142                 new_env = addOneToIdEnv env binder (StgConArg con_id)
 143
 144       other ->    -- Non-trivial RHS
 145            mkUniqueBinder env binder   `thenUs` \ (new_env, new_binder) ->
 146            returnUs ([StgNonRec new_binder stg_rhs], new_env)
 147     where
 148      mkUniqueBinder env binder
 149        | externallyVisibleId binder = returnUs (env, binder)
 150        | otherwise =
 151            -- local binder, give it a new unique Id.
 152            newUniqueLocalId binder   `thenUs` \ binder' ->
 153            let
 154              new_env = addOneToIdEnv env binder (StgVarArg binder')
 155            in
 156            returnUs (new_env, binder')
 157
 158
 159 coreBindToStg env (Rec pairs)
 160   = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
 161     -- (possibly ToDo)
 162     let
 163         (binders, rhss) = unzip pairs
 164     in
 165     newLocalIds env True{-maybe externally visible-} binders   `thenUs` \ (binders', env') ->
 166     mapUs (coreRhsToStg env') rhss                             `thenUs` \ stg_rhss ->
 167     returnUs ([StgRec (binders' `zip` stg_rhss)], env')
 168 \end{code}
 169
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection[coreToStg-rhss]{Converting right hand sides}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
 179
 180 coreRhsToStg env core_rhs
 181   = coreExprToStg env core_rhs  `thenUs` \ stg_expr ->
 182
 183     let stg_rhs = case stg_expr of
 184                     StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
 185                         | var1 == var2 -> rhs
 186                         -- This curious stuff is to unravel what a lambda turns into
 187                         -- We have to do it this way, rather than spot a lambda in the
 188                         -- incoming rhs.  Why?  Because trivial bindings might conceal
 189                         -- what the rhs is actually like.
 190
 191                     StgCon con args _ -> StgRhsCon noCostCentre con args
 192
 193                     other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 194                                            stgArgOcc    -- safe
 195                                            bOGUS_FVs
 196                                            Updatable    -- Be pessimistic
 197                                            []
 198                                            stg_expr
 199     in
 200     returnUs stg_rhs
 201 \end{code}
 202
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection[coreToStg-atoms{Converting atoms}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
 212
 213 coreArgsToStg env [] = ([], [])
 214 coreArgsToStg env (a:as)
 215   = case a of
 216         TyArg    t -> (t:trest, vrest)
 217         VarArg   v -> (trest,   stgLookup env v : vrest)
 218         LitArg   l -> (trest,   StgLitArg l     : vrest)
 219   where
 220     (trest,vrest) = coreArgsToStg env as
 221 \end{code}
 222
 223
 224 %************************************************************************
 225 %*                                                                      *
 226 \subsection[coreToStg-exprs]{Converting core expressions}
 227 %*                                                                      *
 228 %************************************************************************
 229
 230 \begin{code}
 231 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
 232
 233 coreExprToStg env (Lit lit)
 234   = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
 235
 236 coreExprToStg env (Var var)
 237   = returnUs (mk_app (stgLookup env var) [])
 238
 239 coreExprToStg env (Con con args)
 240   = let
 241         (types, stg_atoms) = coreArgsToStg env args
 242     in
 243     returnUs (StgCon con stg_atoms bOGUS_LVs)
 244
 245 coreExprToStg env (Prim op args)
 246   = mkPrimOpUnique op `thenUs` \ op' ->
 247     let
 248         (types, stg_atoms) = coreArgsToStg env args
 249     in
 250     returnUs (StgPrim op' stg_atoms bOGUS_LVs)
 251    where
 252     mkPrimOpUnique (CCallOp (Right _) a b c d e) =
 253        getUnique `thenUs` \ u ->
 254        returnUs (CCallOp (Right u) a b c d e)
 255     mkPrimOpUnique op = returnUs op
 256
 257 \end{code}
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 \begin{code}
 266 coreExprToStg env expr@(Lam _ _)
 267   = let
 268         (_, binders, body) = collectBinders expr
 269     in
 270     newLocalIds env False{-all local-} binders  `thenUs` \ (binders', env') ->
 271     coreExprToStg env' body                     `thenUs` \ stg_body ->
 272
 273     if null binders then -- it was all type/usage binders; tossed
 274         returnUs stg_body
 275     else
 276         newStgVar (coreExprType expr)   `thenUs` \ var ->
 277         returnUs
 278           (StgLet (StgNonRec var
 279                                   (StgRhsClosure noCostCentre
 280                                   stgArgOcc
 281                                   bOGUS_FVs
 282                                   ReEntrant     -- binders is non-empty
 283                                   binders'
 284                                   stg_body))
 285            (StgApp (StgVarArg var) [] bOGUS_LVs))
 286 \end{code}
 287
 288 %************************************************************************
 289 %*                                                                      *
 290 \subsubsection[coreToStg-applications]{Applications}
 291 %*                                                                      *
 292 %************************************************************************
 293
 294 \begin{code}
 295 coreExprToStg env expr@(App _ _)
 296   = let
 297         (fun,args)    = collect_args expr []
 298         (_, stg_args) = coreArgsToStg env args
 299     in
 300         -- Now deal with the function
 301     case (fun, args) of
 302       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 303                                 -- there are no arguments.
 304                             returnUs (mk_app (stgLookup env fun_id) stg_args)
 305
 306       (non_var_fun, []) ->      -- No value args, so recurse into the function
 307                             coreExprToStg env non_var_fun
 308
 309       other ->  -- A non-variable applied to things; better let-bind it.
 310                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 311                 coreExprToStg env fun           `thenUs` \ (stg_fun) ->
 312                 let
 313                    fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 314                                            stgArgOcc
 315                                            bOGUS_FVs
 316                                            SingleEntry  -- Only entered once
 317                                            []
 318                                            stg_fun
 319                 in
 320                 returnUs (StgLet (StgNonRec fun_id fun_rhs)
 321                                  (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
 322   where
 323         -- Collect arguments, discarding type/usage applications
 324     collect_args (App e   (TyArg _))      args = collect_args e   args
 325     collect_args (App fun arg)            args = collect_args fun (arg:args)
 326     collect_args (Note (Coerce _ _) expr) args = collect_args expr args
 327     collect_args (Note InlineCall   expr) args = collect_args expr args
 328     collect_args fun                      args = (fun, args)
 329 \end{code}
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsubsection[coreToStg-cases]{Case expressions}
 334 %*                                                                      *
 335 %************************************************************************
 336
 337
 338 ******* TO DO TO DO: fix what follows
 339
 340 Special case for
 341
 342         case (op x1 ... xn) of
 343           y -> e
 344
 345 where the type of the case scrutinee is a multi-constuctor algebraic type.
 346 Then we simply compile code for
 347
 348         let y = op x1 ... xn
 349         in
 350         e
 351
 352 In this case:
 353
 354         case (op x1 ... xn) of
 355            C a b -> ...
 356            y     -> e
 357
 358 where the type of the case scrutinee is a multi-constuctor algebraic type.
 359 we just bomb out at the moment. It never happens in practice.
 360
 361 **** END OF TO DO TO DO
 362
 363 \begin{code}
 364 coreExprToStg env (Case scrut@(Prim op args) (AlgAlts alts (BindDefault binder rhs)))
 365   = if not (null alts) then
 366         panic "cgCase: case on PrimOp with default *and* alts\n"
 367         -- For now, die if alts are non-empty
 368     else
 369         coreExprToStg env (Let (NonRec binder scrut) rhs)
 370
 371 coreExprToStg env (Case discrim alts)
 372   = coreExprToStg env discrim           `thenUs` \ stg_discrim ->
 373     alts_to_stg discrim alts            `thenUs` \ stg_alts ->
 374     getUnique                           `thenUs` \ uniq ->
 375     returnUs (
 376         StgCase stg_discrim
 377                 bOGUS_LVs
 378                 bOGUS_LVs
 379                 uniq
 380                 stg_alts
 381     )
 382   where
 383     discrim_ty              = coreExprType discrim
 384     (_, discrim_ty_args, _) = splitAlgTyConApp discrim_ty
 385
 386     alts_to_stg discrim (AlgAlts alts deflt)
 387       = default_to_stg discrim deflt            `thenUs` \ stg_deflt ->
 388         mapUs boxed_alt_to_stg alts             `thenUs` \ stg_alts  ->
 389         returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
 390       where
 391         boxed_alt_to_stg (con, bs, rhs)
 392           = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 393             returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 394
 395     alts_to_stg discrim (PrimAlts alts deflt)
 396       = default_to_stg discrim deflt            `thenUs` \ stg_deflt ->
 397         mapUs unboxed_alt_to_stg alts           `thenUs` \ stg_alts  ->
 398         returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
 399       where
 400         unboxed_alt_to_stg (lit, rhs)
 401           = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 402             returnUs (lit, stg_rhs)
 403
 404     default_to_stg discrim NoDefault
 405       = returnUs StgNoDefault
 406
 407     default_to_stg discrim (BindDefault binder rhs)
 408       = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 409         returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
 410 \end{code}
 411
 412 %************************************************************************
 413 %*                                                                      *
 414 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 415 %*                                                                      *
 416 %************************************************************************
 417
 418 \begin{code}
 419 coreExprToStg env (Let bind body)
 420   = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env) ->
 421     coreExprToStg new_env body   `thenUs` \ stg_body ->
 422     returnUs (mkStgLets stg_binds stg_body)
 423 \end{code}
 424
 425
 426 %************************************************************************
 427 %*                                                                      *
 428 \subsubsection[coreToStg-scc]{SCC expressions}
 429 %*                                                                      *
 430 %************************************************************************
 431
 432 Covert core @scc@ expression directly to STG @scc@ expression.
 433 \begin{code}
 434 coreExprToStg env (Note (SCC cc) expr)
 435   = coreExprToStg env expr   `thenUs` \ stg_expr ->
 436     returnUs (StgSCC (coreExprType expr) cc stg_expr)
 437 \end{code}
 438
 439 \begin{code}
 440 coreExprToStg env (Note other_note expr) = coreExprToStg env expr
 441 \end{code}
 442
 443
 444 %************************************************************************
 445 %*                                                                      *
 446 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 447 %*                                                                      *
 448 %************************************************************************
 449
 450 There's not anything interesting we can ASSERT about \tr{var} if it
 451 isn't in the StgEnv. (WDP 94/06)
 452
 453 \begin{code}
 454 stgLookup :: StgEnv -> Id -> StgArg
 455 stgLookup env var = case (lookupIdEnv env var) of
 456                       Nothing   -> StgVarArg var
 457                       Just atom -> atom
 458 \end{code}
 459
 460 Invent a fresh @Id@:
 461 \begin{code}
 462 newStgVar :: Type -> UniqSM Id
 463 newStgVar ty
 464  = getUnique                    `thenUs` \ uniq ->
 465    returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
 466 \end{code}
 467
 468 \begin{code}
 469 newUniqueLocalId :: Id -> UniqSM Id
 470 newUniqueLocalId i =
 471    getUnique                    `thenUs` \ uniq ->
 472    returnUs (mkIdWithNewUniq i uniq)
 473
 474 newLocalIds :: StgEnv -> Bool -> [Id] -> UniqSM ([Id], StgEnv)
 475 newLocalIds env maybe_visible [] = returnUs ([], env)
 476 newLocalIds env maybe_visible (i:is)
 477  | maybe_visible && externallyVisibleId i =
 478      newLocalIds env maybe_visible is `thenUs` \ (is', env') ->
 479      returnUs (i:is', env')
 480  | otherwise             =
 481      newUniqueLocalId i `thenUs` \ i' ->
 482      let
 483       new_env = addOneToIdEnv env i (StgVarArg i')
 484      in
 485      newLocalIds new_env maybe_visible is `thenUs` \ (is', env') ->
 486      returnUs (i':is', env')
 487 \end{code}
 488
 489
 490 \begin{code}
 491 mkStgLets ::   [StgBinding]
 492             -> StgExpr  -- body of let
 493             -> StgExpr
 494
 495 mkStgLets binds body = foldr StgLet body binds
 496
 497 -- mk_app spots an StgCon in a function position,
 498 -- and turns it into an StgCon. See notes with
 499 -- getArgAmode in CgBindery.
 500 mk_app (StgConArg con) args = StgCon con       args bOGUS_LVs
 501 mk_app other_fun       args = StgApp other_fun args bOGUS_LVs
 502 \end{code}