ghc-srcspan-plugin (empty) → 0.1.0.0
raw patch · 4 files changed
+216/−0 lines, 4 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, ghc, hpc
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- ghc-srcspan-plugin.cabal +38/−0
- src/GHC/Plugins/SrcSpan.hs +146/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Galois Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Eric Seidel nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ghc-srcspan-plugin.cabal view
@@ -0,0 +1,38 @@+-- Initial ghc-srcspan-plugin.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: ghc-srcspan-plugin+version: 0.1.0.0+synopsis: Generic GHC Plugin for annotating Haskell code with source+ location data.+description: This package provides a generic Core-to-Core pass for+ annotating Haskell expressions with the original source+ locations, making them available at runtime. + .+ You can use it to build a GHC Plugin tailored to+ your own library by providing a predicate to select+ interesting expressions for annotation and a function to+ annotate the expressions.++license: BSD3+license-file: LICENSE+author: Eric Seidel+maintainer: eseidel@galois.com+copyright: Copyright (c) 2014, Galois Inc.+category: Language+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/GaloisInc/ghc-srcspan-plugin++library+ exposed-modules: GHC.Plugins.SrcSpan+ build-depends: base >= 4.7 && < 5,+ ghc >= 7.8,+ array,+ containers,+ hpc+ hs-source-dirs: src+ default-language: Haskell2010
+ src/GHC/Plugins/SrcSpan.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++-- | This module provides a generic Core-to-Core pass for annotating Haskell+-- expressions with the original source locations. You can use it to build a GHC+-- Plugin tailored to your own library by providing a predicate to select+-- interesting expressions for annotation and a function to annotate the+-- expressions.+--+-- Example usage:+--+-- > module MyPlugin (plugin) where+-- >+-- > import GhcPlugins+-- > import GHC.Plugins.SrcSpan+-- >+-- > plugin :: Plugin+-- > plugin = defaultPlugin { installCoreToDos = install }+-- > +-- > install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+-- > install opts todos = do+-- > reinitializeGlobals+-- > return $ mypass : todos+-- > where+-- > mypass = CoreDoPluginPass "Add Locations" $ mkPass isInteresting annotate False+-- > isInteresting expr = ...+-- > annotate expr = ...+--+-- You will need to coax GHC into adding the source information to the Core via+-- 'Tick's. Currently there are three ways to do this:+-- +-- 1. Load your module in @ghci@.+--+-- 2. Compile your module with @-prof -fprof-auto-calls@. (You can use other+-- profiling options, but that will result in poorer 'Tick' granularity)+--+-- 3. Compile your module with @-fhpc@. Note that this will result in the @hpc@+-- runtime being linked into your program, which is a bit inconvenient. The+-- plugin will prevent this if you pass @True@ instead of @False@ to 'mkPass',+-- but be warned, this will likely break __any__ FFI code your module uses.++module GHC.Plugins.SrcSpan (mkPass) where++import Control.Exception+import Control.Monad+import CostCentre+import qualified Data.Array as Array+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap+import GhcPlugins+import Trace.Hpc.Mix+import Trace.Hpc.Util+++-- | Given a way of identifying "interesting" 'CoreExpr's and annotating them+-- with 'SrcSpan's, construct a Core-to-Core pass that traverses all of the+-- 'CoreBind's and annotates the interesting ones.+mkPass :: (CoreExpr -> CoreM Bool)+ -- ^ Should we annotate this 'CoreExpr'?+ -> (SrcSpan -> CoreExpr -> CoreM CoreExpr)+ -- ^ Annotate the 'CoreExpr' with the 'SrcSpan'.+ -> Bool+ -- ^ Should we remove the @hpc@ hooks from the resulting binary?+ -> ModGuts -> CoreM ModGuts+mkPass isInteresting annotate killForeignStubs guts@(ModGuts {..}) = do+ df <- getDynFlags+ mkLoc <- liftIO $ getSpans df guts++ binds <- mapM (addLocationsBind mkLoc isInteresting annotate) mg_binds++ let stubs = if killForeignStubs+ then NoStubs+ else mg_foreign++ return (guts { mg_binds = binds, mg_foreign = stubs })+++getSpans :: DynFlags -> ModGuts -> IO (Tickish Var -> SrcSpan)+getSpans df ModGuts {..} = do+ let modName = moduleName mg_module+ mixEntries <- getMixEntries modName (hpcDir df) + `catch` \(_ :: SomeException) -> return []+ let hpc = IntMap.fromList $ zip [0..] mixEntries+ let bk = IntMap.fromList $ Array.assocs $ modBreaks_locs mg_modBreaks+ return (tickSpan hpc bk)+++getMixEntries :: ModuleName -> FilePath -> IO [SrcSpan]+getMixEntries nm dir = do+ Mix file _ _ _ entries <- readMix [dir] (Left $ moduleNameString nm)+ let f = fsLit file+ return [ mkSrcSpan (mkSrcLoc f l1 c1) (mkSrcLoc f l2 c2) + | (hpc, _) <- entries, let (l1,c1,l2,c2) = fromHpcPos hpc + ]+++tickSpan :: IntMap SrcSpan -> IntMap SrcSpan -> Tickish Var -> SrcSpan+tickSpan _ _ (ProfNote cc _ _) = cc_loc cc+tickSpan hpc _ (HpcTick _ i) = IntMap.findWithDefault noSrcSpan i hpc+tickSpan _ bk (Breakpoint i _) = IntMap.findWithDefault noSrcSpan i bk+++addLocationsBind :: (Tickish Var -> SrcSpan)+ -> (CoreExpr -> CoreM Bool) + -> (SrcSpan -> CoreExpr -> CoreM CoreExpr) + -> CoreBind -> CoreM CoreBind+addLocationsBind getSpan isInteresting annotate bndr = case bndr of+ NonRec b expr -> NonRec b `liftM` addLocationsExpr getSpan annotate isInteresting expr+ Rec binds -> Rec `liftM` forM binds (secondM $ addLocationsExpr getSpan annotate isInteresting)+++addLocationsExpr :: (Tickish Var -> SrcSpan)+ -> (SrcSpan -> CoreExpr -> CoreM CoreExpr)+ -> (CoreExpr -> CoreM Bool)+ -> CoreExpr -> CoreM CoreExpr+addLocationsExpr getSpan annotate isInteresting = go noSrcSpan+ where+ go ss (Tick t expr) + | isGoodSrcSpan (getSpan t)+ = go (getSpan t) expr+ | otherwise+ = go ss expr+ go ss e@(App expr arg) + = do b <- isInteresting e+ let rest = liftM2 App (go ss expr) (go ss arg)+ if b+ then annotate ss =<< rest+ else rest+ go ss (Lam x expr)+ = liftM (Lam x) (go ss expr)+ go ss (Let bndr expr)+ = liftM2 Let (addLocationsBind getSpan isInteresting annotate bndr) (go ss expr)+ go ss (Case expr x t alts)+ = liftM2 (\e as -> Case e x t as) (go ss expr) (mapM (addLocationsAlt ss) alts)+ go ss (Cast expr c)+ = liftM (`Cast` c) (go ss expr)+ go _ expr+ = return expr++ addLocationsAlt ss (c, xs, expr)+ = (c, xs,) `liftM` go ss expr+++secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c)+secondM f (a, b) = (a,) `liftM` f b