Created
April 27, 2022 10:56
-
-
Save maksbotan/8c7a8f531163c58da9983fbc48d45fff to your computer and use it in GitHub Desktop.
Haskell Language Server + haskell.nix patch
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs | |
index 99938bd4..471b184c 100644 | |
--- a/ghcide/src/Development/IDE/Core/Compile.hs | |
+++ b/ghcide/src/Development/IDE/Core/Compile.hs | |
@@ -122,6 +122,15 @@ import GHC.Hs (LEpaComment) | |
import qualified GHC.Types.Error as Error | |
#endif | |
+import StgSyn | |
+import FastString | |
+import Unique | |
+import CostCentre | |
+import Data.Either | |
+import CoreSyn | |
+import CoreToStg | |
+import SimplStg | |
+ | |
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'. | |
parseModule | |
:: IdeOptions | |
@@ -256,9 +265,37 @@ captureSplicesAndDeps env k = do | |
; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos | |
; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs) | |
#else | |
+ {- Create a temporary binding and convert to STG -} | |
+ ; let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") | |
+ (mkPseudoUniqueE 0) | |
+ (exprType prepd_expr) | |
+ ; (binds, _) <- | |
+ myCoreToStg hsc_env | |
+ (icInteractiveModule (hsc_IC hsc_env)) | |
+ [NonRec bco_tmp_id prepd_expr] | |
+ | |
+ ; let (_strings, lifted_binds) = partitionEithers $ do -- list monad | |
+ bnd <- binds | |
+ case bnd of | |
+ StgTopLifted (StgNonRec i expr) -> [Right (i, expr)] | |
+ StgTopLifted (StgRec bnds) -> map Right bnds | |
+ StgTopStringLit b str -> [Left (b, str)] | |
+ | |
+ ; let stg_expr = case lifted_binds of | |
+ [(_i, e)] -> e | |
+ _ -> | |
+ StgRhsClosure noExtFieldSilent | |
+ dontCareCCS | |
+ ReEntrant | |
+ [] | |
+ (StgLet noExtFieldSilent | |
+ (StgRec lifted_binds) | |
+ (StgApp bco_tmp_id [])) | |
{- Convert to BCOs -} | |
; bcos <- coreExprToBCOs hsc_env | |
- (icInteractiveModule (hsc_IC hsc_env)) prepd_expr | |
+ (icInteractiveModule (hsc_IC hsc_env)) | |
+ bco_tmp_id | |
+ stg_expr | |
; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos) | |
, Just mod <- [nameModule_maybe n] -- Names from other modules | |
@@ -1342,3 +1379,16 @@ pathToModuleName = mkModuleName . map rep | |
rep c | isPathSeparator c = '_' | |
rep ':' = '_' | |
rep c = c | |
+ | |
+myCoreToStg :: HscEnv -> Module -> CoreProgram | |
+ -> IO ( [StgTopBinding] -- output program | |
+ , CollectedCCs ) -- CAF cost centre info (declared and used) | |
+myCoreToStg hsc_env this_mod prepd_binds = do | |
+ let (stg_binds, cost_centre_info) | |
+ = {-# SCC "Core2Stg" #-} | |
+ coreToStg (hsc_dflags hsc_env) this_mod prepd_binds | |
+ stg_binds2 | |
+ <- {-# SCC "Stg2Stg" #-} | |
+ stg2stg hsc_env this_mod stg_binds | |
+ | |
+ return (stg_binds2, cost_centre_info) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment