blob: 03c57e93a5348ab4fae3af1e8950d8b42ef71238 (
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
|
-- 1. Load a set of modules with "nothing" target
-- 2. Load it again with "interpreted" target
-- 3. Execute some code
-- a. If the recompilation checker is buggy this will die due to missing
-- code
-- b. If it's correct, it will recompile because the target has changed.
--
-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where
import GHC
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Utils.Monad ( MonadIO(..) )
import GHC.Types.Basic ( failed )
import GHC.Data.Bag ( bagToList )
import System.Environment
import Control.Monad
import System.IO
main = do
libdir : args <- getArgs
runGhc (Just libdir) $ do
dflags0 <- getSessionDynFlags
(dflags, _, _) <- parseDynamicFlags dflags0
(map (mkGeneralLocated "on the commandline") args)
setSessionDynFlags $ dflags { backend = NoBackend
, ghcLink = LinkInMemory
, verbosity = 0 -- silence please
}
root_mod <- guessTarget "A.hs" Nothing
setTargets [root_mod]
ok <- load LoadAllTargets
when (failed ok) $ error "Couldn't load A.hs in nothing mode"
prn "target nothing: ok"
dflags <- getSessionDynFlags
setSessionDynFlags $ dflags { backend = Interpreter }
ok <- load LoadAllTargets
when (failed ok) $ error "Couldn't load A.hs in interpreted mode"
prn "target interpreted: ok"
-- set context to module "A"
mg <- getModuleGraph
let [mod] = [ ms_mod_name m
| m <- mgModSummaries mg
, moduleNameString (ms_mod_name m) == "A" ]
setContext [IIModule mod]
liftIO $ hFlush stdout -- make sure things above are printed before
-- interactive output
r <- execStmt "main" execOptions
case r of
ExecComplete { execResult = Right _ } -> prn "ok"
ExecComplete { execResult = Left _ } -> prn "exception"
ExecBreak{} -> prn "breakpoint"
liftIO $ hFlush stdout
return ()
prn :: MonadIO m => String -> m ()
prn = liftIO . putStrLn
|
