Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 99adce0

Browse files
add Stg.Tickish utility module to collect source locations for STG IR points
1 parent 58c3d35 commit 99adce0

File tree

3 files changed

+89
-0
lines changed

3 files changed

+89
-0
lines changed

‎external-stg/app/stgapp.hs‎

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ modes = subparser
4444
<> mode "undef" undefMode (progDesc "print list of undefined foreign symbols")
4545
<> mode "link" linkMode (progDesc "link cbits.so for the applications with used foreign functions")
4646
<> mode "hi-list" hiListMode (progDesc "whole program interface file list")
47+
<> mode "srcpaths" srcpathMode (progDesc "print module source filepaths")
4748
)
4849
where
4950
mode :: String -> Parser a -> InfoMod a -> Mod CommandFields a
@@ -209,5 +210,32 @@ modes = subparser
209210
True -> printf "OK: %s\n" modModuleName
210211
False -> printf "MISSING: %s\n" hiName
211212

213+
srcpathMode :: Parser (IO ())
214+
srcpathMode =
215+
run <$> fullpakFile
216+
where
217+
run fname = do
218+
moduleList <- loadModules fname
219+
-- print source filepaths
220+
forM_ moduleList $ \m -> case moduleSourceFilePath m of
221+
Nothing -> pure ()
222+
Just srcPath -> printf "source filepath: %s %s %s\n"
223+
(BS8.unpack $ getUnitId $ moduleUnitId m)
224+
(BS8.unpack $ getModuleName $ moduleName m)
225+
(BS8.unpack srcPath)
226+
227+
-- report empty moduleSourceFilePath
228+
forM_ [m | m <- moduleList, isNothing $ moduleSourceFilePath m] $ \m -> do
229+
printf "missing source filepath for: %s %s\n" (BS8.unpack $ getUnitId $ moduleUnitId m) (BS8.unpack $ getModuleName $ moduleName m)
230+
231+
-- report ambiguous moduleSourceFilePath
232+
let moduleMaps = [Map.singleton srcPath (1, [m]) | m <- moduleList, srcPath <- maybeToList $ moduleSourceFilePath m]
233+
duplicates = Map.filter (\(n, _) -> n > 1) $ Map.unionsWith (\(n1, l1) (n2, l2) -> (n1 + n2, l1 ++ l2)) moduleMaps
234+
forM_ (Map.toList duplicates) $ \(srcPath, (_, mods)) -> forM_ mods $ \m -> do
235+
printf "duplicate source filepath: %s %s %s\n"
236+
(BS8.unpack $ getUnitId $ moduleUnitId m)
237+
(BS8.unpack $ getModuleName $ moduleName m)
238+
(BS8.unpack srcPath)
239+
212240
main :: IO ()
213241
main = join $ execParser $ info (helper <*> modes) mempty

‎external-stg/external-stg.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ library
1616
exposed-modules:
1717
Stg.Pretty
1818
Stg.IRLocation
19+
Stg.Tickish
1920
Stg.Reconstruct
2021
Stg.Deconstruct
2122
Stg.Fullpak

‎external-stg/lib/Stg/Tickish.hs‎

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
module Stg.Tickish where
3+
4+
import Control.Monad.RWS hiding (Alt)
5+
6+
import Stg.Syntax
7+
import Stg.IRLocation
8+
9+
type M = RWS (Maybe StgPoint) [(StgPoint, Tickish)] ()
10+
11+
withStgPoint :: StgPoint -> M () -> M ()
12+
withStgPoint sp = local (const $ Just sp)
13+
14+
getStgPoint :: M StgPoint
15+
getStgPoint = ask >>= \case
16+
Nothing -> error "missing stg point"
17+
Just sp -> pure sp
18+
19+
visitTopBinding :: TopBinding -> M ()
20+
visitTopBinding = \case
21+
StgTopLifted b -> visitBinding b
22+
StgTopStringLit{} -> pure ()
23+
24+
visitBinding :: Binding -> M ()
25+
visitBinding = \case
26+
StgNonRec b r -> visitRhs b r
27+
StgRec bs -> mapM_ (uncurry visitRhs) bs
28+
29+
visitRhs :: Binder -> Rhs -> M ()
30+
visitRhs rhsBinder = \case
31+
StgRhsClosure _ _ _ e -> withStgPoint (SP_RhsClosureExpr $ Id rhsBinder) $ visitExpr e
32+
StgRhsCon{} -> pure ()
33+
34+
visitExpr :: Expr -> M ()
35+
visitExpr expr = do
36+
stgPoint <- getStgPoint
37+
case expr of
38+
StgLit{} -> pure ()
39+
StgApp{} -> pure ()
40+
StgOpApp{} -> pure ()
41+
StgConApp{} -> pure ()
42+
StgCase x b _ alts -> do
43+
withStgPoint (SP_CaseScrutineeExpr $ Id b) $ visitExpr x
44+
sequence_ [visitAlt (Id b) idx a | (idx, a) <- zip [0..] alts]
45+
StgLet b e -> do
46+
visitBinding b
47+
withStgPoint (SP_LetExpr stgPoint) $ visitExpr e
48+
StgLetNoEscape b e -> do
49+
visitBinding b
50+
withStgPoint (SP_LetNoEscapeExpr stgPoint) $ visitExpr e
51+
StgTick tickish e -> do
52+
tell [(stgPoint, tickish)]
53+
visitExpr e
54+
55+
visitAlt :: Id -> Int -> Alt -> M ()
56+
visitAlt scrutId idx (Alt _con _bndrs rhs) = do
57+
withStgPoint (SP_AltExpr scrutId idx) $ visitExpr rhs
58+
59+
collectTickish :: Module -> [(StgPoint, Tickish)]
60+
collectTickish m = snd $ evalRWS (mapM_ visitTopBinding $ moduleTopBindings m) Nothing ()

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /