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