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