@@ -36,6 +36,7 @@ module Development.IDE.Core.Compile
36
36
, TypecheckHelpers (.. )
37
37
) where
38
38
39
+ import Control.Monad.IO.Class
39
40
import Control.Concurrent.Extra
40
41
import Control.Concurrent.STM.Stats hiding (orElse )
41
42
import Control.DeepSeq (NFData (.. ), force , liftRnf ,
@@ -133,6 +134,11 @@ import GHC.Hs (LEpaComment)
133
134
import qualified GHC.Types.Error as Error
134
135
#endif
135
136
137
+ #if MIN_VERSION_ghc(9,5,0)
138
+ import GHC.Driver.Config.CoreToStg.Prep
139
+ import GHC.Core.Lint.Interactive
140
+ #endif
141
+
136
142
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
137
143
parseModule
138
144
:: IdeOptions
@@ -467,7 +473,11 @@ mkHiFileResultNoCompile session tcm = do
467
473
tcGblEnv = tmrTypechecked tcm
468
474
details <- makeSimpleDetails hsc_env_tmp tcGblEnv
469
475
sf <- finalSafeMode (ms_hspp_opts ms) tcGblEnv
470
- iface' <- mkIfaceTc hsc_env_tmp sf details ms tcGblEnv
476
+ iface' <- mkIfaceTc hsc_env_tmp sf details ms
477
+ #if MIN_VERSION_ghc(9,5,0)
478
+ Nothing
479
+ #endif
480
+ tcGblEnv
471
481
let iface = iface' { mi_globals = Nothing , mi_usages = filterUsages (mi_usages iface') } -- See Note [Clearing mi_globals after generating an iface]
472
482
pure $! mkHiFileResult ms iface details (tmrRuntimeModules tcm) Nothing
473
483
@@ -482,20 +492,19 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
482
492
ms = pm_mod_summary $ tmrParsed tcm
483
493
tcGblEnv = tmrTypechecked tcm
484
494
485
- (details, mguts) <-
486
- if mg_hsc_src simplified_guts == HsBootFile
487
- then do
488
- details <- mkBootModDetailsTc session tcGblEnv
489
- pure (details, Nothing )
490
- else do
495
+ (details, guts) <- do
491
496
-- write core file
492
497
-- give variables unique OccNames
493
498
tidy_opts <- initTidyOpts session
494
499
(guts, details) <- tidyProgram tidy_opts simplified_guts
495
- pure (details, Just guts)
500
+ pure (details, guts)
496
501
497
502
#if MIN_VERSION_ghc(9,0,1)
498
- let ! partial_iface = force $ mkPartialIface session details
503
+ let ! partial_iface = force $ mkPartialIface session
504
+ #if MIN_VERSION_ghc(9,5,0)
505
+ (cg_binds guts)
506
+ #endif
507
+ details
499
508
#if MIN_VERSION_ghc(9,3,0)
500
509
ms
501
510
#endif
@@ -513,9 +522,7 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
513
522
let final_iface = final_iface' {mi_globals = Nothing , mi_usages = filterUsages (mi_usages final_iface')} -- See Note [Clearing mi_globals after generating an iface]
514
523
515
524
-- Write the core file now
516
- core_file <- case mguts of
517
- Nothing -> pure Nothing -- no guts, likely boot file
518
- Just guts -> do
525
+ core_file <- do
519
526
let core_fp = ml_core_file $ ms_location ms
520
527
core_file = codeGutsToCoreFile iface_hash guts
521
528
iface_hash = getModuleHash final_iface
@@ -538,27 +545,37 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
538
545
Just (core, _) | optVerifyCoreFile -> do
539
546
let core_fp = ml_core_file $ ms_location ms
540
547
traceIO $ " Verifying " ++ core_fp
541
- let CgGuts {cg_binds = unprep_binds, cg_tycons = tycons } = case mguts of
542
- Nothing -> error " invariant optVerifyCoreFile: guts must exist if linkable exists"
543
- Just g -> g
548
+ let CgGuts {cg_binds = unprep_binds, cg_tycons = tycons } = guts
544
549
mod = ms_mod ms
545
550
data_tycons = filter isDataTyCon tycons
546
551
CgGuts {cg_binds = unprep_binds'} <- coreFileToCgGuts session final_iface details core
547
552
553
+ #if MIN_VERSION_ghc(9,5,0)
554
+ cp_cfg <- initCorePrepConfig session
555
+ #endif
556
+
557
+ let corePrep = corePrepPgm
558
+ #if MIN_VERSION_ghc(9,5,0)
559
+ (hsc_logger session) cp_cfg (initCorePrepPgmConfig (hsc_dflags session) (interactiveInScope $ hsc_IC session))
560
+ #else
561
+ session
562
+ #endif
563
+ mod (ms_location ms)
564
+
548
565
-- Run corePrep first as we want to test the final version of the program that will
549
566
-- get translated to STG/Bytecode
550
567
#if MIN_VERSION_ghc(9,3,0)
551
568
prepd_binds
552
569
#else
553
570
(prepd_binds , _)
554
571
#endif
555
- <- corePrepPgm session mod (ms_location ms) unprep_binds data_tycons
572
+ <- corePrep unprep_binds data_tycons
556
573
#if MIN_VERSION_ghc(9,3,0)
557
574
prepd_binds'
558
575
#else
559
576
(prepd_binds', _)
560
577
#endif
561
- <- corePrepPgm session mod (ms_location ms) unprep_binds' data_tycons
578
+ <- corePrep unprep_binds' data_tycons
562
579
let binds = noUnfoldings $ (map flattenBinds . (: [] )) $ prepd_binds
563
580
binds' = noUnfoldings $ (map flattenBinds . (: [] )) $ prepd_binds'
564
581
@@ -683,7 +700,7 @@ generateByteCode (CoreFileTime time) hscEnv summary guts = do
683
700
let session = _tweak (hscSetFlags (ms_hspp_opts summary) hscEnv)
684
701
-- TODO: maybe settings ms_hspp_opts is unnecessary?
685
702
summary' = summary { ms_hspp_opts = hsc_dflags session }
686
- hscInteractive session guts
703
+ hscInteractive session (mkCgInteractiveGuts guts)
687
704
(ms_location summary')
688
705
let unlinked = BCOs bytecode sptEntries
689
706
let linkable = LM time (ms_mod summary) [unlinked]
@@ -1220,7 +1237,9 @@ parseHeader
1220
1237
=> DynFlags -- ^ flags to use
1221
1238
-> FilePath -- ^ the filename (for source locations)
1222
1239
-> Util. StringBuffer -- ^ Haskell module source text (full Unicode is supported)
1223
- #if MIN_VERSION_ghc(9,0,1)
1240
+ #if MIN_VERSION_ghc(9,5,0)
1241
+ -> ExceptT [FileDiagnostic ] m ([FileDiagnostic ], Located (HsModule GhcPs ))
1242
+ #elif MIN_VERSION_ghc(9,0,1)
1224
1243
-> ExceptT [FileDiagnostic ] m ([FileDiagnostic ], Located (HsModule ))
1225
1244
#else
1226
1245
-> ExceptT [FileDiagnostic ] m ([FileDiagnostic ], Located (HsModule GhcPs ))
@@ -1552,13 +1571,13 @@ showReason (RecompBecause s) = s
1552
1571
mkDetailsFromIface :: HscEnv -> ModIface -> IO ModDetails
1553
1572
mkDetailsFromIface session iface = do
1554
1573
fixIO $ \ details -> do
1555
- let ! hsc' = hscUpdateHPT (\ hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details Nothing )) session
1574
+ let ! hsc' = hscUpdateHPT (\ hpt -> addToHpt hpt (moduleName $ mi_module iface) (HomeModInfo iface details emptyHomeModInfoLinkable )) session
1556
1575
initIfaceLoad hsc' (typecheckIface iface)
1557
1576
1558
1577
coreFileToCgGuts :: HscEnv -> ModIface -> ModDetails -> CoreFile -> IO CgGuts
1559
1578
coreFileToCgGuts session iface details core_file = do
1560
1579
let act hpt = addToHpt hpt (moduleName this_mod)
1561
- (HomeModInfo iface details Nothing )
1580
+ (HomeModInfo iface details emptyHomeModInfoLinkable )
1562
1581
this_mod = mi_module iface
1563
1582
types_var <- newIORef (md_types details)
1564
1583
let hsc_env' = hscUpdateHPT act (session {
@@ -1572,7 +1591,10 @@ coreFileToCgGuts session iface details core_file = do
1572
1591
-- Implicit binds aren't saved, so we need to regenerate them ourselves.
1573
1592
let implicit_binds = concatMap getImplicitBinds tyCons
1574
1593
tyCons = typeEnvTyCons (md_types details)
1575
- #if MIN_VERSION_ghc(9,3,0)
1594
+ #if MIN_VERSION_ghc(9,5,0)
1595
+ -- In GHC 9.6, the implicit binds are tidied and part of core_binds
1596
+ pure $ CgGuts this_mod tyCons core_binds [] NoStubs [] mempty (emptyHpcInfo False ) Nothing []
1597
+ #elif MIN_VERSION_ghc(9,3,0)
1576
1598
pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) [] NoStubs [] mempty (emptyHpcInfo False ) Nothing []
1577
1599
#else
1578
1600
pure $ CgGuts this_mod tyCons (implicit_binds ++ core_binds) NoStubs [] [] (emptyHpcInfo False ) Nothing []
@@ -1582,9 +1604,9 @@ coreFileToLinkable :: LinkableType -> HscEnv -> ModSummary -> ModIface -> ModDet
1582
1604
coreFileToLinkable linkableType session ms iface details core_file t = do
1583
1605
cgi_guts <- coreFileToCgGuts session iface details core_file
1584
1606
(warns, lb) <- case linkableType of
1585
- BCOLinkable -> generateByteCode (CoreFileTime t) session ms cgi_guts
1586
- ObjectLinkable -> generateObjectCode session ms cgi_guts
1587
- pure (warns, HomeModInfo iface details . Just <$> lb)
1607
+ BCOLinkable -> fmap ( maybe emptyHomeModInfoLinkable justBytecode) <$> generateByteCode (CoreFileTime t) session ms cgi_guts
1608
+ ObjectLinkable -> fmap ( maybe emptyHomeModInfoLinkable justObjects) <$> generateObjectCode session ms cgi_guts
1609
+ pure (warns, Just $ HomeModInfo iface details lb) -- TODO wz1000 handle emptyHomeModInfoLinkable
1588
1610
1589
1611
-- | Non-interactive, batch version of 'InteractiveEval.getDocs'.
1590
1612
-- The interactive paths create problems in ghc-lib builds
0 commit comments