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