Advertisement
Guest User

Untitled

a guest
Jun 26th, 2019
76
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 11.38 KB | None | 0 0
  1. diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal
  2. index 2bfef74f..bb1eb1f7 100644
  3. --- a/haskell-ide-engine.cabal
  4. +++ b/haskell-ide-engine.cabal
  5. @@ -114,7 +114,7 @@ executable hie
  6. , hie-plugin-api
  7. , hslogger
  8. , optparse-simple
  9. - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
  10. + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints -g3 -debug
  11. -with-rtsopts=-T
  12. if flag(pedantic)
  13. ghc-options: -Werror
  14. @@ -140,6 +140,15 @@ executable hie-wrapper
  15. ghc-options: -Werror
  16. default-language: Haskell2010
  17.  
  18. +executable leak-test
  19. + hs-source-dirs: leak-test
  20. + main-is: Main.hs
  21. + build-tool-depends: haskell-ide-engine:hie
  22. + build-depends: base
  23. + , lsp-test == 0.5.3.*
  24. + ghc-options: -g3 -debug
  25. + default-language: Haskell2010
  26. +
  27. library hie-test-utils
  28. hs-source-dirs: test/utils
  29. exposed-modules: TestUtils
  30. diff --git a/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs b/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs
  31. index 65f2b2b2..a6ab419b 100644
  32. --- a/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs
  33. +++ b/hie-plugin-api/Haskell/Ide/Engine/Ghc.hs
  34. @@ -226,7 +226,8 @@ setTypecheckedModule_load uri =
  35. canonUri <- canonicalizeUri uri
  36. let diags = Map.insertWith Set.union canonUri Set.empty diags'
  37. debugm "setTypecheckedModule: after ghc-mod"
  38. - debugm ("Diags: " <> show diags')
  39. + debugm ("Diags': " <> show diags')
  40. + debugm ("Diags: " <> show diags)
  41. let collapse Nothing = (Nothing, [])
  42. collapse (Just (n, xs)) = (n, xs)
  43.  
  44. @@ -251,15 +252,15 @@ setTypecheckedModule_load uri =
  45.  
  46. (Nothing, ts) -> do
  47. debugm $ "setTypecheckedModule: Didn't get typechecked or parsed module for: " ++ show fp
  48. - --debugm $ "setTypecheckedModule: errs: " ++ show errs
  49. + debugm $ "setTypecheckedModule: diags': " ++ show diags'
  50. cacheModules rfm ts
  51. failModule fp
  52.  
  53. - let sev = Just DsError
  54. - range = Range (Position 0 0) (Position 1 0)
  55. - msgTxt = T.unlines errs
  56. - let d = Diagnostic range sev Nothing (Just "bios") msgTxt Nothing
  57. - return $ Map.insertWith Set.union canonUri (Set.singleton d) diags
  58. + -- let sev = Just DsError
  59. + -- range = Range (Position 0 0) (Position 1 0)
  60. + -- msgTxt = T.unlines errs
  61. + -- let d = Diagnostic range sev Nothing (Just "bios") msgTxt Nothing
  62. + return diags'
  63.  
  64. return $ IdeResultOk (diags2,errs)
  65.  
  66. diff --git a/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs
  67. index a77de7fd..d7078f39 100644
  68. --- a/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs
  69. +++ b/hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs
  70. @@ -23,12 +23,24 @@ import Haskell.Ide.Engine.ArtifactMap
  71.  
  72. import Language.Haskell.LSP.Types
  73. import Debug.Trace
  74. +import System.Mem.Weak
  75. +import System.IO
  76. +
  77. +data Leakable = Leakable
  78. + { leakableTcMod :: Weak (Maybe TypecheckedModule)
  79. + , leakablePsMod :: Weak ParsedModule
  80. + }
  81. +
  82. +mkLeakable :: UriCache -> IO UriCacheResult
  83. +mkLeakable uc@(UriCache { cachedTcMod = tcmod, cachedPsMod = psmod }) = do
  84. + tcptr <- mkWeakPtr tcmod (Just (hPutStrLn stderr "garbage collected typechecked module"))
  85. + psptr <- mkWeakPtr psmod (Just (hPutStrLn stderr "garbage collected parsed module"))
  86. + return (UriCacheSuccess (Leakable tcptr psptr) uc)
  87.  
  88. type UriCaches = Map.Map FilePath UriCacheResult
  89.  
  90. -data UriCacheResult = UriCacheSuccess UriCache
  91. +data UriCacheResult = UriCacheSuccess Leakable UriCache
  92. | UriCacheFailed
  93. - deriving (Show)
  94.  
  95. uriCacheState :: UriCacheResult -> String
  96. uriCacheState UriCacheFailed = "UriCacheFailed"
  97. @@ -119,6 +131,9 @@ data GhcModuleCache = GhcModuleCache
  98. , currentCradle :: Maybe ([FilePath], BIOS.Cradle)
  99. -- ^ The current cradle and which directories it is
  100. -- responsible for
  101. - } deriving (Show)
  102. + }
  103. +
  104. +instance Show GhcModuleCache where
  105. + show _ = "ghcmodulecache"
  106.  
  107. -- ---------------------------------------------------------------------
  108. diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs
  109. index 3fc8b4ec..3bf08aa5 100644
  110. --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs
  111. +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs
  112. @@ -52,6 +52,10 @@ import Haskell.Ide.Engine.GhcModuleCache
  113. import Haskell.Ide.Engine.MultiThreadState
  114. import Haskell.Ide.Engine.PluginsIdeMonads
  115. import Haskell.Ide.Engine.GhcUtils
  116. +
  117. +import System.Mem
  118. +import System.Mem.Weak
  119. +import System.IO
  120. -- ---------------------------------------------------------------------
  121.  
  122. modifyCache :: (HasGhcModuleCache m) => (GhcModuleCache -> GhcModuleCache) -> m ()
  123. @@ -133,12 +137,12 @@ ifCachedInfo :: (HasGhcModuleCache m, MonadIO m) => FilePath -> a -> (CachedInfo
  124. ifCachedInfo fp def callback = do
  125. muc <- getUriCache fp
  126. case muc of
  127. - Just (UriCacheSuccess uc) -> callback (cachedInfo uc)
  128. + Just (UriCacheSuccess _ uc) -> callback (cachedInfo uc)
  129. _ -> return def
  130.  
  131. withCachedInfo :: FilePath -> a -> (CachedInfo -> IdeDeferM a) -> IdeDeferM a
  132. withCachedInfo fp def callback = deferIfNotCached fp go
  133. - where go (UriCacheSuccess uc) = callback (cachedInfo uc)
  134. + where go (UriCacheSuccess _ uc) = callback (cachedInfo uc)
  135. go UriCacheFailed = return def
  136.  
  137. ifCachedModule :: (HasGhcModuleCache m, MonadIO m, CacheableModule b) => FilePath -> a -> (b -> CachedInfo -> m a) -> m a
  138. @@ -157,7 +161,7 @@ ifCachedModuleM fp k callback = do
  139. let x = do
  140. res <- muc
  141. case res of
  142. - UriCacheSuccess uc -> do
  143. + UriCacheSuccess _ uc -> do
  144. let ci = cachedInfo uc
  145. cm <- fromUriCache uc
  146. return (ci, cm)
  147. @@ -176,7 +180,7 @@ ifCachedModuleAndData :: forall a b m. (ModuleCache a, HasGhcModuleCache m, Mona
  148. ifCachedModuleAndData fp def callback = do
  149. muc <- getUriCache fp
  150. case muc of
  151. - Just (UriCacheSuccess uc@(UriCache info _ (Just tm) dat _)) ->
  152. + Just (UriCacheSuccess _ uc@(UriCache info _ (Just tm) dat _)) ->
  153. case fromUriCache uc of
  154. Just modul -> lookupCachedData fp tm info dat >>= callback modul (cachedInfo uc)
  155. Nothing -> return def
  156. @@ -191,7 +195,7 @@ ifCachedModuleAndData fp def callback = do
  157. -- see also 'ifCachedModule'.
  158. withCachedModule :: CacheableModule b => FilePath -> a -> (b -> CachedInfo -> IdeDeferM a) -> IdeDeferM a
  159. withCachedModule fp def callback = deferIfNotCached fp go
  160. - where go (UriCacheSuccess uc@(UriCache _ _ _ _ _)) =
  161. + where go (UriCacheSuccess _ uc@(UriCache _ _ _ _ _)) =
  162. case fromUriCache uc of
  163. Just modul -> callback modul (cachedInfo uc)
  164. Nothing -> wrap (Defer fp go)
  165. @@ -209,9 +213,9 @@ withCachedModuleAndData :: forall a b. (ModuleCache a)
  166. => FilePath -> b
  167. -> (GHC.TypecheckedModule -> CachedInfo -> a -> IdeDeferM b) -> IdeDeferM b
  168. withCachedModuleAndData fp def callback = deferIfNotCached fp go
  169. - where go (UriCacheSuccess (uc@(UriCache info _ (Just tm) dat _))) =
  170. + where go (UriCacheSuccess _ (uc@(UriCache info _ (Just tm) dat _))) =
  171. lookupCachedData fp tm info dat >>= callback tm (cachedInfo uc)
  172. - go (UriCacheSuccess (UriCache { cachedTcMod = Nothing })) = wrap (Defer fp go)
  173. + go (UriCacheSuccess l (UriCache { cachedTcMod = Nothing })) = wrap (Defer fp go)
  174. go UriCacheFailed = return def
  175.  
  176. getUriCache :: (HasGhcModuleCache m, MonadIO m) => FilePath -> m (Maybe UriCacheResult)
  177. @@ -223,7 +227,7 @@ getUriCache fp = do
  178. Nothing -> return Nothing
  179.  
  180. checkModuleHash :: FilePath -> UriCacheResult -> IO (Maybe UriCacheResult)
  181. -checkModuleHash fp r@(UriCacheSuccess uri_res) = do
  182. +checkModuleHash fp r@(UriCacheSuccess _ uri_res) = do
  183. cur_hash <- hashModule fp
  184. return $ if cachedHash uri_res == cur_hash
  185. then Just r
  186. @@ -249,7 +253,8 @@ lookupCachedData fp tm info dat = do
  187. h <- liftIO $ hashModule canonical_fp
  188. let dat' = Map.insert (typeOf val) (toDyn val) dat
  189. newUc = UriCache info (GHC.tm_parsed_module tm) (Just tm) dat' h
  190. - modifyCache (\s -> s {uriCaches = Map.insert canonical_fp (UriCacheSuccess newUc)
  191. + res <- liftIO $ mkLeakable newUc
  192. + modifyCache (\s -> s {uriCaches = Map.insert canonical_fp res
  193. (uriCaches s)})
  194. return val
  195.  
  196. @@ -279,7 +284,7 @@ cacheModule fp modul = do
  197. muc <- getUriCache canonical_fp
  198. let defInfo = CachedInfo mempty mempty mempty mempty rfm return return
  199. return $ case muc of
  200. - Just (UriCacheSuccess uc) ->
  201. + Just (UriCacheSuccess _ uc) ->
  202. let newCI = (cachedInfo uc) { revMap = rfm }
  203. in uc { cachedPsMod = pm, cachedInfo = newCI, cachedHash = fp_hash }
  204. _ -> UriCache defInfo pm Nothing mempty fp_hash
  205. @@ -290,10 +295,24 @@ cacheModule fp modul = do
  206. pm = GHC.tm_parsed_module tm
  207. return $ UriCache info pm (Just tm) mempty fp_hash
  208.  
  209. - let res = UriCacheSuccess newUc
  210. + res <- liftIO $ mkLeakable newUc
  211. +
  212. + maybeOldUc <- (Map.lookup canonical_fp . uriCaches) <$> getModuleCache
  213. +
  214. modifyCache $ \gmc ->
  215. gmc { uriCaches = Map.insert canonical_fp res (uriCaches gmc) }
  216.  
  217. + liftIO $ hPutStrLn stderr "cacheModule"
  218. + -- check leaks
  219. + case maybeOldUc of
  220. + Just (UriCacheSuccess (Leakable tcptr psptr) _) -> do
  221. + liftIO performGC
  222. + res <- liftIO $ deRefWeak tcptr
  223. + case res of
  224. + Just _ -> error $ "leaking: " <> canonical_fp
  225. + Nothing -> error $ "not leaking: " <> canonical_fp
  226. + Nothing -> return ()
  227. +
  228. -- execute any queued actions for the module
  229. runDeferredActions canonical_fp res
  230.  
  231. @@ -345,14 +364,24 @@ cacheInfoNoClear uri ci = do
  232. )
  233. where
  234. updateCachedInfo :: UriCacheResult -> UriCacheResult
  235. - updateCachedInfo (UriCacheSuccess old) = UriCacheSuccess (old { cachedInfo = ci })
  236. + updateCachedInfo (UriCacheSuccess l old) = UriCacheSuccess l (old { cachedInfo = ci })
  237. updateCachedInfo UriCacheFailed = UriCacheFailed
  238.  
  239. -- | Deletes a module from the cache
  240. deleteCachedModule :: (MonadIO m, HasGhcModuleCache m) => FilePath -> m ()
  241. deleteCachedModule uri = do
  242. uri' <- liftIO $ canonicalizePath uri
  243. + mucr <- (Map.lookup uri' . uriCaches) <$> getModuleCache
  244. + liftIO $ hPutStrLn stderr "deleteCachedModule"
  245. + let (Leakable tcptr psptr) = case mucr of
  246. + Just (UriCacheSuccess l _) -> l
  247. + _ -> error "deleteCachedModule: nothing to delete"
  248. modifyCache (\s -> s { uriCaches = Map.delete uri' (uriCaches s) })
  249. + liftIO performGC
  250. + res <- liftIO $ deRefWeak tcptr
  251. + case res of
  252. + Just _ -> error $ "leaking: " <> uri'
  253. + Nothing -> error $ "not leaking: " <> uri'
  254.  
  255. -- ---------------------------------------------------------------------
  256. -- | A ModuleCache is valid for the lifetime of a CachedModule
  257. diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal
  258. index 8122cab6..4e2b560a 100644
  259. --- a/hie-plugin-api/hie-plugin-api.cabal
  260. +++ b/hie-plugin-api/hie-plugin-api.cabal
  261. @@ -67,7 +67,7 @@ library
  262. build-depends: Win32
  263. else
  264. build-depends: unix
  265. - ghc-options: -Wall
  266. + ghc-options: -Wall -g3 -debug
  267. if flag(pedantic)
  268. ghc-options: -Werror
  269. default-language: Haskell2010
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement