Skip to content
This repository has been archived by the owner on Jan 2, 2021. It is now read-only.

Commit

Permalink
switch back to bytecode
Browse files Browse the repository at this point in the history
  • Loading branch information
@wz1000
wz1000 committed Oct 17, 2020
1 parent f58edfb commit 52e0e7c
Show file tree
Hide file tree
Showing 7 changed files with 124 additions and 68 deletions.
80 changes: 44 additions & 36 deletions src/Development/IDE/Core/Compile.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -71,7 +71,7 @@ import qualified HeaderInfo as Hdr
import HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive)
import MkIface
import StringBuffer as SB
import TcRnMonad (finalSafeMode, TcGblEnv, tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds)
import TcRnMonad
import TcIface (typecheckIface)
import TidyPgm

Expand All @@ -92,8 +92,8 @@ import System.IO.Extra
import Control.Exception (evaluate)
import Exception (ExceptionMonad)
import TcEnv (tcLookup)
import Data.Time (UTCTime)

import Data.Time (UTCTime, getCurrentTime)
import Linker (unload)

-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
parseModule
Expand Down Expand Up @@ -126,9 +126,10 @@ computePackageDeps env pkg = do

typecheckModule :: IdeDefer
-> HscEnv
-> Maybe [Linkable] -- ^ linkables not to unload, if Nothing don't unload anything
-> ParsedModule
-> IO (IdeResult (HscEnv, TcModuleResult))
typecheckModule (IdeDefer defer) hsc pm = do
typecheckModule (IdeDefer defer) hsc keep_lbls pm = do
fmap (\(hsc, res) -> case res of Left d -> (d,Nothing); Right (d,res) -> (d,fmap (hsc,) res)) $
runGhcEnv hsc $
catchSrcErrors "typecheck" $ do
Expand All @@ -138,23 +139,25 @@ typecheckModule (IdeDefer defer) hsc pm = do

modSummary' <- initPlugins modSummary
(warnings, tcm) <- withWarnings "typecheck" $ \tweak ->
tcRnModule $ enableTopLevelWarnings
$ enableUnnecessaryAndDeprecationWarnings
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
tcRnModule keep_lbls $ enableTopLevelWarnings
$ enableUnnecessaryAndDeprecationWarnings
$ demoteIfDefer pm{pm_mod_summary = tweak modSummary'}
let errorPipeline = unDefer . hideDiag dflags . tagDiag
diags = map errorPipeline warnings
deferedError = any fst diags
return (map snd diags, Just $ tcm{tmrDeferedError = deferedError})
where
demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id

tcRnModule :: GhcMonad m => ParsedModule -> m TcModuleResult
tcRnModule pmod = do
tcRnModule :: GhcMonad m => Maybe [Linkable] -> ParsedModule -> m TcModuleResult
tcRnModule keep_lbls pmod = do
let ms = pm_mod_summary pmod
hsc_env <- getSession
let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
(tc_gbl_env, mrn_info)
<- liftIO $ hscTypecheckRename hsc_env_tmp ms $
<- liftIO $ do
whenJust keep_lbls $ unload hsc_env_tmp
hscTypecheckRename hsc_env_tmp ms $
HsParsedModule { hpm_module = parsedSource pmod,
hpm_src_files = pm_extra_src_files pmod,
hpm_annotations = pm_annotations pmod }
Expand Down Expand Up @@ -182,24 +185,22 @@ mkHiFileResultCompile
:: HscEnv
-> TcModuleResult
-> ModGuts
-> LinkableType -- ^ use object code or byte code?
-> IO (IdeResult HiFileResult)
mkHiFileResultCompile session' tcm simplified_guts = catchErrs $ do
mkHiFileResultCompile session' tcm simplified_guts ltype = catchErrs $ do
let session = session' { hsc_dflags = ms_hspp_opts ms }
ms = pm_mod_summary $ tmrParsed tcm
-- give variables unique OccNames
(guts, details) <- tidyProgram session simplified_guts

(diags, obj_res) <- generateObjectCode session ms guts
case obj_res of
let genLinkable = case ltype of
ObjectLinkable -> generateObjectCode
BCOLinkable -> generateByteCode

(diags, res) <- genLinkable session ms guts
case res of
Nothing -> do
#if MIN_GHC_API_VERSION(8,10,0)
let !partial_iface = force (mkPartialIface session details simplified_guts)
final_iface <- mkFullIface session partial_iface
#else
(final_iface,_) <- mkIface session Nothing details simplified_guts
#endif
let mod_info = HomeModInfo final_iface details Nothing
pure (diags, Just $ HiFileResult ms mod_info)
pure (diags, Nothing)
Just linkable -> do
#if MIN_GHC_API_VERSION(8,10,0)
let !partial_iface = force (mkPartialIface session details simplified_guts)
Expand All @@ -221,7 +222,7 @@ mkHiFileResultCompile session' tcm simplified_guts = catchErrs $ do
initPlugins :: GhcMonad m => ModSummary -> m ModSummary
initPlugins modSummary = do
session <- getSession
dflags <- liftIO $ initializePlugins session (ms_hspp_opts modSummary)
dflags <- liftIO $ initializePlugins session $ ms_hspp_opts modSummary
return modSummary{ms_hspp_opts = dflags}

-- | Whether we should run the -O0 simplifier when generating core.
Expand Down Expand Up @@ -261,7 +262,8 @@ generateObjectCode hscEnv summary guts = do
catchSrcErrors "object" $ do
session <- getSession
let dot_o = ml_obj_file (ms_location summary)
let session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }}
mod = ms_mod summary
session' = session { hsc_dflags = (hsc_dflags session) { outputFile = Just dot_o }}
fp = replaceExtension dot_o "s"
liftIO $ createDirectoryIfMissing True (takeDirectory fp)
(warnings, dot_o_fp) <-
Expand All @@ -275,7 +277,10 @@ generateObjectCode hscEnv summary guts = do
fp
compileFile session' StopLn (outputFilename, Just (As False))
let unlinked = DotO dot_o_fp
let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
-- Need time to be the modification time for recompilation checking
t <- liftIO $ getModificationTime dot_o_fp
let linkable = LM t mod [unlinked]

pure (map snd warnings, linkable)

generateByteCode :: HscEnv -> ModSummary -> CgGuts -> IO (IdeResult Linkable)
Expand All @@ -293,7 +298,9 @@ generateByteCode hscEnv summary guts = do
(_tweak summary)
#endif
let unlinked = BCOs bytecode sptEntries
let linkable = LM (ms_hs_date summary) (ms_mod summary) [unlinked]
time <- liftIO getCurrentTime
let linkable = LM time (ms_mod summary) [unlinked]

pure (map snd warnings, linkable)

demoteTypeErrorsToWarnings :: ParsedModule -> ParsedModule
Expand Down Expand Up @@ -479,7 +486,7 @@ loadModuleHome
-> HscEnv
-> HscEnv
loadModuleHome mod_info e =
e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info }
e { hsc_HPT = addToHpt (hsc_HPT e) mod_name mod_info, hsc_type_env_var = Nothing }
where
mod_name = moduleName $ mi_module $ hm_iface mod_info

Expand Down Expand Up @@ -717,10 +724,10 @@ loadInterface
:: MonadIO m => HscEnv
-> ModSummary
-> SourceModified
-> Bool
-> (Bool -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface
-> Maybe LinkableType
-> (Maybe LinkableType -> m ([FileDiagnostic], Maybe HiFileResult)) -- ^ Action to regenerate an interface
-> m ([FileDiagnostic], Maybe HiFileResult)
loadInterface session ms sourceMod objNeeded regen = do
loadInterface session ms sourceMod linkableNeeded regen = do
res <- liftIO $ checkOldIface session ms sourceMod Nothing
case res of
(UpToDate, Just iface)
Expand All @@ -740,19 +747,20 @@ loadInterface session ms sourceMod objNeeded regen = do
-- one-shot mode.
| not (mi_used_th iface) || SourceUnmodifiedAndStable == sourceMod
-> do
linkable <-
if objNeeded
then liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms)
else pure Nothing
let objUpToDate = not objNeeded || case linkable of
linkable <- case linkableNeeded of
Just ObjectLinkable -> liftIO $ findObjectLinkableMaybe (ms_mod ms) (ms_location ms)
_ -> pure Nothing

