Hi all,
Following a short chat in #ghc last week, I did a first attempt of
reusing existing Iface logic to implement serialization for
codegen-related Core. The implementation is included in the attached
patch (~100 loc). As a quick and dirty validation of whether it works,
I also modified the codegen pipeline logic to do a roundtrip: after
CorePrep, the Core bits are converted to Iface, then we immediately
convert it back and use it for later compiling.
With the patch applied, stage-1 GHC would produce a "missing hi file"
error like:
: Bad interface file: _build/stage1/libraries/ghc-prim/build/GHC/Types.hi
_build/stage1/libraries/ghc-prim/build/GHC/Types.hi:
openBinaryFile: does not exist (No such file or directory)
The error surprises me, since by the time we perform the Core-to-Core
roundtrip, the .hi file should already have been written to disk. Is
there anything obviously wrong with the implementation? I'd appreciate
any pointers or further questions, thanks a lot!
Best regards,
Cheng
diff --git a/compiler/ExtCore.hs b/compiler/ExtCore.hs
new file mode 100644
index 0000000000..48f7792cf3
--- /dev/null
+++ b/compiler/ExtCore.hs
@@ -0,0 +1,82 @@
+{-# OPTIONS_GHC -Wall #-}
+
+module ExtCore where
+
+import Data.Traversable
+import qualified GHC.CoreToIface as GHC
+import qualified GHC.Iface.Syntax as GHC
+import qualified GHC.IfaceToCore as GHC
+import qualified GHC.Plugins as GHC
+import GHC.Prelude
+import qualified GHC.Tc.Utils.Monad as GHC
+import qualified GHC.Utils.Binary as GHC
+
+data ExtCoreBind
+ = NonRec GHC.IfExtName GHC.IfaceExpr
+ | Rec [(GHC.IfExtName, GHC.IfaceExpr)]
+
+instance GHC.Binary ExtCoreBind where
+ put_ bh (NonRec bndr rhs) =
+ GHC.putByte bh 0 *> GHC.put_ bh bndr *> GHC.put_ bh rhs
+ put_ bh (Rec pairs) = GHC.putByte bh 1 *> GHC.put_ bh pairs
+
+ get bh = do
+ h <- GHC.getByte bh
+ case h of
+ 0 -> NonRec <$> GHC.get bh <*> GHC.get bh
+ 1 -> Rec <$> GHC.get bh
+ _ -> fail "instance Binary ExtCoreBind"
+
+toExtCoreBinds :: GHC.CoreProgram -> [ExtCoreBind]
+toExtCoreBinds = map toExtCoreBind
+
+toExtCoreBind :: GHC.CoreBind -> ExtCoreBind
+toExtCoreBind (GHC.NonRec b r) =
+ NonRec (unIfaceExt $ GHC.toIfaceVar b) (GHC.toIfaceExpr r)
+toExtCoreBind (GHC.Rec prs) =
+ Rec [(unIfaceExt $ GHC.toIfaceVar b, GHC.toIfaceExpr r) | (b, r) <- prs]
+
+tcExtCoreBindsDriver ::
+ GHC.HscEnv -> GHC.Module -> [ExtCoreBind] -> IO GHC.CoreProgram
+tcExtCoreBindsDriver hsc_env this_mod ext_core_binds = do
+ (_, maybe_result) <-
+ GHC.initTc hsc_env GHC.HsSrcFile False this_mod (error "lazy RealSrcSpan") $
+ initIfaceExtCore $
+ tcExtCoreBinds ext_core_binds
+ case maybe_result of
+ Just r -> pure r
+ _ -> fail "tcExtCoreBindsDriver"
+
+tcExtCoreBinds :: [ExtCoreBind] -> GHC.IfL GHC.CoreProgram
+tcExtCoreBinds = traverse tcExtCoreBind
+
+tcExtCoreBind :: ExtCoreBind -> GHC.IfL GHC.CoreBind
+tcExtCoreBind (NonRec bndr rhs) = do
+ bndr' <- fmap unCoreVar $ GHC.tcIfaceExpr $ GHC.IfaceExt bndr
+ rhs' <- GHC.tcIfaceExpr rhs
+ pure $ GHC.NonRec bndr' rhs'
+tcExtCoreBind (Rec pairs) = do
+ let (bndrs, rhss) = unzip pairs
+ bndrs' <- for bndrs $ fmap unCoreVar . GHC.tcIfaceExpr . GHC.IfaceExt
+ rhss' <- for rhss GHC.tcIfaceExpr
+ pure $ GHC.Rec $ zip bndrs' rhss'
+
+initIfaceExtCore :: GHC.IfL a -> GHC.TcRn a
+initIfaceExtCore thing_inside = do
+ tcg_env <- GHC.getGblEnv
+ let this_mod = GHC.tcg_mod tcg_env
+ if_env =
+ GHC.IfGblEnv
+ { GHC.if_doc = GHC.empty,
+ GHC.if_rec_types = Just (this_mod, pure (GHC.tcg_type_env tcg_env))
+ }
+ if_lenv = GHC.mkIfLclEnv this_mod GHC.empty GHC.NotBoot
+ GHC.setEnvs (if_env, if_lenv) thing_inside
+
+unIfaceExt :: GHC.IfaceExpr -> GHC.IfExtName
+unIfaceExt (GHC.IfaceExt bndr) = bndr
+unIfaceExt _ = error "unIfaceExt"
+
+unCoreVar :: GHC.CoreExpr -> GHC.CoreBndr
+unCoreVar (GHC.Var bndr) = bndr
+unCoreVar _ = error "unCoreVar"
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 90a07d7490..61bfc96693 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -183,6 +183,8 @@ import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
+import ExtCore
+
#include "HsVersions.h"
@@ -1409,9 +1411,12 @@ hscGenHardCode hsc_env cgguts location output_filename = do
-------------------
-- PREPARE FOR CODE GENERATION
-- Do saturation and convert to A-normal form
- (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}
+ (prepd_binds', local_ccs) <- {-# SCC "CorePrep" #-}
corePrepPgm hsc_env this_mod location
core_binds data_tycons
+
+ prepd_binds <- tcExtCoreBindsDriver hsc_env this_mod $ toExtCoreBinds prepd_binds'
+
----------------- Convert to STG ------------------
(stg_binds, (caf_ccs, caf_cc_stacks))
<- {-# SCC "CoreToStg" #-}
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index d469a85926..0bb2524a2b 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -663,3 +663,4 @@ Library
GHC.Runtime.Heap.Inspect
GHC.Runtime.Interpreter
GHC.Runtime.Interpreter.Types
+ ExtCore
_______________________________________________
ghc-devs mailing list
ghc-devs@haskell.org
http://mail.haskell.org/cgi-bin/mailman/listinfo/ghc-devs
