Skip to content

Instantly share code, notes, and snippets.

@Diullei
Forked from chrisdone/PrintStgGHC8_4_3.hs
Created December 6, 2020 18:09
Show Gist options
  • Save Diullei/25b2ceb2d6f598bcc037bb30ff407ea3 to your computer and use it in GitHub Desktop.
Save Diullei/25b2ceb2d6f598bcc037bb30ff407ea3 to your computer and use it in GitHub Desktop.
Print STG in GHC 8.4.3
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | Print STG in GHC 8.4.3.
module Main where
import Control.Monad.IO.Class (liftIO)
import qualified CorePrep
import qualified CoreSyn
import qualified CoreToStg
import qualified CostCentre
import qualified DynFlags
import qualified GHC
import qualified GHC.Paths
import qualified HscTypes
import qualified Literal
import qualified SimplStg
import qualified StgSyn as GHC
import qualified TyCon
import qualified Unique
main :: IO ()
main =
GHC.defaultErrorHandler
DynFlags.defaultFatalMessager
DynFlags.defaultFlushOut
(GHC.runGhc
(Just GHC.Paths.libdir)
(do dflags <- GHC.getSessionDynFlags
_ <- GHC.setSessionDynFlags dflags
target <- GHC.guessTarget "stgdemo.hs" Nothing
GHC.setTargets [target]
_ <- GHC.load GHC.LoadAllTargets
mgraph <- fmap GHC.mgModSummaries GHC.getModuleGraph
mapM_
(\modSummary -> do
stgs <- compile modSummary
liftIO (print stgs))
mgraph))
compile ::
GHC.GhcMonad m
=> GHC.ModSummary
-> m [GHC.StgTopBinding]
compile modSummary = do
parsedModule <- GHC.parseModule modSummary
typecheckedModule <- GHC.typecheckModule parsedModule
desugared <- GHC.desugarModule typecheckedModule
let modguts = GHC.dm_core_module desugared
this_mod = GHC.ms_mod modSummary
hsc_env <- GHC.getSession
-- Copied roughly from HcsMain <https://github.com/ghc/ghc/blob/ghc-8.4/compiler/main/HscMain.hs#L1312-L1318>
(prepd_binds, _) <-
liftIO
(CorePrep.corePrepPgm
hsc_env
this_mod
(GHC.ms_location modSummary)
(HscTypes.mg_binds modguts)
(filter TyCon.isDataTyCon (HscTypes.mg_tcs modguts)))
dflags <- DynFlags.getDynFlags
(stg_binds, _) <- liftIO (myCoreToStg dflags this_mod prepd_binds)
pure stg_binds
-- Lifted directly from HscMain <https://github.com/ghc/ghc/blob/ghc-8.4/compiler/main/HscMain.hs#L1481-L1493>
myCoreToStg ::
GHC.DynFlags
-> GHC.Module
-> CoreSyn.CoreProgram
-> IO ([GHC.StgTopBinding], CostCentre.CollectedCCs)
myCoreToStg dflags this_mod prepd_binds = do
let (stg_binds, cost_centre_info) = CoreToStg.coreToStg dflags this_mod prepd_binds
stg_binds2 <- SimplStg.stg2stg dflags stg_binds
return (stg_binds2, cost_centre_info)
--------------------------------------------------------------------------------
-- Orphan Shows for handy quick look
deriving instance Show (GHC.GenStgTopBinding GHC.Id GHC.Id)
deriving instance Show (GHC.GenStgBinding GHC.Id GHC.Id)
instance Show GHC.Id where show i = "(Id " ++ show (Unique.getKey (Unique.getUnique i)) ++ ")"
deriving instance Show (GHC.GenStgRhs GHC.Id GHC.Id)
deriving instance Show (GHC.GenStgExpr GHC.Id GHC.Id)
deriving instance Show (GHC.GenStgArg GHC.Id)
instance Show CostCentre.CostCentreStack where show _ = "CostCentreStack"
instance Show GHC.StgBinderInfo where show _ = "StgBinderInfo"
deriving instance Show GHC.UpdateFlag
instance Show GHC.DataCon where show _ = "DataCon"
deriving instance Show (CoreSyn.Tickish GHC.Id)
instance Show Literal.Literal where show _ = "Literal"
instance Show GHC.Type where show _ = "Type"
instance Show GHC.StgOp where show _ = "StgOp"
deriving instance Show GHC.AltType
deriving instance Show CoreSyn.AltCon
deriving instance Show CostCentre.CostCentre
instance Show GHC.Module where show _ = "Module"
instance Show TyCon.TyCon where show _ = "TyCon"
deriving instance Show CostCentre.IsCafCC
[ StgTopLifted
(StgNonRec
(Id 8286623314361722638)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[]
ReEntrant
[ (Id 8286623314361722608)
, (Id 8286623314361722609)
, (Id 8286623314361722610)
]
(StgLet
(StgRec
[ ( (Id 8286623314361722611)
, StgRhsClosure
CostCentreStack
StgBinderInfo
[(Id 8286623314361722637)]
Updatable
[]
(StgApp (Id 8286623314361722637) []))
, ( (Id 8286623314361722637)
, StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id 8286623314361722608)
, (Id 8286623314361722609)
, (Id 8286623314361722610)
, (Id 8286623314361722611)
]
ReEntrant
[(Id 8286623314361722612)]
(StgLet
(StgNonRec
(Id 8286623314361722622)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[(Id 8286623314361722609)]
Updatable
[]
(StgLet
(StgNonRec
(Id 8286623314361722621)
(StgRhsCon
CostCentreStack
DataCon
[StgLitArg Literal]))
(StgApp
(Id 3458764513820541088)
[ StgVarArg (Id 8286623314361722609)
, StgVarArg (Id 8286623314361722621)
]))))
(StgCase
(StgApp
(Id 3458764513820541095)
[ StgVarArg (Id 8286623314361722608)
, StgVarArg (Id 8286623314361722612)
, StgVarArg (Id 8286623314361722622)
])
(Id 8286623314361722623)
(AlgAlt TyCon)
[ ( DataAlt DataCon
, []
, StgLet
(StgNonRec
(Id 8286623314361722625)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[(Id 8286623314361722609)]
Updatable
[]
(StgLet
(StgNonRec
(Id 8286623314361722624)
(StgRhsCon
CostCentreStack
DataCon
[StgLitArg Literal]))
(StgApp
(Id 3458764513820541088)
[ StgVarArg
(Id 8286623314361722609)
, StgVarArg
(Id 8286623314361722624)
]))))
(StgCase
(StgApp
(Id 3458764513820541095)
[ StgVarArg (Id 8286623314361722608)
, StgVarArg (Id 8286623314361722612)
, StgVarArg (Id 8286623314361722625)
])
(Id 8286623314361722626)
(AlgAlt TyCon)
[ ( DataAlt DataCon
, []
, StgLet
(StgNonRec
(Id 8286623314361722634)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id 8286623314361722609)
, (Id 8286623314361722611)
, (Id 8286623314361722612)
]
Updatable
[]
(StgLet
(StgNonRec
(Id 8286623314361722633)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id
8286623314361722609)
, (Id
8286623314361722612)
]
Updatable
[]
(StgLet
(StgNonRec
(Id
8286623314361722632)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id
8286623314361722609)
]
Updatable
[]
(StgLet
(StgNonRec
(Id
8286623314361722631)
(StgRhsCon
CostCentreStack
DataCon
[ StgLitArg
Literal
]))
(StgApp
(Id
3458764513820541088)
[ StgVarArg
(Id
8286623314361722609)
, StgVarArg
(Id
8286623314361722631)
]))))
(StgApp
(Id
3458764513820541089)
[ StgVarArg
(Id
8286623314361722609)
, StgVarArg
(Id
8286623314361722612)
, StgVarArg
(Id
8286623314361722632)
]))))
(StgApp
(Id 8286623314361722611)
[ StgVarArg
(Id
8286623314361722633)
]))))
(StgLet
(StgNonRec
(Id 8286623314361722630)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id 8286623314361722609)
, (Id 8286623314361722611)
, (Id 8286623314361722612)
]
Updatable
[]
(StgLet
(StgNonRec
(Id
8286623314361722629)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id
8286623314361722609)
, (Id
8286623314361722612)
]
Updatable
[]
(StgLet
(StgNonRec
(Id
8286623314361722628)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[ (Id
8286623314361722609)
]
Updatable
[]
(StgLet
(StgNonRec
(Id
8286623314361722627)
(StgRhsCon
CostCentreStack
DataCon
[ StgLitArg
Literal
]))
(StgApp
(Id
3458764513820541088)
[ StgVarArg
(Id
8286623314361722609)
, StgVarArg
(Id
8286623314361722627)
]))))
(StgApp
(Id
3458764513820541089)
[ StgVarArg
(Id
8286623314361722609)
, StgVarArg
(Id
8286623314361722612)
, StgVarArg
(Id
8286623314361722628)
]))))
(StgApp
(Id
8286623314361722611)
[ StgVarArg
(Id
8286623314361722629)
]))))
(StgApp
(Id 8214565720323784718)
[ StgVarArg
(Id 8286623314361722610)
, StgVarArg
(Id 8286623314361722630)
, StgVarArg
(Id 8286623314361722634)
])))
, ( DataAlt DataCon
, []
, StgLet
(StgNonRec
(Id 8286623314361722635)
(StgRhsCon
CostCentreStack
DataCon
[StgLitArg Literal]))
(StgApp
(Id 3458764513820541088)
[ StgVarArg
(Id 8286623314361722610)
, StgVarArg
(Id 8286623314361722635)
]))
]))
, ( DataAlt DataCon
, []
, StgLet
(StgNonRec
(Id 8286623314361722636)
(StgRhsCon
CostCentreStack
DataCon
[StgLitArg Literal]))
(StgApp
(Id 3458764513820541088)
[ StgVarArg (Id 8286623314361722610)
, StgVarArg (Id 8286623314361722636)
]))
])))
])
(StgApp (Id 8286623314361722611) []))))
, StgTopLifted
(StgNonRec
(Id 8286623314361722607)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[]
Updatable
[]
(StgApp (Id 8286623314361722638) [])))
, StgTopLifted
(StgNonRec
(Id 8286623314361722641)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[]
Updatable
[]
(StgLet
(StgNonRec
(Id 8286623314361722640)
(StgRhsCon CostCentreStack DataCon [StgLitArg Literal]))
(StgApp
(Id 8286623314361722607)
[ StgVarArg (Id 8214565720323792744)
, StgVarArg (Id 8214565720323784734)
, StgVarArg (Id 8214565720323784734)
, StgVarArg (Id 8286623314361722640)
]))))
, StgTopLifted
(StgNonRec
(Id 8286623314361722639)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[]
Updatable
[]
(StgApp
(Id 3458764513820540965)
[ StgVarArg (Id 8214565720323793545)
, StgVarArg (Id 8286623314361722641)
])))
, StgTopLifted
(StgNonRec
(Id 8286623314361722642)
(StgRhsClosure
CostCentreStack
StgBinderInfo
[]
Updatable
[]
(StgApp (Id 3458764513820541030) [StgVarArg (Id 8286623314361722639)])))
, StgTopLifted
(StgNonRec
(Id 8286623314361722645)
(StgRhsCon CostCentreStack DataCon [StgLitArg Literal]))
, StgTopLifted
(StgNonRec
(Id 8286623314361722644)
(StgRhsCon CostCentreStack DataCon [StgLitArg Literal]))
, StgTopLifted
(StgNonRec
(Id 8286623314361722643)
(StgRhsCon
CostCentreStack
DataCon
[ StgVarArg (Id 8286623314361722644)
, StgVarArg (Id 8286623314361722645)
]))
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment