1 {-# LANGUAGE ScopedTypeVariables #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE TemplateHaskell #-}
6 -- Purpose of this file is just do test some Intermediate representations and stuff ;-)
8 {- Some important material:
10 - Java HotSpotâ„¢ Client Compiler: www.cdl.uni-saarland.de/ssasem/talks/Christian.Wimmer.pdf
11 - http://www.complang.tuwien.ac.at/andi/185A50
13 - [Poletto:1999] http://dl.acm.org/citation.cfm?doid=330249.330250
14 - [Wimmer:2010] http://dl.acm.org/citation.cfm?id=1772954.1772979
19 module ScratchHS where
22 import Control.Monad.State
24 import Harpy hiding(fst,add)
25 import qualified Harpy.X86Disassembler as H
26 import qualified Data.ByteString.Lazy as B
27 import qualified Data.Set as S
28 import qualified Data.Heap as H
42 import Mate.BasicBlocks
47 $(callDecl "callAsWord32" [t|Word32|])
49 data SimpleStack = PushLit Int
55 testP = [PushLit 3, PushLit 2, Mul]
58 data ROp = RMul | RAdd
60 data RegIL = RMov Reg Reg
62 | RBin Reg Reg Reg ROp
64 data MateState = MateState String
66 compileRegIL :: RegIL -> CodeGen (Ptr Int32) MateState ()
67 compileRegIL (RMov t s) = do
69 let (mt,ms) = (eax,eax)
73 entryCode :: CodeGen e s ()
74 entryCode = do push ebp
77 exitCode :: CodeGen e s ()
78 exitCode = do mov esp ebp
84 run :: [RegIL] -> Ptr Int32 -> IO (MateState, Either ErrMsg [H.Instruction])
85 run program env = let compileAndFeedback = mapM_ compileRegIL program >> disassemble
86 in runCodeGen compileAndFeedback env (MateState "none")
89 -- Allocates a buffer with size n. All zero.
90 emptyMemory :: (Storable a, Num a) => Int -> IO (Ptr a)
91 emptyMemory n = mallocArray n
92 >>= (\ptr -> pokeArray ptr (replicate n 0) >> return ptr)
97 (_, Right code) <- run p' ptr
98 return $ map H.showIntel code
101 simpleTest :: [RegIL]
102 simpleTest = [RMov 0 1]
105 -- Just some class file sand
106 loadMethod methodName classFile = do cls <- parseClassFile classFile
108 return (cls, lookupMethod methodName cls)
111 getFib = do (cls, Just m) <- loadMethod "fac" "../tests/Fac.class"
114 fibBasicBlocks = do (cls,m) <- getFib
115 hmap <- parseMethod cls "facFor"
120 fib = do con@(Just (ins,cls)) <- getMethodIO "../tests/Fac.class" "facFor"
121 let offsets = getInstOffsets ins
122 let taggedInst = zip3 (map Source $ sumSeries'' offsets) offsets ins
123 mapM_ print taggedInst
124 let continuations = execState (findContinuations taggedInst) ([],H.empty)
126 let cfg = buildCFGContext con
130 fib' = do con@(Just (ins,cls)) <- getMethodIO "../tests/Fac.class" "facFor"
131 let tagged = getInstructions ins
133 let backRefs = splitBlocksBackRef tagged
134 let splitted = splitBlocks backRefs tagged
136 let transitions = getTransitions splitted
137 let nodes = getNodes splitted
142 let (Just finalCyclicStructure) = indirectCFGToG splitted
144 print $ printG' finalCyclicStructure
146 main = do con@(Just (ins,cls)) <- getMethodIO "../tests/AbsurdlyHuge.class" "absurdlyHuge"
147 let tagged = getInstructions ins
148 let backRefs = splitBlocksBackRef tagged
149 let splitted = splitBlocks backRefs tagged
150 let transitions = getTransitions splitted
151 let nodes = getNodes splitted
156 let (Just finalCyclicStructure) = indirectCFGToG splitted
158 print $ printG' finalCyclicStructure
164 diamant = let start = Node "a" left right
165 left = Node "l" end Nil
166 right = Node "r" end Nil
167 end = Node "g" start Nil
170 dag = Node "a" (Node "b" (Leaf "c") (Leaf "d")) (Node "b" (Leaf "c") (Leaf "d"))
173 value (Node val _ _) = Just val
174 value (Leaf val ) = Just val
178 printG' :: Ord k => G k -> [k]
179 printG' g = evalState (foldGM ((: []), (++)) (\node -> let (Just v) = value node in v) [] g) S.empty