blob: b8aa0180d8da438bf974aabd8b819862e50bae4b (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
-----------------------------------------------------------------------------
-- A Parser monad with access to the 'DynFlags'.
--
-- The 'P' monad only has access to the subset of 'DynFlags'
-- required for parsing Haskell.
-- The parser for C-- requires access to a lot more of the 'DynFlags',
-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
-----------------------------------------------------------------------------
module GHC.Cmm.Parser.Monad (
PD(..)
, liftP
, failMsgPD
, getProfile
, getPlatform
, getPtrOpts
, getHomeUnitId
) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
import GHC.Cmm.Info
import Control.Monad
import GHC.Driver.Session
import GHC.Parser.Lexer
import GHC.Parser.Errors
import GHC.Types.SrcLoc
import GHC.Unit.Types
import GHC.Unit.Home
newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }
instance Functor PD where
fmap = liftM
instance Applicative PD where
pure = returnPD
(<*>) = ap
instance Monad PD where
(>>=) = thenPD
liftP :: P a -> PD a
liftP (P f) = PD $ \_ _ s -> f s
failMsgPD :: (SrcSpan -> Error) -> PD a
failMsgPD = liftP . failMsgP
returnPD :: a -> PD a
returnPD = liftP . return
thenPD :: PD a -> (a -> PD b) -> PD b
(PD m) `thenPD` k = PD $ \d hu s ->
case m d hu s of
POk s1 a -> unPD (k a) d hu s1
PFailed s1 -> PFailed s1
instance HasDynFlags PD where
getDynFlags = PD $ \d _ s -> POk s d
getProfile :: PD Profile
getProfile = targetProfile <$> getDynFlags
getPlatform :: PD Platform
getPlatform = profilePlatform <$> getProfile
getPtrOpts :: PD PtrOpts
getPtrOpts = do
dflags <- getDynFlags
profile <- getProfile
pure $ PtrOpts
{ po_profile = profile
, po_align_check = gopt Opt_AlignmentSanitisation dflags
}
-- | Return the UnitId of the home-unit. This is used to create labels.
getHomeUnitId :: PD UnitId
getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu)
|
