1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ForeignFunctionInterface #-}
3 module Mate.X86CodeGen where
8 import qualified Data.Map as M
9 import qualified Data.Set as S
10 import qualified Data.ByteString.Lazy as B
14 import Foreign.C.Types
18 import qualified JVM.Assembler as J
19 import JVM.Assembler hiding (Instruction)
23 import Harpy.X86Disassembler
25 import Mate.BasicBlocks
32 foreign import ccall "dynamic"
33 code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
35 foreign import ccall "getaddr"
38 foreign import ccall "getMallocAddr"
39 getMallocAddr :: CUInt
41 foreign import ccall "callertrap"
44 foreign import ccall "register_signal"
45 register_signal :: IO ()
47 test_01, test_02, test_03 :: IO ()
50 (entry, end) <- testCase "./tests/Fib" "fib"
51 let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
54 result <- code_int entryFuncPtr x 0
55 let iresult :: Int; iresult = fromIntegral result
56 let kk :: String; kk = if iresult == (fib x) then "OK" else "FAIL (" ++ (show (fib x)) ++ ")"
57 printf "result of fib(%2d): %3d\t\t%s\n" (fromIntegral x :: Int) iresult kk
58 ) $ ([0..10] :: [CInt])
59 printf "patched disasm:\n"
60 Right newdisasm <- disassembleBlock entry end
61 mapM_ (putStrLn . showAtt) newdisasm
66 | otherwise = (fib (n - 1)) + (fib (n - 2))
70 (entry,_) <- testCase "./tests/While" "f"
71 let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
72 result <- code_int entryFuncPtr 5 4
73 let iresult :: Int; iresult = fromIntegral result
74 let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
75 printf "result of f(5,4): %3d\t\t%s\n" iresult kk
77 result2 <- code_int entryFuncPtr 4 3
78 let iresult2 :: Int; iresult2 = fromIntegral result2
79 let kk2 :: String; kk2 = if iresult2 == 10 then "OK" else "FAIL"
80 printf "result of f(4,3): %3d\t\t%s\n" iresult2 kk2
84 (entry,_) <- testCase "./tests/While" "g"
85 let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
86 result <- code_int entryFuncPtr 5 4
87 let iresult :: Int; iresult = fromIntegral result
88 let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
89 printf "result of g(5,4): %3d\t\t%s\n" iresult kk
91 result2 <- code_int entryFuncPtr 4 3
92 let iresult2 :: Int; iresult2 = fromIntegral result2
93 let kk2 :: String; kk2 = if iresult2 == 10 then "OK" else "FAIL"
94 printf "result of g(4,3): %3d\t\t%s\n" iresult2 kk2
97 testCase :: B.ByteString -> B.ByteString -> IO (Ptr Word8, Int)
98 testCase cf method = do
99 cls <- getClassFile cf
100 hmap <- parseMethod cls method
103 Nothing -> error "sorry, no code generation"
105 let ebb = emitFromBB method cls hmap'
106 (_, Right ((entry, bbstarts, end, _), disasm)) <- runCodeGen ebb () ()
107 let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Int)
109 mapM_ (putStrLn . showAtt) disasm
110 printf "basicblocks addresses:\n"
111 let b = map (\(x,y) -> (x,y + int_entry)) $ M.toList bbstarts
112 mapM_ (\(x,y) -> printf "\tBasicBlock %2d starts at 0x%08x\n" x y) b
115 type EntryPoint = Ptr Word8
116 type EntryPointOffset = Int
117 type PatchInfo = (BlockID, EntryPointOffset)
119 type BBStarts = M.Map BlockID Int
121 type CompileInfo = (EntryPoint, BBStarts, Int, TMap)
124 emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
125 emitFromBB method cls hmap = do
126 llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
127 let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
131 -- TODO(bernhard): determine a reasonable value.
132 -- e.g. (locals used) * 4
133 sub esp (0x60 :: Word32)
135 (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
138 return ((ep, bbstarts, end, calls), d)
140 getLabel :: BlockID -> [(BlockID, Label)] -> Label
141 getLabel _ [] = error "label not found!"
142 getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
144 efBB :: (BlockID, BasicBlock) -> TMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TMap, BBStarts)
145 efBB (bid, bb) calls bbstarts lmap =
146 if M.member bid bbstarts then
147 return (calls, bbstarts)
149 bb_offset <- getCodeOffset
150 let bbstarts' = M.insert bid bb_offset bbstarts
151 defineLabel $ getLabel bid lmap
152 cs <- mapM emit' $ code bb
153 let calls' = calls `M.union` (M.fromList $ catMaybes cs)
155 Return -> return (calls', bbstarts')
157 efBB (t, hmap M.! t) calls' bbstarts' lmap
159 efBB (t, hmap M.! t) calls' bbstarts' lmap
160 TwoTarget t1 t2 -> do
161 (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
162 efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
163 -- TODO(bernhard): also use metainformation
164 -- TODO(bernhard): implement `emit' as function which accepts a list of
165 -- instructions, so we can use patterns for optimizations
167 getCurrentOffset :: CodeGen e s (Word32)
168 getCurrentOffset = do
170 let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
171 offset <- getCodeOffset
172 return $ w32_ep + (fromIntegral offset)
174 emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
175 emitInvoke cpidx hasThis = do
176 let l = buildMethodID cls cpidx
177 calladdr <- getCurrentOffset
178 newNamedLabel (show l) >>= defineLabel
179 -- causes SIGILL. in the signal handler we patch it to the acutal call.
180 -- place a nop at the end, therefore the disasm doesn't screw up
181 emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
182 -- discard arguments on stack
183 let argcnt = ((if hasThis then 1 else 0) + (methodGetArgsCount cls cpidx)) * 4
184 when (argcnt > 0) (add esp argcnt)
185 -- push result on stack if method has a return value
186 when (methodHaveReturnValue cls cpidx) (push eax)
187 return $ Just $ (calladdr, MI l)
189 emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
190 emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
191 emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
192 emit' (INVOKEVIRTUAL cpidx) = do
193 -- get methodInfo entry
194 let mi@(MethodInfo methodname objname msig@(MethodSignature args _)) = buildMethodID cls cpidx
195 newNamedLabel (show mi) >>= defineLabel
196 -- objref lives somewhere on the argument stack
197 mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
198 -- get method-table-ptr
199 mov eax (Disp 0, eax)
201 let nameAndSig = methodname `B.append` (encode msig)
202 let offset = unsafePerformIO $ getMethodOffset objname nameAndSig
203 -- make actual (indirect) call
204 calladdr <- getCurrentOffset
205 call (Disp offset, eax)
206 -- discard arguments on stack (+4 for "this")
207 let argcnt = 4 + ((methodGetArgsCount cls cpidx) * 4)
208 when (argcnt > 0) (add esp argcnt)
209 -- push result on stack if method has a return value
210 when (methodHaveReturnValue cls cpidx) (push eax)
211 -- note, the "mi" has the wrong class reference here.
212 -- we figure that out at run-time, in the methodpool,
213 -- depending on the method-table-ptr
214 return $ Just $ (calladdr, VI mi)
215 emit' (PUTSTATIC cpidx) = do
217 trapaddr <- getCurrentOffset
218 mov (Addr 0x00000000) eax -- it's a trap
219 return $ Just $ (trapaddr, SFI $ buildStaticFieldID cls cpidx)
220 emit' (GETSTATIC cpidx) = do
221 trapaddr <- getCurrentOffset
222 mov eax (Addr 0x00000000) -- it's a trap
224 return $ Just $ (trapaddr, SFI $ buildStaticFieldID cls cpidx)
225 emit' insn = emit insn >> return Nothing
227 emit :: J.Instruction -> CodeGen e s ()
228 emit POP = do -- print dropped value
229 calladdr <- getCurrentOffset
230 -- '5' is the size of the `call' instruction ( + immediate)
231 let w32_calladdr = 5 + calladdr
232 let trapaddr = (fromIntegral getaddr :: Word32)
233 call (trapaddr - w32_calladdr)
234 add esp (4 :: Word32)
235 emit DUP = push (Disp 0, esp)
236 emit (NEW objidx) = do
237 let objname = buildClassID cls objidx
238 let amount = unsafePerformIO $ getMethodSize objname
239 push (amount :: Word32)
240 calladdr <- getCurrentOffset
241 let w32_calladdr = 5 + calladdr
242 let malloaddr = (fromIntegral getMallocAddr :: Word32)
243 call (malloaddr - w32_calladdr)
244 add esp (4 :: Word32)
246 -- TODO(bernhard): save reference somewhere for GC
247 -- set method table pointer
248 let mtable = unsafePerformIO $ getMethodTable objname
249 mov (Disp 0, eax) mtable
250 emit (CHECKCAST _) = nop -- TODO(bernhard): ...
251 emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
252 emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
253 emit (ICONST_0) = push (0 :: Word32)
254 emit (ICONST_1) = push (1 :: Word32)
255 emit (ICONST_2) = push (2 :: Word32)
256 emit (ICONST_4) = push (4 :: Word32)
257 emit (ICONST_5) = push (5 :: Word32)
258 emit (ALOAD_ x) = emit (ILOAD_ x)
260 push (Disp (cArgs_ x), ebp)
261 emit (ALOAD x) = emit (ILOAD x)
263 push (Disp (cArgs x), ebp)
264 emit (ASTORE_ x) = emit (ISTORE_ x)
265 emit (ISTORE_ x) = do
267 mov (Disp (cArgs_ x), ebp) eax
268 emit (ASTORE x) = emit (ISTORE x)
271 mov (Disp (cArgs x), ebp) eax
273 emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
275 let value = case (constsPool cls) M.! x of
276 (CString s) -> unsafePerformIO $ getUniqueStringAddr s
277 _ -> error $ "LDCI... missing impl."
279 emit (GETFIELD x) = do
280 pop eax -- this pointer
281 let (cname, fname) = buildFieldOffset cls x
282 let offset = unsafePerformIO $ getFieldOffset cname fname
283 push (Disp (fromIntegral $ offset * 4), eax) -- get field
284 emit (PUTFIELD x) = do
285 pop ebx -- value to write
286 pop eax -- this pointer
287 let (cname, fname) = buildFieldOffset cls x
288 let offset = unsafePerformIO $ getFieldOffset cname fname
289 mov (Disp (fromIntegral $ offset * 4), eax) ebx -- set field
291 emit IADD = do pop ebx; pop eax; add eax ebx; push eax
292 emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
293 emit IMUL = do pop ebx; pop eax; mul ebx; push eax
294 emit (IINC x imm) = do
295 add (Disp (cArgs x), ebp) (s8_w32 imm)
297 emit (IF_ICMP cond _) = do
300 cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
301 let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
302 let l = getLabel sid lmap
304 C_EQ -> je l; C_NE -> jne l
305 C_LT -> jl l; C_GT -> jg l
306 C_GE -> jge l; C_LE -> jle l
308 emit (IF cond _) = do
310 cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
311 let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
312 let l = getLabel sid lmap
314 C_EQ -> je l; C_NE -> jne l
315 C_LT -> jl l; C_GT -> jg l
316 C_GE -> jge l; C_LE -> jle l
319 let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
320 jmp $ getLabel sid lmap
322 emit RETURN = do mov esp ebp; pop ebp; ret
323 emit ARETURN = emit IRETURN
329 emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
331 -- for locals we use a different storage
332 cArgs :: Word8 -> Word32
333 cArgs x = if (x' >= thisMethodArgCnt)
334 -- TODO(bernhard): maybe s/(-4)/(-8)/
335 then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
336 else 4 + (thisMethodArgCnt * 4) - (4 * x')
337 where x' = fromIntegral x
339 cArgs_ :: IMM -> Word32
340 cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
342 thisMethodArgCnt :: Word32
343 thisMethodArgCnt = isNonStatic + (fromIntegral $ length args)
345 (Just m) = lookupMethod method cls
346 (MethodSignature args _) = methodSignature m
347 isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
349 else 1 -- one argument for the this pointer
352 -- sign extension from w8 to w32 (over s8)
353 -- unfortunately, hs-java is using Word8 everywhere (while
354 -- it should be Int8 actually)
355 s8_w32 :: Word8 -> Word32
356 s8_w32 w8 = fromIntegral s8
357 where s8 = (fromIntegral w8) :: Int8