-- We don't need to regenerate if the object is up do date, or we don't need one
let objUpToDate = isNothing linkableNeeded || case linkable of
Nothing -> False
Just (LM obj_time _ _) -> obj_time > ms_hs_date ms
if objUpToDate
then do
hmi <- liftIO $ mkDetailsFromIface session iface linkable
return ([], Just $ HiFileResult ms hmi)
else regen objNeeded
(_reason, _) -> regen objNeeded
else regen linkableNeeded
(_reason, _) -> regen linkableNeeded

mkDetailsFromIface :: HscEnv -> ModIface -> Maybe Linkable -> IO HomeModInfo
mkDetailsFromIface session iface linkable = do
Expand Down
27 changes: 18 additions & 9 deletions src/Development/IDE/Core/RuleTypes.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,14 +27,18 @@ import Development.Shake
import GHC.Generics (Generic)

import Module (InstalledUnitId)
import HscTypes (ModGuts, hm_iface, HomeModInfo)
import HscTypes (ModGuts, hm_iface, HomeModInfo, hm_linkable)

import Development.IDE.Spans.Common
import Development.IDE.Spans.LocalBindings
import Development.IDE.Import.FindImports (ArtifactsLocation)
import Data.ByteString (ByteString)
import Language.Haskell.LSP.Types (NormalizedFilePath)
import TcRnMonad (TcGblEnv)
import qualified Data.ByteString.Char8 as BS

data LinkableType = ObjectLinkable | BCOLinkable
deriving (Eq,Ord,Show)

-- NOTATION
-- Foo+ means Foo for the dependencies
Expand All @@ -54,9 +58,6 @@ type instance RuleResult GetDependencies = TransitiveDependencies

type instance RuleResult GetModuleGraph = DependencyInformation

-- | Does this module need object code?
type instance RuleResult NeedsObjectCode = Bool

data GetKnownTargets = GetKnownTargets
deriving (Show, Generic, Eq, Ord)
instance Hashable GetKnownTargets
Expand Down Expand Up @@ -111,7 +112,12 @@ data HiFileResult = HiFileResult
}

hiFileFingerPrint :: HiFileResult -> ByteString
hiFileFingerPrint = fingerprintToBS . getModuleHash . hirModIface
hiFileFingerPrint hfr = ifaceBS <> linkableBS
where
ifaceBS = fingerprintToBS . getModuleHash . hirModIface $ hfr -- will always be two bytes
linkableBS = case hm_linkable $ hirHomeMod hfr of
Nothing -> ""
Just l -> BS.pack $ show $ linkableTime l

hirModIface :: HiFileResult -> ModIface
hirModIface = hm_iface . hirHomeMod
Expand Down Expand Up @@ -213,11 +219,14 @@ instance Hashable GetLocatedImports
instance NFData GetLocatedImports
instance Binary GetLocatedImports

data NeedsObjectCode = NeedsObjectCode
-- | Does this module need to be compiled?
type instance RuleResult NeedsCompilation = Bool

data NeedsCompilation = NeedsCompilation
deriving (Eq, Show, Typeable, Generic)
instance Hashable NeedsObjectCode
instance NFData NeedsObjectCode
instance Binary NeedsObjectCode
instance Hashable NeedsCompilation
instance NFData NeedsCompilation
instance Binary NeedsCompilation

data GetDependencyInformation = GetDependencyInformation
deriving (Eq, Show, Typeable, Generic)
Expand Down
Loading

0 comments on commit 52e0e7c

Please sign in to comment.