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