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,
  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 \begin{code}
  83 type StgEnv = IdEnv StgArg
  84 \end{code}
  85
  86 No free/live variable information is pinned on in this pass; it's added
  87 later.  For this pass
  88 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
  89
  90 \begin{code}
  91 bOGUS_LVs :: StgLiveVars
  92 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
  93
  94 bOGUS_FVs :: [Id]
  95 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
  96 \end{code}
  97
  98 \begin{code}
  99 topCoreBindsToStg :: UniqSupply -- name supply
 100                   -> [CoreBinding]      -- input
 101                   -> [StgBinding]       -- output
 102
 103 topCoreBindsToStg us core_binds
 104   = initUs us (coreBindsToStg nullIdEnv core_binds)
 105   where
 106     coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
 107
 108     coreBindsToStg env [] = returnUs []
 109     coreBindsToStg env (b:bs)
 110       = coreBindToStg  env b            `thenUs` \ (new_b, new_env) ->
 111         coreBindsToStg new_env bs       `thenUs` \ new_bs ->
 112         returnUs (new_b ++ new_bs)
 113 \end{code}
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection[coreToStg-binds]{Converting bindings}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 coreBindToStg :: StgEnv
 123               -> CoreBinding
 124               -> UniqSM ([StgBinding],  -- Empty or singleton
 125                          StgEnv)        -- Floats
 126
 127 coreBindToStg env (NonRec binder rhs)
 128   = coreRhsToStg env rhs        `thenUs` \ stg_rhs ->
 129     let
 130         -- Binds to return if RHS is trivial
 131         triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs]    -- Retain it
 132                    | otherwise                  = []                            -- Discard it
 133     in
 134     case stg_rhs of
 135       StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
 136                 -- Trivial RHS, so augment envt, and ditch the binding
 137                 returnUs (triv_binds, new_env)
 138            where
 139                 new_env = addOneToIdEnv env binder atom
 140
 141       StgRhsCon cc con_id [] ->
 142                 -- Trivial RHS, so augment envt, and ditch the binding
 143                 returnUs (triv_binds, new_env)
 144            where
 145                 new_env = addOneToIdEnv env binder (StgConArg con_id)
 146
 147       other ->  -- Non-trivial RHS, so don't augment envt
 148                 returnUs ([StgNonRec binder stg_rhs], env)
 149
 150 coreBindToStg env (Rec pairs)
 151   = -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
 152     -- (possibly ToDo)
 153     let
 154         (binders, rhss) = unzip pairs
 155     in
 156     mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
 157     returnUs ([StgRec (binders `zip` stg_rhss)], env)
 158 \end{code}
 159
 160
 161 %************************************************************************
 162 %*                                                                      *
 163 \subsection[coreToStg-rhss]{Converting right hand sides}
 164 %*                                                                      *
 165 %************************************************************************
 166
 167 \begin{code}
 168 coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
 169
 170 coreRhsToStg env core_rhs
 171   = coreExprToStg env core_rhs  `thenUs` \ stg_expr ->
 172
 173     let stg_rhs = case stg_expr of
 174                     StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
 175                         | var1 == var2 -> rhs
 176                         -- This curious stuff is to unravel what a lambda turns into
 177                         -- We have to do it this way, rather than spot a lambda in the
 178                         -- incoming rhs.  Why?  Because trivial bindings might conceal
 179                         -- what the rhs is actually like.
 180
 181                     StgCon con args _ -> StgRhsCon noCostCentre con args
 182
 183                     other -> StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 184                                            stgArgOcc    -- safe
 185                                            bOGUS_FVs
 186                                            Updatable    -- Be pessimistic
 187                                            []
 188                                            stg_expr
 189     in
 190     returnUs stg_rhs
 191 \end{code}
 192
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection[coreToStg-atoms{Converting atoms}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 \begin{code}
 201 coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
 202
 203 coreArgsToStg env [] = ([], [])
 204 coreArgsToStg env (a:as)
 205   = case a of
 206         TyArg    t -> (t:trest, vrest)
 207         VarArg   v -> (trest,   stgLookup env v : vrest)
 208         LitArg   l -> (trest,   StgLitArg l     : vrest)
 209   where
 210     (trest,vrest) = coreArgsToStg env as
 211 \end{code}
 212
 213
 214 %************************************************************************
 215 %*                                                                      *
 216 \subsection[coreToStg-exprs]{Converting core expressions}
 217 %*                                                                      *
 218 %************************************************************************
 219
 220 \begin{code}
 221 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
 222
 223 coreExprToStg env (Lit lit)
 224   = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
 225
 226 coreExprToStg env (Var var)
 227   = returnUs (mk_app (stgLookup env var) [])
 228
 229 coreExprToStg env (Con con args)
 230   = let
 231         (types, stg_atoms) = coreArgsToStg env args
 232     in
 233     returnUs (StgCon con stg_atoms bOGUS_LVs)
 234
 235 coreExprToStg env (Prim op args)
 236   = let
 237         (types, stg_atoms) = coreArgsToStg env args
 238     in
 239     returnUs (StgPrim op stg_atoms bOGUS_LVs)
 240 \end{code}
 241
 242 %************************************************************************
 243 %*                                                                      *
 244 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 \begin{code}
 249 coreExprToStg env expr@(Lam _ _)
 250   = let
 251         (_, binders, body) = collectBinders expr
 252     in
 253     coreExprToStg env body              `thenUs` \ stg_body ->
 254
 255     if null binders then -- it was all type/usage binders; tossed
 256         returnUs stg_body
 257     else
 258         newStgVar (coreExprType expr)   `thenUs` \ var ->
 259         returnUs
 260           (StgLet (StgNonRec var
 261                                   (StgRhsClosure noCostCentre
 262                                   stgArgOcc
 263                                   bOGUS_FVs
 264                                   ReEntrant     -- binders is non-empty
 265                                   binders
 266                                   stg_body))
 267            (StgApp (StgVarArg var) [] bOGUS_LVs))
 268 \end{code}
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsubsection[coreToStg-applications]{Applications}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 \begin{code}
 277 coreExprToStg env expr@(App _ _)
 278   = let
 279         (fun,args)    = collect_args expr []
 280         (_, stg_args) = coreArgsToStg env args
 281     in
 282         -- Now deal with the function
 283     case (fun, args) of
 284       (Var fun_id, _) ->        -- A function Id, so do an StgApp; it's ok if
 285                                 -- there are no arguments.
 286                             returnUs (mk_app (stgLookup env fun_id) stg_args)
 287
 288       (non_var_fun, []) ->      -- No value args, so recurse into the function
 289                             coreExprToStg env non_var_fun
 290
 291       other ->  -- A non-variable applied to things; better let-bind it.
 292                 newStgVar (coreExprType fun)    `thenUs` \ fun_id ->
 293                 coreExprToStg env fun           `thenUs` \ (stg_fun) ->
 294                 let
 295                    fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 296                                            stgArgOcc
 297                                            bOGUS_FVs
 298                                            SingleEntry  -- Only entered once
 299                                            []
 300                                            stg_fun
 301                 in
 302                 returnUs (StgLet (StgNonRec fun_id fun_rhs)
 303                                  (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
 304   where
 305         -- Collect arguments, discarding type/usage applications
 306     collect_args (App e   (TyArg _))    args = collect_args e   args
 307     collect_args (App fun arg)          args = collect_args fun (arg:args)
 308     collect_args (Coerce _ _ expr)      args = collect_args expr args
 309     collect_args fun                    args = (fun, args)
 310 \end{code}
 311
 312 %************************************************************************
 313 %*                                                                      *
 314 \subsubsection[coreToStg-cases]{Case expressions}
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 \begin{code}
 319 coreExprToStg env (Case discrim alts)
 320   = coreExprToStg env discrim           `thenUs` \ stg_discrim ->
 321     alts_to_stg discrim alts            `thenUs` \ stg_alts ->
 322     getUnique                           `thenUs` \ uniq ->
 323     returnUs (
 324         StgCase stg_discrim
 325                 bOGUS_LVs
 326                 bOGUS_LVs
 327                 uniq
 328                 stg_alts
 329     )
 330   where
 331     discrim_ty              = coreExprType discrim
 332     (_, discrim_ty_args, _) = splitAlgTyConApp discrim_ty
 333
 334     alts_to_stg discrim (AlgAlts alts deflt)
 335       = default_to_stg discrim deflt            `thenUs` \ stg_deflt ->
 336         mapUs boxed_alt_to_stg alts             `thenUs` \ stg_alts  ->
 337         returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
 338       where
 339         boxed_alt_to_stg (con, bs, rhs)
 340           = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 341             returnUs (con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
 342
 343     alts_to_stg discrim (PrimAlts alts deflt)
 344       = default_to_stg discrim deflt            `thenUs` \ stg_deflt ->
 345         mapUs unboxed_alt_to_stg alts           `thenUs` \ stg_alts  ->
 346         returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
 347       where
 348         unboxed_alt_to_stg (lit, rhs)
 349           = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 350             returnUs (lit, stg_rhs)
 351
 352     default_to_stg discrim NoDefault
 353       = returnUs StgNoDefault
 354
 355     default_to_stg discrim (BindDefault binder rhs)
 356       = coreExprToStg env rhs    `thenUs` \ stg_rhs ->
 357         returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
 358 \end{code}
 359
 360 %************************************************************************
 361 %*                                                                      *
 362 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
 363 %*                                                                      *
 364 %************************************************************************
 365
 366 \begin{code}
 367 coreExprToStg env (Let bind body)
 368   = coreBindToStg env     bind   `thenUs` \ (stg_binds, new_env) ->
 369     coreExprToStg new_env body   `thenUs` \ stg_body ->
 370     returnUs (mkStgLets stg_binds stg_body)
 371 \end{code}
 372
 373
 374 %************************************************************************
 375 %*                                                                      *
 376 \subsubsection[coreToStg-scc]{SCC expressions}
 377 %*                                                                      *
 378 %************************************************************************
 379
 380 Covert core @scc@ expression directly to STG @scc@ expression.
 381 \begin{code}
 382 coreExprToStg env (SCC cc expr)
 383   = coreExprToStg env expr   `thenUs` \ stg_expr ->
 384     returnUs (StgSCC (coreExprType expr) cc stg_expr)
 385 \end{code}
 386
 387 \begin{code}
 388 coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
 389 \end{code}
 390
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection[coreToStg-misc]{Miscellaneous helping functions}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 There's not anything interesting we can ASSERT about \tr{var} if it
 399 isn't in the StgEnv. (WDP 94/06)
 400
 401 \begin{code}
 402 stgLookup :: StgEnv -> Id -> StgArg
 403 stgLookup env var = case (lookupIdEnv env var) of
 404                       Nothing   -> StgVarArg var
 405                       Just atom -> atom
 406 \end{code}
 407
 408 Invent a fresh @Id@:
 409 \begin{code}
 410 newStgVar :: Type -> UniqSM Id
 411 newStgVar ty
 412  = getUnique                    `thenUs` \ uniq ->
 413    returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
 414 \end{code}
 415
 416 \begin{code}
 417 mkStgLets ::   [StgBinding]
 418             -> StgExpr  -- body of let
 419             -> StgExpr
 420
 421 mkStgLets binds body = foldr StgLet body binds
 422
 423 -- mk_app spots an StgCon in a function position,
 424 -- and turns it into an StgCon. See notes with
 425 -- getArgAmode in CgBindery.
 426 mk_app (StgConArg con) args = StgCon con       args bOGUS_LVs
 427 mk_app other_fun       args = StgApp other_fun args bOGUS_LVs
 428 \end{code}