compiler/GHC/Cmm/Monad.hs


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

-----------------------------------------------------------------------------
-- 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.Monad (
    PD(..)
  , liftP
  , failMsgPD
  , getProfile
  , getPlatform
  , getPtrOpts
  ) 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

newtype PD a = PD { unPD :: DynFlags -> 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 :: String -> 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 s ->
        case m d s of
                POk s1 a         -> unPD (k a) d 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
      }