2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE ForeignFunctionInterface #-}
5 module Mate.X86CodeGen where
7 import Prelude hiding (and, div)
9 import Data.BinaryState
12 import Data.List (genericLength)
13 import qualified Data.Map as M
14 import qualified Data.ByteString.Lazy as B
17 import Foreign hiding (xor)
18 import Foreign.C.Types
20 import qualified JVM.Assembler as J
21 import JVM.Assembler hiding (Instruction)
25 import Harpy.X86Disassembler
27 import Mate.BasicBlocks
28 import Mate.NativeSizes
38 foreign import ccall "&mallocObjectGC"
39 mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
41 type EntryPoint = Ptr Word8
42 type EntryPointOffset = Int
43 type PatchInfo = (BlockID, EntryPointOffset)
45 type BBStarts = M.Map BlockID Int
47 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
50 emitFromBB :: Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction])
51 emitFromBB cls method = do
52 let keys = M.keys hmap
53 llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
54 let lmap = zip keys llmap
58 sub esp (fromIntegral (rawLocals method) * ptrSize :: Word32)
60 (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
63 return ((ep, bbstarts, end, calls), d)
65 hmap = rawMapBB method
67 getLabel :: BlockID -> [(BlockID, Label)] -> Label
68 getLabel _ [] = error "label not found!"
69 getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
71 efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
72 efBB (bid, bb) calls bbstarts lmap =
73 if M.member bid bbstarts then
74 return (calls, bbstarts)
76 bb_offset <- getCodeOffset
77 let bbstarts' = M.insert bid bb_offset bbstarts
78 defineLabel $ getLabel bid lmap
79 cs <- mapM emit'' $ code bb
80 let calls' = calls `M.union` M.fromList (catMaybes cs)
82 Return -> return (calls', bbstarts')
84 -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
86 efBB (t, hmap M.! t) calls' bbstarts' lmap
87 OneTarget t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
89 (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
90 efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
91 -- TODO(bernhard): also use metainformation
92 -- TODO(bernhard): implement `emit' as function which accepts a list of
93 -- instructions, so we can use patterns for optimizations
95 forceRegDump :: CodeGen e s ()
98 mov esi (0x13371234 :: Word32)
102 getCurrentOffset :: CodeGen e s Word32
103 getCurrentOffset = do
105 let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
106 offset <- getCodeOffset
107 return $ w32_ep + fromIntegral offset
109 emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
110 emitInvoke cpidx hasThis = do
111 let l = buildMethodID cls cpidx
112 calladdr <- getCurrentOffset
113 newNamedLabel (show l) >>= defineLabel
114 -- causes SIGILL. in the signal handler we patch it to the acutal call.
115 -- place two nop's at the end, therefore the disasm doesn't screw up
116 emit32 (0x9090ffff :: Word32); nop
117 -- discard arguments on stack
118 let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount (methodNameTypeByIdx cls cpidx)) * ptrSize
119 when (argcnt > 0) (add esp argcnt)
120 -- push result on stack if method has a return value
121 when (methodHaveReturnValue cls cpidx) (push eax)
122 return $ Just (calladdr, StaticMethod l)
124 virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
125 virtualCall cpidx isInterface = do
126 let mi@(MethodInfo methodname objname msig@(MethodSignature args _)) = buildMethodID cls cpidx
127 newNamedLabel (show mi) >>= defineLabel
128 -- get method offset for call @ runtime
129 let offset = if isInterface
130 then getInterfaceMethodOffset objname methodname (encode msig)
131 else getMethodOffset objname (methodname `B.append` encode msig)
132 let argsLen = genericLength args
133 -- objref lives somewhere on the argument stack
134 mov ebx (Disp (argsLen * ptrSize), esp)
136 then mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
137 else return () -- invokevirtual
138 -- get method-table-ptr (or interface-table-ptr)
139 mov eax (Disp 0, ebx)
140 -- make actual (indirect) call
141 calladdr <- getCurrentOffset
142 -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
143 emit32 (0x9090ffff :: Word32); nop; nop
144 -- discard arguments on stack (`+1' for "this")
145 let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
146 when (argcnt > 0) (add esp argcnt)
147 -- push result on stack if method has a return value
148 when (methodHaveReturnValue cls cpidx) (push eax)
149 -- note, that "mi" has the wrong class reference here.
150 -- we figure that out at run-time, in the methodpool,
151 -- depending on the method-table-ptr
152 return $ Just (calladdr, VirtualCall isInterface mi offset)
154 emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
155 emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
157 emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
158 emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
159 emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
160 emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
161 emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
162 emit' (PUTSTATIC cpidx) = do
164 trapaddr <- getCurrentOffset
165 mov (Addr 0x00000000) eax -- it's a trap
166 return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
167 emit' (GETSTATIC cpidx) = do
168 trapaddr <- getCurrentOffset
169 mov eax (Addr 0x00000000) -- it's a trap
171 return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
172 emit' (INSTANCEOF cpidx) = do
174 mov eax (Disp 0, eax) -- mtable of objectref
175 trapaddr <- getCurrentOffset
176 -- place something like `mov edx $mtable_of_objref' instead
177 emit32 (0x9090ffff :: Word32); nop
183 return $ Just (trapaddr, InstanceOf $ buildClassID cls cpidx)
184 emit' (NEW objidx) = do
185 let objname = buildClassID cls objidx
186 trapaddr <- getCurrentOffset
187 -- place something like `push $objsize' instead
188 emit32 (0x9090ffff :: Word32); nop
190 -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
191 mov (Disp 0, eax) (0x13371337 :: Word32)
192 return $ Just (trapaddr, NewObject objname)
194 emit' insn = emit insn >> return Nothing
196 emit :: J.Instruction -> CodeGen e s ()
197 emit POP = add esp (ptrSize :: Word32) -- drop value
198 emit DUP = push (Disp 0, esp)
199 emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
200 emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
201 emit AASTORE = emit IASTORE
205 add ebx (1 :: Word32)
207 mov (ecx, ebx, S4) eax
211 add ebx (1 :: Word32)
213 mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
214 emit AALOAD = emit IALOAD
217 add ebx (1 :: Word32)
222 add ebx (1 :: Word32)
224 push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
225 emit ARRAYLENGTH = do
228 emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
229 emit (NEWARRAY typ) = do
230 let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
233 _ -> error "newarray: type not implemented yet"
234 -- get length from stack, but leave it there
235 mov eax (Disp 0, esp)
236 mov ebx (tsize :: Word32)
237 -- multiple amount with native size of one element
238 mul ebx -- result is in eax
239 add eax (ptrSize :: Word32) -- for "length" entry
240 -- push amount of bytes to allocate
243 pop eax -- ref to arraymemory
245 mov (Disp 0, eax) ebx -- store length at offset 0
246 push eax -- push ref again
248 emit (CHECKCAST _) = nop -- TODO(bernhard): ...
249 emit ATHROW = -- TODO(bernhard): ...
250 emit32 (0xffffffff :: Word32)
253 and eax (0x000000ff :: Word32)
255 emit (BIPUSH val) = push (fromIntegral val :: Word32)
256 emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
257 emit ACONST_NULL = push (0 :: Word32)
258 emit (ICONST_M1) = push ((-1) :: Word32)
259 emit (ICONST_0) = push (0 :: Word32)
260 emit (ICONST_1) = push (1 :: Word32)
261 emit (ICONST_2) = push (2 :: Word32)
262 emit (ICONST_3) = push (3 :: Word32)
263 emit (ICONST_4) = push (4 :: Word32)
264 emit (ICONST_5) = push (5 :: Word32)
266 emit (ALOAD_ x) = emit (ILOAD_ x)
267 emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
268 emit (ALOAD x) = emit (ILOAD x)
269 emit (ILOAD x) = push (Disp (cArgs x), ebp)
271 emit (ASTORE_ x) = emit (ISTORE_ x)
272 emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
273 emit (ASTORE x) = emit (ISTORE x)
276 mov (Disp (cArgs x), ebp) eax
278 emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
280 value <- case constsPool cls M.! x of
281 (CString s) -> liftIO $ getUniqueStringAddr s
282 (CInteger i) -> liftIO $ return i
283 e -> error $ "LDCI... missing impl.: " ++ show e
285 emit (GETFIELD x) = do
286 offset <- emitFieldOffset x
287 push (Disp (fromIntegral offset), eax) -- get field
288 emit (PUTFIELD x) = do
289 pop ebx -- value to write
290 offset <- emitFieldOffset x
291 mov (Disp (fromIntegral offset), eax) ebx -- set field
293 emit IADD = do pop ebx; pop eax; add eax ebx; push eax
294 emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
295 emit IMUL = do pop ebx; pop eax; mul ebx; push eax
296 emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
297 emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
298 emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
299 emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
300 emit INEG = do pop eax; neg eax; push eax
302 add (Disp (cArgs x), ebp) (s8_w32 imm)
304 emit (IFNONNULL x) = emit (IF C_NE x)
305 emit (IFNULL x) = emit (IF C_EQ x)
306 emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
307 emit (IF_ICMP cond _) = do
310 cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
313 emit (IF cond _) = do
315 cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
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
324 emit IRETURN = do pop eax; emit RETURN
325 emit invalid = error $ "insn not implemented yet: " ++ show invalid
327 emitFieldOffset :: Word16 -> CodeGen e s Int32
328 emitFieldOffset x = do
329 pop eax -- this pointer
330 let (cname, fname) = buildFieldOffset cls x
331 liftIO $ getFieldOffset cname fname
333 emitIF :: CMP -> CodeGen e s ()
335 sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
336 l = getLabel sid lmap
337 sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
338 l2 = getLabel sid2 lmap
341 C_EQ -> je l; C_NE -> jne l
342 C_LT -> jl l; C_GT -> jg l
343 C_GE -> jge l; C_LE -> jle l
344 -- TODO(bernhard): ugly workaround, to get broken emitBB working
345 -- (it didn't work for gnu/classpath/SystemProperties.java)
349 -- for locals we use a different storage
350 cArgs :: Word8 -> Word32
351 cArgs x = ptrSize * (argcount - x' + isLocal)
354 argcount = rawArgCount method
355 isLocal = if x' >= argcount then (-1) else 1
357 cArgs_ :: IMM -> Word8
358 cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
361 -- sign extension from w8 to w32 (over s8)
362 -- unfortunately, hs-java is using Word8 everywhere (while
363 -- it should be Int8 actually)
364 s8_w32 :: Word8 -> Word32
365 s8_w32 w8 = fromIntegral s8
366 where s8 = fromIntegral w8 :: Int8
368 callMalloc :: CodeGen e s ()
370 call mallocObjectAddr
371 add esp (ptrSize :: Word32)
374 -- the regular push implementation, considers the provided immediate and selects
375 -- a different instruction if it fits in 8bit. but this is not useful for
377 push32 :: Word32 -> CodeGen e s ()
378 push32 imm32 = emit8 0x68 >> emit32 imm32
380 call32_eax :: Disp -> CodeGen e s ()
381 call32_eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32