diff options
Diffstat (limited to 'compiler/GHC/CoreToStg.hs')
| -rw-r--r-- | compiler/GHC/CoreToStg.hs | 59 |
1 files changed, 46 insertions, 13 deletions
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 8082023ae7..2193577a3d 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP, DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 @@ -330,10 +332,11 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs) ; let (stg_rhs, ccs') = mkTopStgRhs dflags this_mod ccs bndr new_rhs + stg_rhs' = coerceStgRhs stg_rhs stg_arity = - stgRhsArity stg_rhs + stgRhsArity stg_rhs' - ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, + ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs', ccs') } where -- It's vital that the arity on a top-level Id matches @@ -355,13 +358,43 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs) text "Id arity:" <+> ppr id_arity, text "STG arity:" <+> ppr stg_arity] + -- Coerces the intermediate SgStgRhs that is used in this module to StgRhs, + -- panicking if any StgLams are found. mkStgRhs and mkTopStgRhs remove any + -- lambdas that appear in the body of a let binding, and CorePrep ensures + -- that no other lambdas exist, so this should never panic. + coerceStgRhs :: SgStgRhs -> StgRhs + coerceStgRhs (StgRhsCon cc con args) = StgRhsCon cc con args + coerceStgRhs (StgRhsClosure ext cc upd_flag args body) + = StgRhsClosure ext cc upd_flag args (coerceStgExpr body) + where + coerceStgExpr :: SgStgExpr -> StgExpr + coerceStgExpr (StgApp func args) = StgApp func args + coerceStgExpr (StgLit lit) = StgLit lit + coerceStgExpr (StgConApp con args tys) = StgConApp con args tys + coerceStgExpr (StgOpApp op args ty) = StgOpApp op args ty + coerceStgExpr (StgCase scrut bndr alt_type alts) + = StgCase (coerceStgExpr scrut) bndr alt_type ((fmap . mapLast) coerceStgExpr alts) + coerceStgExpr (StgLet ext bind expr) + = StgLet ext (coerceStgBinding bind) (coerceStgExpr expr) + coerceStgExpr (StgLetNoEscape ext bind expr) + = StgLetNoEscape ext (coerceStgBinding bind) (coerceStgExpr expr) + coerceStgExpr (StgTick tick expr) = StgTick tick (coerceStgExpr expr) + coerceStgExpr (XStgExpr _) = pprPanic "CoreToStg.coerceStgExpr" (text "StgLam") + + coerceStgBinding :: SgStgBinding -> StgBinding + coerceStgBinding (StgNonRec bndr rhs) = StgNonRec bndr (coerceStgRhs rhs) + coerceStgBinding (StgRec binds) = StgRec $ (fmap . fmap) coerceStgRhs binds + + mapLast :: (a -> b) -> (c, d, a) -> (c, d, b) + mapLast f (c, d, a) = (c, d, f a) + -- --------------------------------------------------------------------------- -- Expressions -- --------------------------------------------------------------------------- coreToStgExpr :: CoreExpr - -> CtsM StgExpr + -> CtsM SgStgExpr -- The second and third components can be derived in a simple bottom up pass, not -- dependent on any decisions about which variables will be let-no-escaped or @@ -399,7 +432,7 @@ coreToStgExpr expr@(Lam _ _) let result_expr = case nonEmpty args' of Nothing -> body' - Just args'' -> StgLam args'' body' + Just args'' -> XStgExpr $ StgLam args'' body' return result_expr @@ -448,7 +481,7 @@ coreToStgExpr e0@(Case scrut bndr _ alts) = do text "STG:" $$ pprStgExpr panicStgPprOpts stg _ -> return stg where - vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr) + vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], SgStgExpr) vars_alt (con, binders, rhs) | DataAlt c <- con, c == unboxedUnitDataCon = -- This case is a bit smelly. @@ -515,7 +548,7 @@ mkStgAltType bndr alts coreToStgApp :: Id -- Function -> [CoreArg] -- Arguments -> [Tickish Id] -- Debug ticks - -> CtsM StgExpr + -> CtsM SgStgExpr coreToStgApp f args ticks = do (args', ticks') <- coreToStgArgs args how_bound <- lookupVarCts f @@ -624,7 +657,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument coreToStgLet :: CoreBind -- bindings -> CoreExpr -- body - -> CtsM StgExpr -- new let + -> CtsM SgStgExpr -- new let coreToStgLet bind body = do (bind2, body2) @@ -650,7 +683,7 @@ coreToStgLet bind body = do = (binder, LetBound NestedLet (manifestArity rhs)) vars_bind :: CoreBind - -> CtsM (StgBinding, + -> CtsM (SgStgBinding, [(Id, HowBound)]) -- extension to environment vars_bind (NonRec binder rhs) = do @@ -671,7 +704,7 @@ coreToStgLet bind body = do return (StgRec (binders `zip` rhss2), env_ext) coreToStgRhs :: (Id,CoreExpr) - -> CtsM StgRhs + -> CtsM SgStgRhs coreToStgRhs (bndr, rhs) = do new_rhs <- coreToStgExpr rhs @@ -680,10 +713,10 @@ coreToStgRhs (bndr, rhs) = do -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> Id -> StgExpr -> (StgRhs, CollectedCCs) + -> Id -> SgStgExpr -> (SgStgRhs, CollectedCCs) mkTopStgRhs dflags this_mod ccs bndr rhs - | StgLam bndrs body <- rhs + | XStgExpr (StgLam bndrs body) <- rhs = -- StgLam can't have empty arguments, so not CAF ( StgRhsClosure noExtFieldSilent dontCareCCS @@ -732,9 +765,9 @@ mkTopStgRhs dflags this_mod ccs bndr rhs -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. -mkStgRhs :: Id -> StgExpr -> StgRhs +mkStgRhs :: Id -> SgStgExpr -> SgStgRhs mkStgRhs bndr rhs - | StgLam bndrs body <- rhs + | XStgExpr (StgLam bndrs body) <- rhs = StgRhsClosure noExtFieldSilent currentCCS ReEntrant |