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