Use GHC as a library, compiling to CMM

ghc-pipeline.hs

--
--  Call the PROG as:
--  <PROG> -package-db=<PATH-TO-PKGCONF>
--
--  <PATH-TO-PKGCONF> can be found by the following command:
--  ghc --print-global-package-db
--
module Main where

import GHC
import CorePrep
import CoreToStg
import SimplStg
import StgCmm
import CmmPipeline
import CmmBuildInfoTables
import HscTypes
import TyCon
import DynFlags
import MonadUtils
import UniqSupply
import qualified Stream as S
import Outputable
import GHC.Paths
import System.Environment (getArgs)

mload :: GhcMonad m => [Located String] -> FilePath -> m ()
mload args file = defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
    dflags <- getDynFlags 
    (dflags, args', warn) <- parseDynamicFlags dflags args
    setSessionDynFlags dflags

    -- build up the Module Graph, starting from 
    -- the input file.
    guessTarget file Nothing >>= addTarget
    depanal [] True

    -- ModuleSummary and Module
    summary  <- getModSummary (mkModuleName "Main")
    let modu = ms_mod summary
        location = ms_location summary
    session  <- getSession

    -- Compile To Core
    mod_guts <- coreModule <$> (parseModule summary
                            >>= typecheckModule
                            >>= desugarModule)
    
    -- Core to STG transform
    -- 1. corePrepPgm: normalize
    -- 2. coreToStg:   transform
    -- 3. stg2stg:     simplify
    let datacons = filter isDataTyCon $ mg_tcs mod_guts
        hpcinfo  = mg_hpc_info mod_guts
    (stg,cccs) <- liftIO $ corePrepPgm session location (mg_binds mod_guts) datacons
                       >>= coreToStg dflags modu
                       >>= stg2stg dflags modu

    -- STG to CMM transform
    let stream = codeGen dflags modu datacons cccs stg hpcinfo

    -- CMM Optimisation and stack layout computation
    us0 <- liftIO $ mkSplitUniqSupply 'C'
    let pipeline us cmm = do
            let (srt, us') = initUs us emptySRT
            (srt, cmm) <- cmmPipeline session srt cmm
            if isEmptySRT srt 
                then return (us', cmm)
                else return (us', srtToData srt ++ cmm)
        stream' = const () <$> S.mapAccumL pipeline us0 stream

    -- CMM is ready to be assembled
    -- we dump the CMM.
    cmms <- liftIO $ S.collect stream'
    liftIO $ putStrLn $ showPpr dflags cmms

main = do
    as <- map (mkGeneralLocated "command-line args") <$> getArgs
    (as, _) <- parseStaticFlags as
    runGhc (Just libdir) (mload as "2.hs")