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 8ba2ab4

Browse files
print stg tickish optionally
1 parent 99adce0 commit 8ba2ab4

File tree

3 files changed

+64
-29
lines changed

3 files changed

+64
-29
lines changed

‎external-stg/app/ext-stg.hs‎

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ import Data.List
33

44
import Options.Applicative
55
import qualified Data.ByteString.Lazy as BSL
6+
import qualified Data.Text.IO as T
67

78
import Stg.Pretty
89
import Stg.IO
@@ -20,14 +21,17 @@ modes = subparser
2021

2122
showMode :: Parser (IO ())
2223
showMode =
23-
run <$> modpakFile
24+
run <$> modpakFile<*> switch (long "hide-tickish"<> help "do not print STG IR Tickish annotation")
2425
where
25-
run fname = do
26+
run fname hideTickish = do
2627
dump <- case () of
2728
_ | isSuffixOf "modpak" fname -> Stg.IO.readModpakL fname modpakStgbinPath decodeStgbin
2829
_ | isSuffixOf "stgbin" fname -> decodeStgbin <$> BSL.readFile fname
2930
_ -> fail "unknown file format"
30-
putStrLn . fst . pShowS $ pprModule dump
31+
let cfg = Config
32+
{ cfgPrintTickish = not hideTickish
33+
}
34+
T.putStrLn . fst . pShowWithConfig cfg $ pprModule dump
3135

3236
main :: IO ()
3337
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
@@ -62,6 +62,7 @@ executable ext-stg
6262
external-stg-syntax,
6363
ansi-wl-pprint,
6464
bytestring,
65+
text,
6566
optparse-applicative
6667
default-language: Haskell2010
6768

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

Lines changed: 56 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -23,15 +23,13 @@ import Control.Monad.Reader
2323
import Control.Monad.Writer hiding (Alt)
2424
import Control.Monad.State
2525
import Control.Monad.RWS hiding (Alt)
26+
import Data.Maybe
2627
import Data.Foldable
2728
import Data.String (IsString(..))
2829
import Data.Text (Text)
2930
import qualified Data.Text as T
3031
import qualified Data.Text.IO as TIO
3132

32-
import Data.Map (Map)
33-
import qualified Data.Map as Map
34-
3533
import Stg.Syntax
3634
import Stg.IRLocation
3735

@@ -104,7 +102,7 @@ code
104102
-}
105103

106104
getStgPoint :: DocM StgPoint
107-
getStgPoint = askEnv >>= \case
105+
getStgPoint = (speStgPoint <$>askEnv) >>= \case
108106
Nothing -> error "missing stg point"
109107
Just sp -> pure sp
110108
---------------------------------------------------------
@@ -125,21 +123,25 @@ state0 = PState
125123
{ curLine = []
126124
}
127125

128-
{-
126+
data Config
127+
= Config
128+
{ cfgPrintTickish :: Bool
129+
}
130+
129131
data SPEnv
130132
= SPEnv
131-
{ speParent :: Maybe StgPoint
132-
, speBinderName :: Maybe Name
133-
, speScrutineeName :: Maybe Name
134-
} Maybe StgPoint
135-
-}
136-
type SPEnv = Maybe StgPoint
133+
{ speStgPoint :: Maybe StgPoint
134+
, speConfig :: Config
135+
}
137136

138137
withStgPoint :: StgPoint -> Doc -> Doc
139-
withStgPoint sp = localEnv (const$Just sp)
138+
withStgPoint sp = localEnv (\env -> env {speStgPoint =Just sp})
140139

141-
spEnv0 :: SPEnv
142-
spEnv0 = Nothing
140+
spEnv0 :: Config -> SPEnv
141+
spEnv0 cfg = SPEnv
142+
{ speStgPoint = Nothing
143+
, speConfig = cfg
144+
}
143145

144146

145147
-- For plain text pretty printing
@@ -161,9 +163,9 @@ instance IsString (DocM ()) where
161163
runDocM :: PEnv Int StgPoint () -> SPEnv -> PState Int () -> DocM a -> Maybe (PState Int (), POut Int StgPoint, a)
162164
runDocM e spe s d = (\(a,s',o) -> (s',o,a)) <$> runRWST (runEnvT spe $ unDocM d) e s
163165

164-
execDoc :: Doc -> POut Int StgPoint
165-
execDoc d =
166-
let rM = runDocM env0 spEnv0 state0 d
166+
execDoc :: Config->Doc -> POut Int StgPoint
167+
execDoc cfg d =
168+
let rM = runDocM env0 (spEnv0 cfg) state0 d
167169
in case rM of
168170
Nothing -> PAtom $ AChunk $ CText "<internal pretty printing error>"
169171
Just (_, o, ()) -> o
@@ -319,10 +321,6 @@ instance Pretty AltType where
319321
PrimAlt r -> text "PrimAlt" <+> ppPrimRep r
320322
AlgAlt tc -> text "AlgAlt" <+> ppTyConName tc
321323

322-
instance Pretty Binder where
323-
pretty = pprBinder
324-
325-
326324
pprAlt :: Id -> Int -> Alt -> Doc
327325
pprAlt scrutId idx (Alt con bndrs rhs) =
328326
(hsep (pretty con : map (pprBinder) bndrs) <+> text "-> do") <$$>
@@ -388,6 +386,23 @@ putDefaultLast :: [Alt] -> [Doc] -> [Doc]
388386
putDefaultLast (Alt AltDefault _ _ : _) (first : rest) = rest ++ [first]
389387
putDefaultLast _ l = l
390388

389+
pprRealSrcSpan :: RealSrcSpan -> Doc
390+
pprRealSrcSpan RealSrcSpan'{..} = pretty srcSpanFile <+> pprPos srcSpanSLine srcSpanSCol <> text "-" <> pprPos srcSpanELine srcSpanECol
391+
where pprPos line col = parens $ pretty line <> text ":" <> pretty col
392+
393+
instance Pretty RealSrcSpan where
394+
pretty = pprRealSrcSpan
395+
396+
pprTickish :: Tickish -> Doc
397+
pprTickish = \case
398+
ProfNote -> text "-- ProfNote"
399+
HpcTick -> text "-- HpcTick"
400+
Breakpoint -> text "-- Breakpoint"
401+
SourceNote{..} -> text "-- SourceNote for" <+> pretty sourceName <+> pretty sourceSpan
402+
403+
instance Pretty Tickish where
404+
pretty = pprTickish
405+
391406
pprExpr :: Expr -> Doc
392407
pprExpr exp = do
393408
stgPoint <- getStgPoint
@@ -419,7 +434,11 @@ pprExpr exp = do
419434
[ text "-- stack allocating let"
420435
, text "let" <+> (align $ pprBinding b) <$$> align (withStgPoint (SP_LetNoEscapeExpr stgPoint) $ pprExpr e)
421436
]
422-
StgTick tickish e -> pprExpr e
437+
StgTick tickish e -> do
438+
Config{..} <- speConfig <$> askEnv
439+
if cfgPrintTickish
440+
then vsep [pretty tickish, pprExpr e]
441+
else pprExpr e
423442

424443
instance Pretty Expr where
425444
pretty = pprExpr
@@ -428,10 +447,17 @@ addUnboxedCommentIfNecessary :: DataCon -> Doc -> Doc
428447
addUnboxedCommentIfNecessary DataCon{..} doc = case dcRep of
429448
UnboxedTupleCon{} -> doc -- vsep [text "-- stack allocated unboxed tuple", doc]
430449
_ -> doc
431-
450+
{-
451+
pprSrcSpan :: SrcSpan -> Doc
452+
pprSrcSpan = \case
453+
UnhelpfulSpan UnhelpfulNoLocationInfo -> mempty
454+
UnhelpfulSpan (UnhelpfulOther s) -> text "-- src-loc:" <+> pretty s
455+
UnhelpfulSpan sr -> text "-- src-loc:" <+> text (T.pack $ show sr)
456+
RealSrcSpan sp _ -> text "-- src-loc:" <+> pretty sp
457+
-}
432458
pprRhs :: Id -> Rhs -> Doc
433459
pprRhs rhsId@(Id rhsBinder) = \case
434-
StgRhsClosure _ u bs e -> pprBinder rhsBinder <+> hsep (map pprBinder bs) <+> text "= do" <+> (newline <> (indent 2 $ withStgPoint (SP_RhsClosureExpr rhsId) $ pprExpr e))
460+
StgRhsClosure _ u bs e -> pprBinder rhsBinder <+> hsep (map pprBinder bs) <+> text "= do" <> (newline <> (indent 2 $ withStgPoint (SP_RhsClosureExpr rhsId) $ pprExpr e))
435461
StgRhsCon dc vs -> annotate (SP_RhsCon rhsId) $ do
436462
pprBinder rhsBinder <+> text "=" <+> addUnboxedCommentIfNecessary dc (pprDataConName dc <+> (hsep $ map (pprArg) vs))
437463

@@ -481,6 +507,7 @@ instance Pretty DataCon where
481507
pprModule :: Module -> Doc
482508
pprModule Module{..} = vsep
483509
[ text "-- package:" <+> pretty moduleUnitId
510+
, text "-- source-file-path:" <+> pretty (fromMaybe "<empty>" moduleSourceFilePath)
484511
, text "module" <+> pretty moduleName
485512
, indent 2 $ pprExportList moduleTopBindings
486513
, " ) where"
@@ -573,9 +600,12 @@ getPos :: M SrcPos
573600
getPos = (,) <$> gets spsRow <*> gets spsCol
574601

575602
pShow :: Doc -> (Text, [(StgPoint, SrcRange)])
576-
pShow doc = (T.concat . reverse $ spsOutput result, spsStgPoints result)
603+
pShow = pShowWithConfig Config {cfgPrintTickish = False}
604+
605+
pShowWithConfig :: Config -> Doc -> (Text, [(StgPoint, SrcRange)])
606+
pShowWithConfig cfg doc = (T.concat . reverse $ spsOutput result, spsStgPoints result)
577607
where
578-
result = execState (renderPOut $ execDoc doc) emptyStgPointState
608+
result = execState (renderPOut $ execDoc cfg doc) emptyStgPointState
579609

580610
renderChunk :: Chunk Int -> M ()
581611
renderChunk = \case

0 commit comments

Comments
(0)

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