blob: 854bf62998c7225d6905dcaf0b3f66c93d4cafec (
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
|
{-# LANGUAGE BangPatterns #-}
module Main where
import ByteCodeLink
import CoreMonad
import Data.Array
import DataCon
import DebuggerUtils
import GHC
import HscTypes
import Linker
import RtClosureInspect
import TcEnv
import Type
import TcRnMonad
import TcType
import Control.Applicative
import Name (getOccString)
import Unsafe.Coerce
import Control.Monad
import Data.Maybe
import Bag
import Outputable
import GhcMonad
import X
import System.Environment
main :: IO ()
main = do [libdir] <- getArgs
runGhc (Just libdir) doit
doit :: Ghc ()
doit = do
dflags' <- getSessionDynFlags
primPackages <- setSessionDynFlags dflags'
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
target <- guessTarget "X.hs" Nothing
setTargets [target]
load LoadAllTargets
() <- chaseConstructor (unsafeCoerce False)
() <- chaseConstructor (unsafeCoerce [1,2,3])
() <- chaseConstructor (unsafeCoerce (3 :-> 2))
() <- chaseConstructor (unsafeCoerce (4 :->. 4))
() <- chaseConstructor (unsafeCoerce (4 :->.+ 4))
return ()
chaseConstructor :: (GhcMonad m) => HValue -> m ()
chaseConstructor !hv = do
dflags <- getDynFlags
liftIO $ putStrLn "====="
closure <- liftIO $ getClosureData dflags hv
case tipe closure of
Indirection _ -> chaseConstructor (ptrs closure ! 0)
Constr -> do
withSession $ \hscEnv -> liftIO $ initTcForLookup hscEnv $ do
eDcname <- dataConInfoPtrToName (infoPtr closure)
case eDcname of
Left _ -> return ()
Right dcName -> do
liftIO $ putStrLn $ "Name: " ++ showPpr dflags dcName
liftIO $ putStrLn $ "OccString: " ++ "'" ++ getOccString dcName ++ "'"
dc <- tcLookupDataCon dcName
liftIO $ putStrLn $ "DataCon: " ++ showPpr dflags dc
_ -> return ()
|
