Dive into core ghc 8.6 Conversion

core-dump.hs

{- stack script
--package "base mtl time ghc ghc-paths haskeline containers"
--resolver lts-14.20
-}

module Main where

-- Compiler
import GHC
import DynFlags
import HscMain
import HscTypes
import Outputable
import GHC.Paths ( libdir )

-- Core Types
import Type
import TyCoRep
import Var
import Name
import Kind
import Avail
import IdInfo
import Module
import Data.Typeable (TypeRep)
import Unique
import OccName
import InstEnv
import NameSet
import RdrName
import FamInstEnv
import qualified Stream
import qualified CoreSyn as Syn
import TysWiredIn

-- Core Passes
import CorePrep (corePrepPgm)
import CoreToStg (coreToStg)
import SimplStg (stg2stg)
import FastString
import StgCmm (codeGen)
import Cmm (CmmGroup)
import CmmInfo (cmmToRawCmm )
import CmmLint (cmmLint)
import CmmPipeline (cmmPipeline)
import CmmBuildInfoTables
import AsmCodeGen ( nativeCodeGen )
import UniqSupply ( mkSplitUniqSupply, initUs_ )
import UniqDFM

import System.IO
import Data.Time
import Control.Monad.Trans
import Data.Set as Set
-------------------------------------------------------------------------------
-- Module
-------------------------------------------------------------------------------
mkName :: Int -> String -> Name
mkName i n = mkInternalName (mkUnique 'n' i) (mkOccName OccName.varName n) noSrcSpan

xn :: Name
xn = mkName 0 "x"

an :: Name
an = mkName 1 "a"

fn :: Name
fn = mkExternalName (mkUnique 'n' 2) modl (mkOccName OccName.varName "f") noSrcSpan

-- a :: *
a :: TyVar
a = mkTyVar an constraintKind

-- x :: a
x :: Var
x = mkLocalVar VanillaId xn (TyVarTy a) vanillaIdInfo

-- f :: a -> a
fv :: Var
fv = mkGlobalVar VanillaId fn (TyVarTy a `mkFunTy` TyVarTy a) vanillaIdInfo

def :: [Syn.CoreBind]
def = [Syn.NonRec fv f]

f :: Syn.Expr Var
f = Syn.Lam x (Syn.Var x)

modl :: Module
modl = mkModule unitid (mkModuleName "Example")
  where
    unitid :: UnitId
    unitid = fsToUnitId (fsLit "Example")

guts :: ModGuts
guts = ModGuts
  {
      mg_module          = modl,
      mg_hsc_src         = HsSrcFile,
      mg_loc             = noSrcSpan,
      mg_exports         = [Avail fn],
      mg_deps            = noDependencies,

      mg_usages          = [],

      mg_used_th         = False,
      mg_rdr_env         = emptyGlobalRdrEnv,

      mg_fix_env         = emptyFixityEnv,

      mg_tcs             = [],

      mg_insts           = [],
      mg_fam_insts       = [],

      mg_patsyns         = [],
      mg_rules           = [],

      mg_binds           = def,
      mg_foreign         = NoStubs,
      mg_foreign_files   = [],

      mg_warns           = NoWarnings,
      mg_anns            = [],
      mg_complete_sigs   = [],
      mg_hpc_info        = NoHpcInfo False,
      mg_modBreaks       = Nothing,

      mg_inst_env        = emptyInstEnv,

      mg_fam_inst_env    = emptyUDFM,

      mg_safe_haskell    = Sf_None,
      mg_trust_pkg       = False,

      mg_doc_hdr         = Nothing,
      mg_decl_docs       = emptyDeclDocMap,
      mg_arg_docs        = emptyArgDocMap
  }

summ :: DynFlags -> ModSummary
summ dflags = ModSummary
  {
      ms_mod          = modl,
      ms_hsc_src      = HsSrcFile,
      ms_location     = ModLocation {
          ml_hs_file  = Nothing
      ,   ml_hi_file  = "Example.hi"
      ,   ml_obj_file = "Example.o"
      },
      ms_hs_date      = UTCTime (toEnum 0) 0,
      ms_obj_date     = Nothing,
      ms_iface_date   = Nothing,
      ms_srcimps      = [],
      ms_textual_imps = [],
      ms_parsed_mod   = Nothing,
      ms_hspp_file    = "Example.hs",
      ms_hspp_opts    = dflags,
      ms_hspp_buf     = Nothing
  }

modloc :: ModLocation
modloc = ModLocation
 { ml_hs_file  = Nothing
 , ml_hi_file  = "Example.hi"
 , ml_obj_file = "Example.o"
 }

showGhc :: (Outputable a) => a -> String
showGhc = showPpr unsafeGlobalDynFlags

-------------------------------------------------------------------------------
-- Compilation
-------------------------------------------------------------------------------

