Add --verify-core-file to do roundtrip testing of core-files

Author: wz1000

ghcide/exe/Arguments.hs

@@ -15,6 +15,7 @@ data Arguments = Arguments
     ,argsOTMemoryProfiling          :: Bool
     ,argsTesting                    :: Bool
     ,argsDisableKick                :: Bool
+    ,argsVerifyCoreFile             :: Bool
     ,argsThreads                    :: Int
     ,argsVerbose                    :: Bool
     ,argsCommand                    :: Command
@@ -36,6 +37,7 @@ arguments plugins = Arguments
       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
       <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
+      <*> switch (long "verify-core-file" <> help "Verify core trips by roundtripping after serialization. Slow, only useful for testing purposes")
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
       <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")
       <*> (commandP plugins <|> lspCommand <|> checkCommand)

ghcide/exe/Main.hs

@@ -141,5 +141,6 @@ main = withTelemetryLogger $ \telemetryLogger -> do
                 , optCheckParents = pure $ checkParents config
                 , optCheckProject = pure $ checkProject config
                 , optRunSubset = not argsConservativeChangeTracking
+                , optVerifyCoreFile = argsVerifyCoreFile
                 }
         }

ghcide/src/Development/IDE/Core/Compile.hs

@@ -132,6 +132,9 @@ import qualified GHC                               as G
 import           GHC.Hs                            (LEpaComment)
 import qualified GHC.Types.Error                   as Error
 #endif
+import qualified Control.Monad.Trans.State.Strict as S
+import Data.Generics.Schemes
+import Data.Generics.Aliases
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
@@ -380,12 +383,13 @@ mkHiFileResultNoCompile session tcm = do
   pure $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm)
 
 mkHiFileResultCompile
-    :: HscEnv
+    :: ShakeExtras
+    -> HscEnv
     -> TcModuleResult
     -> ModGuts
     -> LinkableType -- ^ use object code or byte code?
     -> IO (IdeResult HiFileResult)
-mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
+mkHiFileResultCompile se session' tcm simplified_guts ltype = catchErrs $ do
   let session = hscSetFlags (ms_hspp_opts ms) session'
       ms = pm_mod_summary $ tmrParsed tcm
       tcGblEnv = tmrTypechecked tcm
@@ -394,17 +398,17 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
         ObjectLinkable -> generateObjectCode
         BCOLinkable    -> generateByteCode WriteCoreFile
 
-  (linkable, details, diags) <-
+  (linkable, details, mguts, diags) <-
     if mg_hsc_src simplified_guts == HsBootFile
     then do
         -- give variables unique OccNames
         details <- mkBootModDetailsTc session tcGblEnv
-        pure (Nothing, details, [])
+        pure (Nothing, details, Nothing, [])
     else do
         -- give variables unique OccNames
         (guts, details) <- tidyProgram session simplified_guts
         (diags, linkable) <- genLinkable session ms guts
-        pure (linkable, details, diags)
+        pure (linkable, details, Just guts, diags)
 #if MIN_VERSION_ghc(9,0,1)
   let !partial_iface = force (mkPartialIface session details simplified_guts)
   final_iface <- mkFullIface session partial_iface Nothing
@@ -415,6 +419,51 @@ mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
   (final_iface,_) <- mkIface session Nothing details simplified_guts
 #endif
   let mod_info = HomeModInfo final_iface details linkable
