Skip to content

Commit 5afab21

Browse files
csabahruskacsabahruska
committed
use StgId in StgPoint to support Show/Read instances
1 parent 86a4d11 commit 5afab21

File tree

3 files changed

+45
-21
lines changed

3 files changed

+45
-21
lines changed

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

Lines changed: 29 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,39 @@
1+
{-# LANGUAGE RecordWildCards #-}
12
module Stg.IRLocation where
23

34
import Stg.Syntax
45

6+
data StgId
7+
= StgId
8+
{ siUnitId :: Name
9+
, siModuleName :: Name
10+
, siName :: Name
11+
, siUnique :: Maybe Unique
12+
}
13+
deriving (Eq, Ord, Show, Read)
14+
15+
binderToStgId :: Binder -> StgId
16+
binderToStgId Binder{..} = StgId
17+
{ siUnitId = getUnitId binderUnitId
18+
, siModuleName = getModuleName binderModule
19+
, siName = binderName
20+
, siUnique = case binderScope of
21+
ModulePublic -> Nothing
22+
_ | BinderId u <- binderId
23+
-> Just u
24+
}
25+
526
data StgPoint
627
-- expression locations
7-
= SP_CaseScrutineeExpr { spScrutineeResultName :: Id }
28+
= SP_CaseScrutineeExpr { spScrutineeResultName :: StgId }
829
| SP_LetExpr { spParent :: StgPoint }
930
| SP_LetNoEscapeExpr { spParent :: StgPoint }
10-
| SP_RhsClosureExpr { spRhsBinderName :: Id }
11-
| SP_AltExpr { spScrutineeResultName :: Id, spAltIndex :: Int }
12-
| SP_RhsCon { spRhsBinderName :: Id }
13-
deriving (Eq, Ord, Show)
31+
| SP_RhsClosureExpr { spRhsBinderName :: StgId }
32+
| SP_AltExpr { spScrutineeResultName :: StgId, spAltIndex :: Int }
33+
| SP_RhsCon { spRhsBinderName :: StgId }
34+
| SP_Binding { spBinderName :: StgId }
35+
| SP_Tickish { spParent :: StgPoint }
36+
deriving (Eq, Ord, Show, Read)
1437

1538
{-
1639
breakpoint types:
@@ -59,7 +82,7 @@ data StgPoint
5982
data FieldSelector
6083
-- generic
6184
= FS_UniqueName Name -- selects uniquely named IR element
62-
| FS_Binder Id -- selects uniquely named IR element
85+
| FS_Binder StgId -- selects uniquely named IR element
6386

6487
-- Module
6588
| FS_Module_moduleTopBindings Int -- selects: Module -> TopBinding

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

Lines changed: 12 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -322,9 +322,9 @@ instance Pretty AltType where
322322
AlgAlt tc -> text "AlgAlt" <+> ppTyConName tc
323323

324324
pprAlt :: Id -> Int -> Alt -> Doc
325-
pprAlt scrutId idx (Alt con bndrs rhs) =
325+
pprAlt (Id scrutBinder) idx (Alt con bndrs rhs) =
326326
(hsep (pretty con : map (pprBinder) bndrs) <+> text "-> do") <$$>
327-
indent 2 (withStgPoint (SP_AltExpr scrutId idx) $ pprExpr rhs)
327+
indent 2 (withStgPoint (SP_AltExpr (binderToStgId scrutBinder) idx) $ pprExpr rhs)
328328

329329
pprArg :: Arg -> Doc
330330
pprArg = \case
@@ -409,19 +409,19 @@ pprExpr exp = do
409409
annotate stgPoint $ case exp of
410410
StgLit l -> pretty l
411411
StgCase x b at [Alt AltDefault [] rhs] -> sep
412-
[ withStgPoint (SP_CaseScrutineeExpr $ Id b) $
412+
[ withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $
413413
pprBinder b <+> text "<-" <+> nest 2 (pprExpr x)
414-
, withStgPoint (SP_AltExpr (Id b) 0) $
414+
, withStgPoint (SP_AltExpr (binderToStgId b) 0) $
415415
pprExpr rhs
416416
]
417417
StgCase x b at [Alt con bndrs rhs] -> sep
418-
[ withStgPoint (SP_CaseScrutineeExpr $ Id b) $
418+
[ withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $
419419
pprBinder b <+> text "@" <+> parens (hsep $ pretty con : map (pprBinder) bndrs) <+> text "<-" <+> nest 2 (pprExpr x)
420-
, withStgPoint (SP_AltExpr (Id b) 0) $
420+
, withStgPoint (SP_AltExpr (binderToStgId b) 0) $
421421
pprExpr rhs
422422
]
423423
StgCase x b at alts -> sep
424-
[ withStgPoint (SP_CaseScrutineeExpr $ Id b) $
424+
[ withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $
425425
pprBinder b <+> text "<-" <+> nest 2 (pprExpr x)
426426
, text "case" <+> pprVar b <+> text "of"
427427
, indent 2 $ vcat $ putDefaultLast alts [pprAlt (Id b) idx a | (idx, a) <- zip [0..] alts]
@@ -437,7 +437,7 @@ pprExpr exp = do
437437
StgTick tickish e -> do
438438
Config{..} <- speConfig <$> askEnv
439439
if cfgPrintTickish
440-
then vsep [pretty tickish, pprExpr e]
440+
then vsep [annotate (SP_Tickish stgPoint) $ pretty tickish, pprExpr e]
441441
else pprExpr e
442442

443443
instance Pretty Expr where
@@ -456,9 +456,10 @@ pprSrcSpan = \case
456456
RealSrcSpan sp _ -> text "-- src-loc:" <+> pretty sp
457457
-}
458458
pprRhs :: Id -> Rhs -> Doc
459-
pprRhs rhsId@(Id rhsBinder) = \case
460-
StgRhsClosure _ u bs e -> pprBinder rhsBinder <+> hsep (map pprBinder bs) <+> text "= do" <> (newline <> (indent 2 $ withStgPoint (SP_RhsClosureExpr rhsId) $ pprExpr e))
461-
StgRhsCon dc vs -> annotate (SP_RhsCon rhsId) $ do
459+
pprRhs (Id rhsBinder) = \case
460+
StgRhsClosure _ u bs e -> annotate (SP_Binding $ binderToStgId rhsBinder) $ do
461+
pprBinder rhsBinder <+> hsep (map pprBinder bs) <+> text "= do" <> (newline <> (indent 2 $ withStgPoint (SP_RhsClosureExpr $ binderToStgId rhsBinder) $ pprExpr e))
462+
StgRhsCon dc vs -> annotate (SP_RhsCon $ binderToStgId rhsBinder) $ do
462463
pprBinder rhsBinder <+> text "=" <+> addUnboxedCommentIfNecessary dc (pprDataConName dc <+> (hsep $ map (pprArg) vs))
463464

464465
pprBinding :: Binding -> Doc

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ visitBinding = \case
2828

2929
visitRhs :: Binder -> Rhs -> M ()
3030
visitRhs rhsBinder = \case
31-
StgRhsClosure _ _ _ e -> withStgPoint (SP_RhsClosureExpr $ Id rhsBinder) $ visitExpr e
31+
StgRhsClosure _ _ _ e -> withStgPoint (SP_RhsClosureExpr $ binderToStgId rhsBinder) $ visitExpr e
3232
StgRhsCon{} -> pure ()
3333

3434
visitExpr :: Expr -> M ()
@@ -40,7 +40,7 @@ visitExpr expr = do
4040
StgOpApp{} -> pure ()
4141
StgConApp{} -> pure ()
4242
StgCase x b _ alts -> do
43-
withStgPoint (SP_CaseScrutineeExpr $ Id b) $ visitExpr x
43+
withStgPoint (SP_CaseScrutineeExpr $ binderToStgId b) $ visitExpr x
4444
sequence_ [visitAlt (Id b) idx a | (idx, a) <- zip [0..] alts]
4545
StgLet b e -> do
4646
visitBinding b
@@ -53,8 +53,8 @@ visitExpr expr = do
5353
visitExpr e
5454

5555
visitAlt :: Id -> Int -> Alt -> M ()
56-
visitAlt scrutId idx (Alt _con _bndrs rhs) = do
57-
withStgPoint (SP_AltExpr scrutId idx) $ visitExpr rhs
56+
visitAlt (Id scrutBinder) idx (Alt _con _bndrs rhs) = do
57+
withStgPoint (SP_AltExpr (binderToStgId scrutBinder) idx) $ visitExpr rhs
5858

5959
collectTickish :: Module -> [(StgPoint, Tickish)]
6060
collectTickish m = snd $ evalRWS (mapM_ visitTopBinding $ moduleTopBindings m) Nothing ()

0 commit comments

Comments
 (0)