Commit f582379d authored by Alec Theriault's avatar Alec Theriault Committed by Ben Gamari
Browse files

Support generating HIE files

Adds a `-fenable-ide-info` flag which instructs GHC to generate `.hie`
files (see the wiki page:
https://ghc.haskell.org/trac/ghc/wiki/HIEFiles).

This is a rebased version of Zubin Duggal's (@wz1000) GHC changes for
his GSOC project, as posted here:
https://gist.github.com/wz1000/5ed4ddd0d3e96d6bc75e095cef95363d.

Test Plan: ./validate

Reviewers: bgamari, gershomb, nomeata, alanz, sjakobi

Reviewed By: alanz, sjakobi

Subscribers: alanz, hvr, sjakobi, rwbarton, wz1000, carter

Differential Revision: https://phabricator.haskell.org/D5239
parent 21339c9f
......@@ -677,6 +677,7 @@ summariseRequirement pn mod_name = do
env <- getBkpEnv
time <- liftIO $ getModificationUTCTime (bkp_filename env)
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
......@@ -690,6 +691,7 @@ summariseRequirement pn mod_name = do
ms_hs_date = time,
ms_obj_date = Nothing,
ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp,
ms_srcimps = [],
ms_textual_imps = extra_sig_imports,
ms_parsed_mod = Just (HsParsedModule {
......@@ -765,12 +767,13 @@ hsModuleToModSummary pn hsc_src modname
HsSrcFile -> "hs")
-- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocn location0
HsBootFile -> addBootSuffixLocnOut location0
_ -> location0
-- This duplicates a pile of logic in GhcMake
env <- getBkpEnv
time <- liftIO $ getModificationUTCTime (bkp_filename env)
hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-- Also copied from 'getImports'
let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
......@@ -815,7 +818,8 @@ hsModuleToModSummary pn hsc_src modname
}),
ms_hs_date = time,
ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
ms_iface_date = hi_timestamp
ms_iface_date = hi_timestamp,
ms_hie_date = hie_timestamp
}
-- | Create a new, externally provided hashed unit id from
......
......@@ -112,7 +112,8 @@ module Module
-- * The ModuleLocation type
ModLocation(..),
addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn,
addBootSuffix, addBootSuffix_maybe,
addBootSuffixLocn, addBootSuffixLocnOut,
-- * Module mappings
ModuleEnv,
......@@ -267,11 +268,12 @@ data ModLocation
-- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later)
ml_obj_file :: FilePath
ml_obj_file :: FilePath,
-- Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- package with a .a file)
ml_hie_file :: FilePath
} deriving Show
instance Outputable ModLocation where
......@@ -302,7 +304,16 @@ addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
= locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
, ml_hi_file = addBootSuffix (ml_hi_file locn)
, ml_obj_file = addBootSuffix (ml_obj_file locn) }
, ml_obj_file = addBootSuffix (ml_obj_file locn)
, ml_hie_file = addBootSuffix (ml_hie_file locn) }
addBootSuffixLocnOut :: ModLocation -> ModLocation
-- ^ Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut locn
= locn { ml_hi_file = addBootSuffix (ml_hi_file locn)
, ml_obj_file = addBootSuffix (ml_obj_file locn)
, ml_hie_file = addBootSuffix (ml_hie_file locn) }
{-
************************************************************************
......
......@@ -170,6 +170,7 @@ Library
typecheck
types
utils
hieFile
-- we use an explicit Prelude
Default-Extensions:
......@@ -179,6 +180,11 @@ Library
GhcPrelude
Exposed-Modules:
HieTypes
HieDebug
HieBin
HieUtils
HieAst
Ar
FileCleanup
DriverBkp
......
This diff is collapsed.
{-# LANGUAGE ScopedTypeVariables #-}
module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where
import GhcPrelude
import Binary
import BinIface ( getDictFastString )
import FastMutInt
import FastString ( FastString )
import Module ( Module )
import Name
import NameCache
import Outputable
import PrelInfo
import SrcLoc
import UniqSupply ( takeUniqFromSupply )
import Unique
import UniqFM
import qualified Data.Array as A
import Data.IORef
import Data.List ( mapAccumR )
import Data.Word ( Word32 )
import Control.Monad ( replicateM )
-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
-- these two types.
data HieName
= ExternalName !Module !OccName !SrcSpan
| LocalName !OccName !SrcSpan
| KnownKeyName !Unique
deriving (Eq)
instance Ord HieName where
compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
-- Not actually non determinstic as it is a KnownKey
compare ExternalName{} _ = LT
compare LocalName{} ExternalName{} = GT
compare LocalName{} _ = LT
compare KnownKeyName{} _ = GT
instance Outputable HieName where
ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
data HieSymbolTable = HieSymbolTable
{ hie_symtab_next :: !FastMutInt
, hie_symtab_map :: !(IORef (UniqFM (Int, HieName)))
}
data HieDictionary = HieDictionary
{ hie_dict_next :: !FastMutInt -- The next index to use
, hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
}
initBinMemSize :: Int
initBinMemSize = 1024*1024
writeHieFile :: Binary a => FilePath -> a -> IO ()
writeHieFile filename hiefile = do
bh0 <- openBinMem initBinMemSize
-- remember where the dictionary pointer will go
dict_p_p <- tellBin bh0
put_ bh0 dict_p_p
-- remember where the symbol table pointer will go
symtab_p_p <- tellBin bh0
put_ bh0 symtab_p_p
-- Make some intial state
symtab_next <- newFastMutInt
writeFastMutInt symtab_next 0
symtab_map <- newIORef emptyUFM
let hie_symtab = HieSymbolTable {
hie_symtab_next = symtab_next,
hie_symtab_map = symtab_map }
dict_next_ref <- newFastMutInt
writeFastMutInt dict_next_ref 0
dict_map_ref <- newIORef emptyUFM
let hie_dict = HieDictionary {
hie_dict_next = dict_next_ref,
hie_dict_map = dict_map_ref }
-- put the main thing
let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
(putName hie_symtab)
(putFastString hie_dict)
put_ bh hiefile
-- write the symtab pointer at the front of the file
symtab_p <- tellBin bh
putAt bh symtab_p_p symtab_p
seekBin bh symtab_p
-- write the symbol table itself
symtab_next' <- readFastMutInt symtab_next
symtab_map' <- readIORef symtab_map
putSymbolTable bh symtab_next' symtab_map'
-- write the dictionary pointer at the fornt of the file
dict_p <- tellBin bh
putAt bh dict_p_p dict_p
seekBin bh dict_p
-- write the dictionary itself
dict_next <- readFastMutInt dict_next_ref
dict_map <- readIORef dict_map_ref
putDictionary bh dict_next dict_map
-- and send the result to the file
writeBinMem bh filename
return ()
readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)
readHieFile nc file = do
bh0 <- readBinMem file
dict <- get_dictionary bh0
-- read the symbol table so we are capable of reading the actual data
(bh1, nc') <- do
let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
(getDictFastString dict)
(nc', symtab) <- get_symbol_table bh1
let bh1' = setUserData bh1
$ newReadState (getSymTabName symtab)
(getDictFastString dict)
return (bh1', nc')
-- load the actual data
hiefile <- get bh1
return (hiefile, nc')
where
get_dictionary bin_handle = do
dict_p <- get bin_handle
data_p <- tellBin bin_handle
seekBin bin_handle dict_p
dict <- getDictionary bin_handle
seekBin bin_handle data_p
return dict
get_symbol_table bh1 = do
symtab_p <- get bh1
data_p' <- tellBin bh1
seekBin bh1 symtab_p
(nc', symtab) <- getSymbolTable bh1 nc
seekBin bh1 data_p'
return (nc', symtab)
putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
putFastString HieDictionary { hie_dict_next = j_r,
hie_dict_map = out_r} bh f
= do
out <- readIORef out_r
let unique = getUnique f
case lookupUFM out unique of
Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out unique (j, f)
putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
putSymbolTable bh next_off symtab = do
put_ bh next_off
let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
mapM_ (putHieName bh) names
getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)
getSymbolTable bh namecache = do
sz <- get bh
od_names <- replicateM sz (getHieName bh)
let arr = A.listArray (0,sz-1) names
(namecache', names) = mapAccumR fromHieName namecache od_names
return (namecache', arr)
getSymTabName :: SymbolTable -> BinHandle -> IO Name
getSymTabName st bh = do
i :: Word32 <- get bh
return $ st A.! (fromIntegral i)
putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
putName (HieSymbolTable next ref) bh name = do
symmap <- readIORef ref
case lookupUFM symmap name of
Just (off, ExternalName mod occ (UnhelpfulSpan _))
| isGoodSrcSpan (nameSrcSpan name) -> do
let hieName = ExternalName mod occ (nameSrcSpan name)
writeIORef ref $! addToUFM symmap name (off, hieName)
put_ bh (fromIntegral off :: Word32)
Just (off, LocalName _occ span)
| notLocal (toHieName name) || nameSrcSpan name /= span -> do
writeIORef ref $! addToUFM symmap name (off, toHieName name)
put_ bh (fromIntegral off :: Word32)
Just (off, _) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt next
writeFastMutInt next (off+1)
writeIORef ref $! addToUFM symmap name (off, toHieName name)
put_ bh (fromIntegral off :: Word32)
where
notLocal :: HieName -> Bool
notLocal LocalName{} = False
notLocal _ = True
-- ** Converting to and from `HieName`'s
toHieName :: Name -> HieName
toHieName name
| isKnownKeyName name = KnownKeyName (nameUnique name)
| isExternalName name = ExternalName (nameModule name)
(nameOccName name)
(nameSrcSpan name)
| otherwise = LocalName (nameOccName name) (nameSrcSpan name)
fromHieName :: NameCache -> HieName -> (NameCache, Name)
fromHieName nc (ExternalName mod occ span) =
let cache = nsNames nc
in case lookupOrigNameCache cache mod occ of
Just name -> (nc, name)
Nothing ->
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
name = mkExternalName uniq mod occ span
new_cache = extendNameCache cache mod occ name
in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
fromHieName nc (LocalName occ span) =
let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
name = mkInternalName uniq occ span
in ( nc{ nsUniqs = us }, name )
fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
Nothing -> pprPanic "fromHieName:unknown known-key unique"
(ppr (unpkUnique u))
Just n -> (nc, n)
-- ** Reading and writing `HieName`'s
putHieName :: BinHandle -> HieName -> IO ()
putHieName bh (ExternalName mod occ span) = do
putByte bh 0
put_ bh (mod, occ, span)
putHieName bh (LocalName occName span) = do
putByte bh 1
put_ bh (occName, span)
putHieName bh (KnownKeyName uniq) = do
putByte bh 2
put_ bh $ unpkUnique uniq
getHieName :: BinHandle -> IO HieName
getHieName bh = do
t <- getByte bh
case t of
0 -> do
(modu, occ, span) <- get bh
return $ ExternalName modu occ span
1 -> do
(occ, span) <- get bh
return $ LocalName occ span
2 -> do
(c,i) <- get bh
return $ KnownKeyName $ mkUnique c i
_ -> panic "HieBin.getHieName: invalid tag"
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module HieDebug where
import GhcPrelude
import SrcLoc
import Module
import FastString
import Outputable
import HieTypes
import HieBin
import HieUtils
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Function ( on )
import Data.List ( sortOn )
import Data.Foldable ( toList )
ppHies :: Outputable a => (HieASTs a) -> SDoc
ppHies (HieASTs asts) = M.foldrWithKey go "" asts
where
go k a rest = vcat $
[ "File: " <> ppr k
, ppHie a
, rest
]
ppHie :: Outputable a => HieAST a -> SDoc
ppHie = go 0
where
go n (Node inf sp children) = hang header n rest
where
rest = vcat $ map (go (n+2)) children
header = hsep
[ "Node"
, ppr sp
, ppInfo inf
]
ppInfo :: Outputable a => NodeInfo a -> SDoc
ppInfo ni = hsep
[ ppr $ toList $ nodeAnnotations ni
, ppr $ nodeType ni
, ppr $ M.toList $ nodeIdentifiers ni
]
type Diff a = a -> a -> [SDoc]
diffFile :: Diff HieFile
diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))
diffAsts f = diffList (diffAst f) `on` M.elems
diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)
diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
where
spanDiff
| span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
| otherwise = []
infoDiff
= (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
++ (diffList diffType `on` nodeType) info1 info2
++ (diffIdents `on` nodeIdentifiers) info1 info2
diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
diffIdent (a,b) (c,d) = diffName a c
++ eqDiff b d
diffName (Right a) (Right b) = case (a,b) of
(ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')
(LocalName o _, ExternalName _ o' _) -> eqDiff o o'
_ -> eqDiff a b
diffName a b = eqDiff a b
type DiffIdent = Either ModuleName HieName
normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
normalizeIdents = sortOn fst . map (first toHieName) . M.toList
where
first f (a,b) = (fmap f a, b)
diffList :: Diff a -> Diff [a]
diffList f xs ys
| length xs == length ys = concat $ zipWith f xs ys
| otherwise = ["length of lists doesn't match"]
eqDiff :: (Outputable a, Eq a) => Diff a
eqDiff a b
| a == b = []
| otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]
validAst :: HieAST a -> Either SDoc ()
validAst (Node _ span children) = do
checkContainment children
checkSorted children
mapM_ validAst children
where
checkSorted [] = return ()
checkSorted [_] = return ()
checkSorted (x:y:xs)
| nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)
| otherwise = Left $ hsep
[ ppr $ nodeSpan x
, "is not to the left of"
, ppr $ nodeSpan y
]
checkContainment [] = return ()
checkContainment (x:xs)
| span `containsSpan` (nodeSpan x) = checkContainment xs
| otherwise = Left $ hsep
[ ppr $ span
, "does not contain"
, ppr $ nodeSpan x
]
-- | Look for any identifiers which occur outside of their supposed scopes.
-- Returns a list of error messages.
validateScopes :: M.Map FastString (HieAST a) -> [SDoc]
validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
where
refMap = generateReferencesMap asts
valid (Left _) _ = []
valid (Right n) refs = concatMap inScope refs
where
mapRef = foldMap getScopeFromContext . identInfo . snd
scopes = case foldMap mapRef refs of
Just xs -> xs
Nothing -> []
inScope (sp, dets)
| definedInAsts asts n
&& any isOccurrence (identInfo dets)
= case scopes of
[] -> []
_ -> if any (`scopeContainsSpan` sp) scopes
then []
else return $ hsep $
[ "Name", ppr n, "at position", ppr sp
, "doesn't occur in calculated scope", ppr scopes]
| otherwise = []
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HieTypes where
import GhcPrelude
import Binary
import FastString ( FastString )
import IfaceType
import Module ( ModuleName )
import Name ( Name )
import Outputable hiding ( (<>) )
import SrcLoc ( RealSrcSpan )
import qualified Data.Array as A
import qualified Data.Map as M
import qualified Data.Set as S
import Data.ByteString ( ByteString )
import Data.Data ( Typeable, Data )
import Data.Semigroup ( Semigroup(..) )
import Data.Word ( Word8 )
import Control.Applicative ( (<|>) )
type Span = RealSrcSpan
-- | Current version of @.hie@ files
curHieVersion :: Word8
curHieVersion = 0
{- |
GHC builds up a wealth of information about Haskell source as it compiles it.
@.hie@ files are a way of persisting some of this information to disk so that
external tools that need to work with haskell source don't need to parse,
typecheck, and rename all over again. These files contain:
* a simplified AST
* nodes are annotated with source positions and types
* identifiers are annotated with scope information
* the raw bytes of the initial Haskell source
Besides saving compilation cycles, @.hie@ files also offer a more stable
interface than the GHC API.
-}
data HieFile = HieFile
{ hie_version :: Word8
-- ^ version of the HIE format
, hie_ghc_version :: ByteString
-- ^ Version of GHC that produced this file
, hie_hs_file :: FilePath
-- ^ Initial Haskell source file path
, hie_types :: A.Array TypeIndex HieTypeFlat
-- ^ Types referenced in the 'hie_asts'.
--
-- See Note [Efficient serialization of redundant type info]
, hie_asts :: HieASTs TypeIndex
-- ^ Type-annotated abstract syntax trees
, hie_hs_src :: ByteString
-- ^ Raw bytes of the initial Haskell source
}
instance Binary HieFile where
put_ bh hf = do
put_ bh $ hie_version hf
put_ bh $ hie_ghc_version hf
put_ bh $ hie_hs_file hf
put_ bh $ hie_types hf
put_ bh $ hie_asts hf
put_ bh $ hie_hs_src hf
get bh = HieFile
<$> get bh
<*> get bh