+
+  -- Verify core file by rountrip testing and comparison
+  IdeOptions{optVerifyCoreFile} <- getIdeOptionsIO se
+  when (maybe False (not . isObjectLinkable) linkable && optVerifyCoreFile) $ do
+    let core_fp = ml_core_file $ ms_location ms
+    traceIO $ "Verifying " ++ core_fp
+    core <- readBinCoreFile (mkUpdater $ hsc_NC session) core_fp
+    let CgGuts{cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of
+          Nothing -> error "invariant optVerifyCoreFile: guts must exist if linkable exists)"
+          Just g -> g
+        mod = ms_mod ms
+        data_tycons = filter isDataTyCon tycons
+    CgGuts{cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
+
+    -- Run corePrep first as we want to test the final version of the program that will
+    -- get translated to STG/Bytecode
+    (prepd_binds , _) <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
+    (prepd_binds', _) <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
+    let binds  = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds
+        binds' = noUnfoldings $ (map flattenBinds . (:[])) $ prepd_binds'
+
+        -- diffBinds is unreliable, sometimes it goes down the wrong track.
+        -- This fixes the order of the bindings so that it is less likely to do so.
+        diffs2 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go binds binds'
+        -- diffs1 = concat $ flip S.evalState (mkRnEnv2 emptyInScopeSet) $ zipWithM go (map (:[]) $ concat binds) (map (:[]) $ concat binds')
+        -- diffs3  = flip S.evalState (mkRnEnv2 emptyInScopeSet) $ go (concat binds) (concat binds')
+
+        diffs = diffs2
+        go x y = S.state $ \s -> diffBinds True s x y
+
+        -- The roundtrip doesn't preserver OtherUnfolding or occInfo, but neither are of these
+        -- are used for generate core or bytecode, so we can safely ignore them
+        -- SYB is slow but fine given that this is only used for testing
+        noUnfoldings = everywhere $ mkT $ \v -> if isId v
+          then
+            let v' = if isOtherUnfolding (realIdUnfolding v) then (setIdUnfolding v noUnfolding) else v
+              in setIdOccInfo v' noOccInfo
+          else v
+        isOtherUnfolding (OtherCon _) = True
+        isOtherUnfolding _ = False
+
+
+    when (not $ null diffs) $
+      panicDoc "verify core failed!" (vcat $ punctuate (text "\n\n") (diffs )) -- ++ [ppr binds , ppr binds']))
+
   pure (diags, Just $! mkHiFileResult ms mod_info (tmrRuntimeModules tcm))
 
   where

ghcide/src/Development/IDE/Core/Rules.hs

@@ -895,7 +895,8 @@ getModIfaceRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $
       linkableType <- getLinkableType f
       hsc <- hscEnv <$> use_ GhcSessionDeps f
       let compile = fmap ([],) $ use GenerateCore f
-      (diags, !hiFile) <- compileToObjCodeIfNeeded hsc linkableType compile tmr
+      se <- getShakeExtras
+      (diags, !hiFile) <- compileToObjCodeIfNeeded se hsc linkableType compile tmr
       let fp = hiFileFingerPrint <$> hiFile
       hiDiags <- case hiFile of
         Just hiFile
@@ -945,8 +946,9 @@ regenerateHiFile sess f ms compNeeded = do
                 -- compile writes .o file
                 let compile = compileModule (RunSimplifier True) hsc (pm_mod_summary pm) $ tmrTypechecked tmr
 
+                se <- getShakeExtras
                 -- Bang pattern is important to avoid leaking 'tmr'
-                (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded hsc compNeeded compile tmr
+                (diags'', !res) <- liftIO $ compileToObjCodeIfNeeded se hsc compNeeded compile tmr
 
                 -- Write hi file
                 hiDiags <- case res of
@@ -977,16 +979,16 @@ regenerateHiFile sess f ms compNeeded = do
 type CompileMod m = m (IdeResult ModGuts)
 
 -- | HscEnv should have deps included already
-compileToObjCodeIfNeeded :: MonadIO m => HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)
-compileToObjCodeIfNeeded hsc Nothing _ tmr = liftIO $ do
+compileToObjCodeIfNeeded :: MonadIO m => ShakeExtras -> HscEnv -> Maybe LinkableType -> CompileMod m -> TcModuleResult -> m (IdeResult HiFileResult)
+compileToObjCodeIfNeeded _ hsc Nothing _ tmr = liftIO $ do
   res <- mkHiFileResultNoCompile hsc tmr
   pure ([], Just $! res)
-compileToObjCodeIfNeeded hsc (Just linkableType) getGuts tmr = do
+compileToObjCodeIfNeeded se hsc (Just linkableType) getGuts tmr = do
   (diags, mguts) <- getGuts
   case mguts of
     Nothing -> pure (diags, Nothing)
     Just guts -> do
-      (diags', !res) <- liftIO $ mkHiFileResultCompile hsc tmr guts linkableType
+      (diags', !res) <- liftIO $ mkHiFileResultCompile se hsc tmr guts linkableType
       pure (diags++diags', res)
 
 getClientSettingsRule :: Recorder (WithPriority Log) -> Rules ()

ghcide/src/Development/IDE/GHC/Compat.hs

@@ -79,6 +79,7 @@ module Development.IDE.GHC.Compat(
     tidyExpr,
     emptyTidyEnv,
     corePrepExpr,
+    corePrepPgm,
     lintInteractiveExpr,
     icInteractiveModule,
     HomePackageTable,
@@ -93,6 +94,12 @@ module Development.IDE.GHC.Compat(
     module UniqSet,
     module UniqDFM,
     getDependentMods,
+    diffBinds,
+    flattenBinds,
+    mkRnEnv2,
+    emptyInScopeSet,
+    Unfolding(..),
+    noUnfolding,
 #if MIN_VERSION_ghc(9,2,0)
     loadExpr,
     byteCodeGen,
@@ -122,11 +129,12 @@ import           GHC                                   hiding (HasSrcSpan,
                                                         lookupName, exprType)
 #if MIN_VERSION_ghc(9,0,0)
 import GHC.Driver.Hooks (hscCompileCoreExprHook)
-import GHC.Core (CoreExpr, CoreProgram)
+import GHC.Core (CoreExpr, CoreProgram, Unfolding(..))
 import qualified GHC.Core.Opt.Pipeline as GHC
 import GHC.Core.Tidy (tidyExpr)
 import GHC.Types.Var.Env (emptyTidyEnv)
 import qualified GHC.CoreToStg.Prep as GHC
+import GHC.CoreToStg.Prep (corePrepPgm)
 import GHC.Core.Lint (lintInteractiveExpr)
 #if MIN_VERSION_ghc(9,2,0)
 import GHC.Unit.Home.ModInfo (lookupHpt, HomePackageTable)
@@ -146,11 +154,11 @@ import GHC.Types.Unique.Set as UniqSet
 import GHC.Types.Unique.DFM  as UniqDFM
 #else
 import Hooks (hscCompileCoreExprHook)
-import CoreSyn (CoreExpr)
+import CoreSyn (CoreExpr, flattenBinds, Unfolding(..), noUnfolding)
 import qualified SimplCore as GHC
 import CoreTidy (tidyExpr)
-import VarEnv (emptyTidyEnv)
-import CorePrep (corePrepExpr)
+import VarEnv (emptyTidyEnv, mkRnEnv2, emptyInScopeSet)
+import CorePrep (corePrepExpr, corePrepPgm)
 import CoreLint (lintInteractiveExpr)
 import ByteCodeGen (coreExprToBCOs)
 import HscTypes (icInteractiveModule, HomePackageTable, lookupHpt, Dependencies(dep_mods))
@@ -234,6 +242,8 @@ import GHC.ByteCode.Types
 import GHC.Linker.Loader (loadDecls)
 import GHC.Data.Maybe
 import GHC.CoreToStg
+import GHC.Core.Utils
+import GHC.Types.Var.Env
 #endif
 
 type ModIfaceAnnotation = Annotation

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -305,6 +305,7 @@ module Development.IDE.GHC.Compat.Core (
     -- * Panic
     PlainGhcException,
     panic,
+    panicDoc,
     -- * Other
     GHC.CoreModule(..),
     GHC.SafeHaskellMode(..),

ghcide/src/Development/IDE/GHC/Compat/Outputable.hs

@@ -6,7 +6,7 @@ module Development.IDE.GHC.Compat.Outputable (
     showSDoc,
     showSDocUnsafe,
     showSDocForUser,
-    ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest,
+    ppr, pprPanic, text, vcat, (<+>), ($$), empty, hang, nest, punctuate,
     printSDocQualifiedUnsafe,
     printNameWithoutUniques,
     printSDocAllTheWay,

ghcide/src/Development/IDE/Types/Options.hs

@@ -83,6 +83,8 @@ data IdeOptions = IdeOptions
   , optProgressStyle      :: ProgressReportingStyle
   , optRunSubset          :: Bool
       -- ^ Experimental feature to re-run only the subset of the Shake graph that has changed
+  , optVerifyCoreFile     :: Bool
+    -- ^ Verify core files after serialization
   }
 
 data OptHaddockParse = HaddockParse | NoHaddockParse
@@ -135,6 +137,7 @@ defaultIdeOptions session = IdeOptions
     ,optSkipProgress = defaultSkipProgress
     ,optProgressStyle = Explicit
     ,optRunSubset = True
+    ,optVerifyCoreFile = False
     ,optMaxDirtyAge = 100
     }
 

ghcide/test/data/THUnboxed/THA.hs

@@ -1,9 +1,16 @@
-{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}
+{-# LANGUAGE TemplateHaskell, UnboxedTuples, BangPatterns #-}
 module THA where
 import Language.Haskell.TH
 
-f :: Int -> (# Int, Int #)
-f x = (# x , x+1 #)
+data Foo = Foo !Int !Char !String
+  deriving Show
+
+newtype Bar = Bar Int
+  deriving Show
+
+
+f :: Int -> (# Int, Int, Foo, Bar#)
+f x = (# x , x+1 , Foo x 'a' "test" #)
 
 th_a :: DecsQ
-th_a = case f 1 of (# a , b #) -> [d| a = () |]
+th_a = case f 1 of (# a , b, Foo a b c, Bar !d #) -> [d| a = () |]

ghcide/test/exe/Main.hs

@@ -6323,7 +6323,7 @@ runInDir' dir startExeIn startSessionIn extraOptions s = do
 
   shakeProfiling <- getEnv "SHAKE_PROFILING"
   let cmd = unwords $
-       [ghcideExe, "--lsp", "--test", "--verbose", "-j2", "--cwd", startDir
+       [ghcideExe, "--lsp", "--test", "--verify-core-file", "--verbose", "-j2", "--cwd", startDir
        ] ++ ["--shake-profiling=" <> dir | Just dir <- [shakeProfiling]
        ] ++ extraOptions
   -- HIE calls getXgdDirectory which assumes that HOME is set.