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