[Git][ghc/ghc][wip/coreField] Loading core field
Josh Meredith
gitlab at gitlab.haskell.org
Tue Jun 9 06:31:17 UTC 2020
Josh Meredith pushed to branch wip/coreField at Glasgow Haskell Compiler / GHC
Commits:
7cf12f75 by Josh Meredith at 2020-06-09T16:31:01+10:00
Loading core field
- - - - -
6 changed files:
- compiler/GHC/Iface/Ext/Binary.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Types/Module.hs
Changes:
=====================================
compiler/GHC/Iface/Ext/Binary.hs
=====================================
@@ -111,12 +111,22 @@ putBinLine bh xs = do
mapM_ (putByte bh) $ BS.unpack xs
putByte bh 10 -- newline char
--- | Write a `HieFile` to the given `FilePath`, with a proper header and
--- symbol tables for `Name`s and `FastString`s
+
writeHieFile :: FilePath -> HieFile -> IO ()
writeHieFile hie_file_path hiefile = do
bh0 <- openBinMem initBinMemSize
+ writeHie bh0 hiefile
+
+ -- and send the result to the file
+ createDirectoryIfMissing True (takeDirectory hie_file_path)
+ writeBinMem bh0 hie_file_path
+
+-- | Write a `HieFile` to the given `FilePath`, with a proper header and
+-- symbol tables for `Name`s and `FastString`s
+writeHie :: BinHandle -> HieFile -> IO ()
+writeHie bh0 hiefile = do
+
-- Write the header: hieHeader followed by the
-- hieVersion and the GHC version used to generate this file
mapM_ (putByte bh0) hieMagic
@@ -171,10 +181,6 @@ writeHieFile hie_file_path hiefile = do
dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
- -- and send the result to the file
- createDirectoryIfMissing True (takeDirectory hie_file_path)
- writeBinMem bh hie_file_path
- return ()
data HieFileResult
= HieFileResult
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -69,6 +69,8 @@ import Data.Ord
import Data.IORef
import GHC.Driver.Plugins (LoadedPlugin(..))
+import Control.Monad
+
{-
************************************************************************
* *
@@ -99,6 +101,7 @@ mkPartialIface hsc_env mod_details
}
| gopt Opt_WriteCoreField dflags = do
fields <- writeFieldWith "ghc/core" write (mi_ext_fields iface)
+ forM_ (mg_binds guts) go
return iface{mi_ext_fields = fields}
| otherwise = return iface
where
@@ -107,6 +110,21 @@ mkPartialIface hsc_env mod_details
iface = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
safe_mode usages doc_hdr decl_docs arg_docs mod_details
+ go (NonRec iden rhs) = go2 iden rhs
+ go (Rec binds ) = print (length binds) >> mapM_ (uncurry go2) binds
+ go2 iden rhs = do
+ let n = idName iden
+ putStrLn "------------------------------------"
+ putStrLn (nameStableString n)
+ putStrLn $ showSDoc dflags (ppr n)
+ print (isInternalName n, isExternalName n, isSystemName n, isWiredInName n)
+ putStrLn "-------"
+ putStrLn $ showSDoc dflags (ppr rhs)
+ putStrLn "-------"
+ putStrLn (showSDoc dflags (ppr (toIfaceExpr rhs)))
+ putStrLn "------------------------------------"
+
+
-- | Fully instantiate a interface
-- Adds fingerprints and potentially code generator produced information.
mkFullIface :: HscEnv -> PartialModIface -> Maybe NameSet -> IO ModIface
@@ -752,7 +770,7 @@ toIfaceModGuts (ModGuts f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f
(map famInstToIfaceFamInst f12)
(map patSynToIfaceDecl f13)
(map coreRuleToIfaceRule f14)
- (map toIfaceBind f15)
+ (map toIfaceBind' $ filter isRealBinding f15)
f16
f17
f18
@@ -767,3 +785,7 @@ toIfaceModGuts (ModGuts f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f
f27
f28
f29
+
+isRealBinding (NonRec n _) = isExternalName (idName n)
+
+toIfaceBind' b = (isRealBinding b, toIfaceBind b)
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -155,6 +155,22 @@ check_old_iface hsc_env mod_summary src_modified maybe_iface
return Nothing
Succeeded iface -> do
traceIf (text "Read the interface file" <+> text iface_path)
+
+ -- liftIO $ putStrLn $ showSDoc dflags (ppr (mgModSummaries $ hsc_mod_graph hsc_env))
+
+ -- liftIO $ do
+ -- core <- initIfaceLoad hsc_env $ do
+ -- liftIO $ putStrLn $ showSDoc dflags (ppr mod_summary)
+ -- liftIO $ putStrLn "Interface"
+ -- initIfaceLcl (ms_mod mod_summary) (text "CORE") False $ do
+ -- liftIO $ putStrLn "init"
+ -- loadCore iface
+
+ -- putStrLn $ "Loaded core:"
+ -- case core of
+ -- Just c -> print $ showSDoc dflags (ppr (mg_binds c))
+ -- Nothing -> putStrLn "No core field"
+
return $ Just iface
src_changed
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -404,7 +404,7 @@ data IfaceModGuts = IfaceModGuts {
img_fam_insts :: ![IfaceFamInst],
img_patsyns :: ![IfaceDecl],
img_rules :: ![IfaceRule],
- img_binds :: ![IfaceBinding],
+ img_binds :: ![(Bool, IfaceBinding)],
img_foreign :: !ForeignStubs,
img_foreign_files :: ![(ForeignSrcLang, FilePath)],
img_warns :: !Warnings,
@@ -1329,9 +1329,9 @@ pprParendIfaceExpr = pprIfaceExpr parens
-- an atomic value (e.g. function args)
pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
-pprIfaceExpr _ (IfaceLcl v) = ppr v
-pprIfaceExpr _ (IfaceExt v) = ppr v
-pprIfaceExpr _ (IfaceLit l) = ppr l
+pprIfaceExpr _ (IfaceLcl v) = sep [ text "IfaceLcl", parens (ppr v) ]
+pprIfaceExpr _ (IfaceExt v) = sep [ text "IfaceExt", parens (ppr v) ]
+pprIfaceExpr _ (IfaceLit l) = sep [ text "IfaceLit", parens (ppr l) ]
pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty
pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -21,6 +21,8 @@ module GHC.IfaceToCore (
tcIfaceExpr, -- Desired by HERMIT (#7683)
tcIfaceGlobal,
tcIfaceModGuts,
+
+ tcIfaceType, tcJoinInfo, tcIfaceTyCon, tcIfaceRule
) where
#include "HsVersions.h"
@@ -81,6 +83,8 @@ import qualified BooleanFormula as BF
import Control.Monad
import qualified Data.Map as Map
+import Data.IORef
+import GHC.Types.Name.Cache
{-
This module takes
@@ -1846,32 +1850,65 @@ bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
************************************************************************
-}
-tcIfaceBinding :: IfaceBinding -> IfL (Bind Id)
-tcIfaceBinding (IfaceNonRec (IfLetBndr fs ty info ji) rhs)
- = do { name <- newIfaceName (mkVarOccFS fs)
- ; ty' <- tcIfaceType ty
- ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
- NotTopLevel name ty' info
- ; let id = mkLocalIdWithInfo name ty' id_info
- `asJoinId_maybe` tcJoinInfo ji
- ; rhs' <- tcIfaceExpr rhs
- ; return (NonRec id rhs') }
-
-tcIfaceBinding (IfaceRec pairs)
- = do { ids <- mapM tc_rec_bndr (map fst pairs)
- ; extendIfaceIdEnv ids $ do
- { pairs' <- zipWithM tc_pair pairs ids
- ; return (Rec pairs') } }
- where
- tc_rec_bndr (IfLetBndr fs ty _ ji)
- = do { name <- newIfaceName (mkVarOccFS fs)
- ; ty' <- tcIfaceType ty
- ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }
- tc_pair (IfLetBndr _ _ info _, rhs) id
- = do { rhs' <- tcIfaceExpr rhs
- ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
- NotTopLevel (idName id) (idType id) info
- ; return (setIdInfo id id_info, rhs') }
+tcIfaceBinding :: Module -> SrcSpan -> (Bool, IfaceBinding) -> IfL (Maybe (Bind Id))
+tcIfaceBinding mod loc ibind = do
+ bind <- tryAllM $ tcIfaceBinding' mod loc ibind
+ case bind of
+ Left _ -> return Nothing
+ Right b -> do
+ let (NonRec n _) = b
+ liftIO $ putStrLn (nameStableString $ idName n)
+ return $ Just b
+
+tcIfaceBinding' :: Module -> SrcSpan -> (Bool, IfaceBinding) -> IfL (Bind Id)
+tcIfaceBinding' _ _ (_p, (IfaceRec _)) = panic "tcIfaceBinding: expected NonRec at top level"
+tcIfaceBinding' mod loc b@(p, IfaceNonRec (IfLetBndr fs ty info ji) rhs) = do
+ name <- lookupIfaceTop (mkVarOccFS fs)
+
+
+ -- name <- newGlobalBinder mod (mkVarOccFS fs) loc
+
+ ty' <- tcIfaceType ty
+ -- id_info <- tcIdInfo False TopLevel name ty' info
+ let id = mkExportedVanillaId name ty'
+ `asJoinId_maybe` tcJoinInfo ji
+
+
+ liftIO $ putStrLn "-----------------------------"
+ liftIO $ print (nameStableString name, isInternalName name, isExternalName name, isSystemName name, isWiredInName name)
+ liftIO $ putStrLn "------------"
+ dflags <- getDynFlags
+ -- Env env _ _ _ <- getEnv
+ -- liftIO $ do
+ -- nc <- readIORef $ hsc_NC env
+ -- putStrLn $ showSDoc dflags (ppr $ nsNames nc)
+ -- return ()
+
+
+ liftIO $ putStrLn $ showSDoc dflags (ppr rhs)
+ rhs' <- tcIfaceExpr rhs
+ liftIO $ putStrLn "------------"
+ liftIO $ putStrLn $ showSDoc dflags (ppr rhs')
+ -- liftIO $ putStrLn "------------"
+ -- liftIO $ print (b == toIfaceBinding (NonRec id rhs'))
+ liftIO $ putStrLn "-----------------------------"
+ return (NonRec id rhs')
+
+-- tcIfaceBinding' (IfaceRec pairs)
+-- = do { ids <- mapM tc_rec_bndr (map fst pairs)
+-- ; extendIfaceIdEnv ids $ do
+-- { pairs' <- zipWithM tc_pair pairs ids
+-- ; return (Rec pairs') } }
+-- where
+-- tc_rec_bndr (IfLetBndr fs ty _ ji)
+-- = do { name <- newIfaceName (mkVarOccFS fs)
+-- ; ty' <- tcIfaceType ty
+-- ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) }
+-- tc_pair (IfLetBndr _ _ info _, rhs) id
+-- = do { rhs' <- tcIfaceExpr rhs
+-- ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+-- NotTopLevel (idName id) (idType id) info
+-- ; return (setIdInfo id id_info, rhs') }
tcIfaceModGuts :: IfaceModGuts -> IfL ModGuts
tcIfaceModGuts (IfaceModGuts f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17 f18
@@ -1881,7 +1918,7 @@ tcIfaceModGuts (IfaceModGuts f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15
f12' <- mapM tcIfaceFamInst f12
f13' <- mapM tcIfacePatSyn f13
f14' <- mapM tcIfaceRule f14
- f15' <- mapM tcIfaceBinding f15
+ f15' <- catMaybes <$> mapM (tcIfaceBinding f1 f3) f15
f23' <- extendInstEnvList emptyInstEnv <$> mapM tcIfaceInst f23
f24' <- extendFamInstEnvList emptyFamInstEnv <$> mapM tcIfaceFamInst f24
=====================================
compiler/GHC/Types/Module.hs
=====================================
@@ -164,7 +164,7 @@ import Control.DeepSeq
import Data.Coerce
import Data.Data
import Data.Function
-import Data.Map (Map)
+import Data.Map (Map, toList)
import Data.Set (Set)
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -1173,6 +1173,9 @@ wiredInUnitIds = [ primUnitId,
-- | A map keyed off of 'Module's
newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
+instance Outputable elt => Outputable (ModuleEnv elt) where
+ ppr (ModuleEnv m) = vcat $ map (\(NDModule md, elt) -> sep [ppr (moduleName md), ppr elt]) $ toList m
+
{-
Note [ModuleEnv performance and determinism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cf12f7555a75fc82b2dc6f0ca6b098db00ad4d8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7cf12f7555a75fc82b2dc6f0ca6b098db00ad4d8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200609/360223bd/attachment-0001.html>
More information about the ghc-commits
mailing list