main :: IO ()
main = runGhc (Just libdir) $ do
  dflags <- getSessionDynFlags
  setSessionDynFlags $ dflags { hscTarget = HscAsm, ghcLink = LinkBinary }
  dflags <- getSessionDynFlags

  env <- getSession

  setTargets [Target
    { targetId = TargetModule (mkModuleName "Example")
    , targetAllowObjCode = True
    , targetContents = Nothing }]

  -- Run the Core prep pass
  (prep, prepCost) <- liftIO $ corePrepPgm env modl (ms_location (summ dflags)) (mg_binds guts) (mg_tcs guts)
  liftIO $ putStrLn "finish corePrepPgm"
  liftIO $ putStrLn $ showGhc prep

  -- Transform Core into STG
  let (stg, stgCost) = coreToStg dflags (mg_module guts) prep
  liftIO $ putStrLn "finish coreToStg"

  -- STG Transformer
  stg_binds2 <- liftIO $ stg2stg dflags stg
  liftIO $ putStrLn "finish stg2stg"

  -- Generated Cmm
  let cmms = codeGen dflags (mg_module guts) (mg_tcs guts) stgCost stg_binds2 (mg_hpc_info guts)
  liftIO $ putStrLn "finish codegen"

  -- Initialize a name supply for the Cmm pipeline
  let initTopSRT = emptySRT (mg_module guts)
      run_pipeline = cmmPipeline env

  -- Collect the Cmm code stream after running the pipeline.
  let cmmstream = Stream.mapAccumL run_pipeline (emptySRT (mg_module guts)) cmms

  -- Prepare the Cmm for
  genraw <- liftIO $ cmmToRawCmm dflags cmms
  liftIO $ putStrLn "finish cmmToRawCmm"

  -- Initialize name supply for the native code generator and generate x86 to a
  ncg_uniqs <- liftIO $ mkSplitUniqSupply 'n'
  fname <- liftIO $ (openFile "Example.asm" WriteMode)
  liftIO $ putStrLn "finish open Example.asm"
  {- XXX this code, AsmCodeGen.nativeCodeGen, is giving the error -}
  rawDebug <- liftIO $ Stream.collect genraw
  liftIO $ putStrLn $ showGhc $ rawDebug
  liftIO $ nativeCodeGen dflags (mg_module guts) modloc fname ncg_uniqs genraw
  liftIO $ putStrLn "finish nativeCodeGen"

  -- Dump the outputted Stg and  Cmm out
  (gen, _) <- liftIO $ mycollect_ cmmstream

  liftIO $ putStrLn "=== STG ==="
  liftIO $ putStrLn $ showGhc stg_binds2

  liftIO $ putStrLn "=== CMM ==="
  liftIO $ putStrLn $ showGhc gen


mycollect_ :: Monad m => Stream.Stream m a r -> m ([a], r)
mycollect_ str = go str []
 where
  go str acc = do
    r <- Stream.runStream str
    case r of
      Left r -> return (reverse acc, r)
      Right (a, str') -> go str' (a:acc)

execution command

stack core-dump.hs --ghc-options"-verbose -prof -fprof-auto +RTS -xs"

output

~/projects/hask-play$ stack core-dump.hs
finish corePrepPgm
[sat_suA2 :: a => a
 [LclId]
 sat_suA2 = \ (x [Occ=Once] :: a) -> x,
 f :: a => a
 [GblId]
 f = sat_suA2]
finish coreToStg
finish stg2stg
finish codegen
finish cmmToRawCmm
finish open Example.asm
[[],
 [sat_suA2_entry() //  [R2]
          { [(cuA7,
              sat_suA2_info:
                  const 4294967301;
                  const 0;
                  const 14 :: W32;
                  const 0 :: W32;)]
          }
      {offset
        cuA7: // global
            _suA1::P64 = R2;
            goto cuA5;
        cuA5: // global
            if ((old + 0) - <highSp> < SpLim) (likely: False) goto cuA8; else goto cuA9;
        cuA8: // global
            R2 = _suA1::P64;
            R1 = sat_suA2_closure;
            call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
        cuA9: // global
            goto cuA4;
        cuA4: // global
            R1 = _suA1::P64;
            call stg_ap_0_fast(R1) args: 8, res: 0, upd: 8;
      }
  }],
 [section ""data" . f_closure" {
      f_closure:
          const stg_IND_STATIC_info;
          const sat_suA2_closure+1;
          const 0;
          const 0;
  }]]
core-dump.hs: core-dump.hs: panic! (the 'impossible' happened)
  (GHC version 8.6.5 for x86_64-apple-darwin):
	getRegister(x86)

(old + 0)
Call stack:
    CallStack (from HasCallStack):
      callStackDoc, called at compiler/utils/Outputable.hs:1160:37 in ghc:Outputable
      pprPanic, called at compiler/nativeGen/X86/CodeGen.hs:1011:26 in ghc:X86.CodeGen

Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug