content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  module Compiler.Mate.Backend.X86CodeGenerator
    ( compileLinear
    , handleExceptionPatcher
    , compileStateInit
    ) where
  
  import Prelude hiding (and, div, or)
  
  import qualified Data.Map as M
  import qualified Data.IntervalMap as IM
  import qualified Data.ByteString.Lazy as B
  import Data.Int
  import Data.Word
  import Data.Maybe
  import Data.List hiding (and, or)
  import Data.Ord
  import Data.Binary.IEEE754
  import qualified Data.Bits as DB
  
  import Control.Arrow
  import Control.Applicative hiding ((<*>))
  import Control.Monad
  
  import Foreign hiding (xor)
  import Foreign.C.Types
  
  import JVM.Assembler hiding (Instruction)
  import JVM.ClassFile hiding (methodName)
  import Data.Binary
  import Data.BinaryState
  
  import Harpy hiding (fst)
  import Harpy.X86Disassembler
  
  import qualified Compiler.Hoopl as H
  import Compiler.Hoopl hiding (Label)
  import Compiler.Mate.Frontend hiding (classf)
  import Compiler.Mate.Backend.NativeSizes
  import Compiler.Mate.Runtime.ClassHierarchy
  import Compiler.Mate.Runtime.JavaObjects
  import Compiler.Mate.Runtime.ClassPool
  import Compiler.Mate.Runtime.MethodPool
  
  import Compiler.Mate.Debug
  import Compiler.Mate.Types
  import Compiler.Mate.Utilities
  
  
  foreign import ccall "&mallocObjectGC_stackstrace"
    mallocObjectAddr :: FunPtr (CPtrdiff -> CPtrdiff -> Int -> IO CPtrdiff)
  
  
  data CompileState = CompileState
    { floatConsts :: M.Map Label Float
    , traps :: TrapMap
    , classf :: Class Direct
    , tryBlock :: Maybe (Word32, [(B.ByteString, Word32)])
    , exHandler :: M.Map Word32 Word32 {- JVM PC -> x86 EIP -}
    , exTable :: ExceptionMap Word32
    , gcpoints :: GCPoints
    , methodName :: B.ByteString }
  
  compileStateInit :: Class Direct -> B.ByteString -> CompileState
  compileStateInit cls m = CompileState
      { floatConsts = M.empty
      , traps = M.empty
      , classf = cls
      , tryBlock = Nothing
      , exHandler = M.empty
      , exTable = IM.empty
      , gcpoints = M.empty
      , methodName = m }
  
  modifyState :: (CompileState -> CompileState) -> CodeGen e CompileState ()
  modifyState f = do
    s <- getState
    setState (f s)
  
  
  compileLinear :: M.Map Int32 H.Label -> [LinearIns HVarX86] -> Word32
                -> CodeGen e CompileState ([Instruction], NativeWord, TrapMap)
  compileLinear lbls linsn stackAlloc = do
    -- entry sequence
    push ebp
    patchExPush <- (+1) <$> getCodeOffset
    push (0x13371337 :: Word32) -- (compile-time) patch it later manually
    mov ebp esp
    sub esp stackAlloc
    forM_ x86calleesave push
    bblabels <- forM (M.elems lbls) $ \h -> do
                  l <- newNamedLabel ("Label: " ++ show h)
                  return (h, l)
    let lmap :: M.Map H.Label Label
        lmap = M.fromList bblabels
    let retseq = do forM_ (reverse x86calleesave) pop
                    mov esp ebp
                    pop ebp {- kill exmap ref on stack -}
                    pop ebp
                    ret
    let compileIns (Fst (IRLabel hlabel hmap maybeHandler)) = do
          defineLabel $ lmap M.! hlabel
          reip <- getCurrentOffset
          -- liftIO $ printf "maybeHandler: %s\n" (show maybeHandler)
          -- liftIO $ printf "hmap: %s\n\n" (show hmap)
          case maybeHandler of
            Nothing -> return ()
            Just jvmpc ->
              modifyState (\s -> s {exHandler = M.insert jvmpc reip (exHandler s)})
          case hmap of
            [] -> return ()
            table -> modifyState (\s -> s {tryBlock = Just (reip, table)})
        compileIns (Mid ins) = girEmitOO ins
        compileIns (Lst ins) = do
          case ins of
            -- TODO: signed values
            IRIfElse jcmp src1 src2 h1 h2 -> do
              let l1 = lmap M.! h1
              let l2 = lmap M.! h2
              case (src1, src2) of -- attention: swap args
                (HIReg s1, HIReg s2) -> cmp s2 s1
                (SpillIReg d1, HIReg s2) -> cmp s2 (d1, ebp)
                (HIReg s1, SpillIReg d2) -> do
                  mov eax (d2, ebp)
                  cmp eax s1
                (SpillIReg d1, SpillIReg d2) -> do
                  mov eax (d2, ebp)
                  cmp eax (d1, ebp)
                (HIConstant c, HIReg s1) -> cmp s1 (i32Tow32 c)
                (HIReg s1, HIConstant c) -> do
                  mov eax (i32Tow32 c)
                  cmp eax s1
                (SpillIReg d1, HIConstant c) -> do
                  mov eax (i32Tow32 c)
                  cmp eax (d1, ebp)
                (HIConstant c, SpillIReg s1) -> cmp (s1, ebp) (i32Tow32 c)
                x -> error $ "IRifelse: not impl. yet" ++ show x
              case jcmp of
                C_EQ -> je  l1; C_NE -> jne l1
                C_LT -> jl  l1; C_GT -> jg  l1
                C_GE -> jge l1; C_LE -> jle l1
              jmp l2
            IRJump h -> jmp (lmap M.! h)
            IRExHandler _ -> error "emit: IRExHandlers: should not happen"
            IRSwitch src table -> do
              r2r eax src
              forM_ table $ \x -> case x of
                  (Just val, label) -> do
                    cmp eax (i32Tow32 val)
                    je (lmap M.! label)
                  -- on construction, we ensure that Nothing is the last entry of the table
                  (Nothing, label) ->
                    jmp (lmap M.! label)
            IRReturn Nothing -> retseq
            IRReturn (Just (HFReg r)) -> do
              movss xmm7 r
              retseq
            IRReturn (Just retreg) -> do
              r2r eax retreg
              retseq
          st <- getState
          case tryBlock st of
            Nothing -> return ()
            Just (start_ip, hmap) -> do
              end_ip <- getCurrentOffset
              -- TODO: end_ip - 1?
              let key = IM.ClosedInterval start_ip end_ip
              case IM.lookup key (exTable st) of
                Nothing -> do
                  let newmap = IM.insert (IM.ClosedInterval start_ip end_ip) hmap
                  modifyState (\s -> s { exTable = newmap (exTable s) })
                Just hmap_old -> do
                  let newmap = IM.insert (IM.ClosedInterval start_ip end_ip) (hmap ++ hmap_old)
                  modifyState (\s -> s { exTable = newmap (exTable s) })
          modifyState (\s -> s { tryBlock = Nothing })
    forM_ linsn $ \ins -> do
      newNamedLabel ("ir: " ++ show ins) >>= defineLabel
      compileIns ins
    exTab <- exTable <$> getState
    -- liftIO $ printf "exTab: %s\n" (show exTab)
    exHandls <- exHandler <$> getState
    -- liftIO $ printf "exHandls: %s\n" (show exHandls)
    let exmap :: ExceptionMap Word32
        exmap = foldl'
                (flip (IM.update (Just .  map (second ((M.!) exHandls)))))
                exTab
                (IM.keys exTab)
    mname <- methodName <$> getState
    gcpts <- gcpoints <$> getState
    liftIO $ printfJit "gcpoints:\n"
    liftIO $ forM_ (M.toList gcpts) $ \(ip, lst) -> do
              printfJit $ printf "\teip: %08x\n" ip
              forM_ lst $ \x -> printfJit $ printf "\t\t0x%08x\n" x
    let rsi = RuntimeStackInfo
               { rsiMethodname = mname
               , rsiExceptionMap = exmap
               , rsiGCPoints = gcpts
               }
    sptr_rsi <- liftIO $
      (fromIntegral . ptrToIntPtr . castStablePtrToPtr) <$> newStablePtr rsi
    emit32At patchExPush sptr_rsi
    floatconstants <- M.toList <$> floatConsts <$> getState
    forM_ floatconstants $ \(l, f) -> do
      defineLabel l
      emit32 (floatToWord f)
    nop; nop; nop; nop -- just some NOPs to fix up the disasm
    d <- if mateDEBUG then disassemble else return []
    ep <- fromIntegral <$> ptrToIntPtr <$> getEntryPoint
    tm <- traps <$> getState
    return (d, ep, tm)
  
  select :: forall a b.
            (Sub a b, And a b, Add a b, Or a b, Xor a b) =>
            OpType -> a -> b -> forall e s. CodeGen e s ()
  select Add = add
  select Sub = sub
  select And = and
  select Or = or
  select Xor = xor
  select x = error $ "codegen: select: not impl.: " ++ show x
  
  girEmitOO :: MateIR HVarX86 O O -> CodeGen e CompileState ()
  girEmitOO (IROp operation dst' src1' src2') =
      case operation of
        Mul -> girMul
        Div -> girDiv eax -- result is in eax
        Rem -> girDiv edx -- result is in edx
        ShiftRightLogical -> girShift shr
        ShiftRightArth -> girShift sar
        ShiftLeft -> girShift sal
        _ -> case (operation, dst', src1', src2') of
          -- handle special add cases (move instructions)
          (Add, HIReg dst, HIReg src1, HIConstant 0) -> mov dst src1
          (Add, SpillIReg d, SpillIReg s1, HIConstant 0) -> do
            mov eax (s1, ebp)
            mov (d, ebp) eax
          (Add, SpillIReg d, HIReg r1, HIConstant 0) -> mov (d, ebp) r1
          (Add, HIReg dst, SpillIReg r1, HIConstant 0) -> mov dst (r1, ebp)
          (Add, HIReg dst, HIConstant c1, HIConstant 0) -> mov dst (i32Tow32 c1)
          (Add, SpillIReg d, HIConstant c1, HIConstant 0) ->
            mov (d, ebp) (i32Tow32 c1)
          -- general case
          _ -> gd (select operation) dst' src1' src2'
    where
      gd :: (forall a b. (Sub a b, And a b, Add a b, Or a b, Xor a b)
                         => a -> b -> CodeGen e s ())
            -> HVarX86 -> HVarX86 -> HVarX86 -> CodeGen e s ()
      gd _ (SpillIReg d) (HIConstant c1) (HIConstant c2) = do
        let res = i32Tow32 $ case operation of
                    Add -> c1 + c2
                    And -> c1 .&. c2
                    Or -> c1 .|. c2
                    Xor -> c1 `DB.xor` c2
                    Sub -> error "emit: gd: opx: not sure if c1 - c2 or c2 - c1"
                    y -> error $ "emit: gd: opx: constant: " ++ show y
        mov (d, ebp) res
      gd opx (HIReg dst) (HIReg src1) (HIReg src2) = do
        mov dst src2
        opx dst src1
      gd opx dst src1 src2 = do
        r2r eax src2
        case src1 of
          HIConstant c -> opx eax (i32Tow32 c)
          HIReg r ->      opx eax r
          SpillIReg d ->  opx eax (d, ebp)
          y -> error $ "emit: gd: opx: src1: " ++ show y
        r2r dst eax
  
      -- edx is killed by `mul' instruction
      girMul = freeRegFor edx dst' $ gm dst' src1' src2'
      gm dst src1 src2
          | hvarIsConst src2 = gm' dst src2 src1
          | otherwise = gm' dst src1 src2
      gm' dst src1 src2 = do
        r2r eax src1
        case src2 of
          HIReg r -> mul r
          SpillIReg d -> mul (d, ebp)
          y -> error $ "emit: gm: src: " ++ show y
        r2r dst eax
  
      girShift :: (forall a b. (Shr a b, Sar a b, Sal a b)
                            => a -> b -> CodeGen e s ())
               -> CodeGen e s ()
      girShift shiftop = freeRegFor ecx dst' $ gs shiftop dst' src1' src2'
  
      gs :: (forall a b. (Shr a b, Sar a b, Sal a b)
                      => a -> b -> CodeGen e s ())
            -> HVarX86 -> HVarX86 -> HVarX86 -> CodeGen e s ()
      gs so (HIReg dst) (HIReg src1) (HIReg src2) = do
        mov dst src2
        mov ecx src1
        so dst cl
      gs so dst src1 src2 = do
        r2r eax src2
        r2r ecx src1
        so eax cl
        r2r dst eax
  
      girDiv resreg = -- `div' destroys eax and edx
        freeRegFor edx dst' $
          freeRegFor ebx dst' $ do
            r2r eax src2'
            r2r ebx src1'
  
            -- if null, then create exception-object in signal handler
            xor edx edx
            trapaddr <- getCurrentOffset
            modifyState (\s -> s { traps = M.insert trapaddr DivByNullException (traps s) })
            div ebx
            -- move result (depending on the operation) into destination
            r2r dst' resreg
  
  girEmitOO (IRInvoke (RTPoolCall cpidx mapping) haveReturn ct) = do
    let static = girStatic cpidx haveReturn ct mapping
    let virtual = girVirtual cpidx haveReturn ct mapping
    case ct of
      CallStatic -> static
      CallSpecial -> static
      CallVirtual -> virtual
      CallInterface -> virtual
  girEmitOO (IRLoad (RTPoolCall x mapping) (HIConstant 0) dst) = do
    cls <- classf <$> getState
    case constsPool cls M.! x of
      (CClass objname) -> do -- `new' object
        saveRegs
        trapaddr <- emitSigIllTrap 5
        callMallocGCPoint mapping
        restoreRegs
        -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
        mov (Disp objectMtable, eax) (0x13371337 :: Word32)
        mov (Disp objectGC, eax) (0 :: Word32)
        r2r dst eax
        let patcher wbr = do
              objsize <- liftIO $ getObjectSize objname
              push32 objsize
              callMalloc
              restoreRegs
              mtable <- liftIO $ getMethodTable objname
              mov (Disp objectMtable, eax) mtable
              mov (Disp objectGC, eax) (0 :: Word32)
              r2r dst eax
              return wbr
        modifyState (\s -> s { traps = M.insert trapaddr (NewObject patcher) (traps s)})
      e -> error $ "emit irload: missing impl.: " ++ show e
  
  girEmitOO (IRLoad (RTPool x) (HIConstant 0) dst) = do
    cls <- classf <$> getState
    case constsPool cls M.! x of
      (CString s) -> do -- load str (ldc)
        sref <- liftIO $ getUniqueStringAddr s
        r2r dst sref
      (CInteger i) -> r2r dst i -- load integer (ldc)
      (CField rc fnt) -> do -- getstatic
        let sfi = StaticField $ StaticFieldInfo rc (ntName fnt)
        trapaddr <- getCurrentOffset
        mov eax (Addr 0)
        r2r dst eax
        modifyState (\s -> s { traps = M.insert trapaddr sfi (traps s)})
      e -> error $ "emit: irload2: missing impl.: " ++ show e
  
  girEmitOO (IRLoad (RTPool x) src dst) = do
    cls <- classf <$> getState
    case constsPool cls M.! x of
      (CField rc fnt) -> -- getfield
        freeRegFor ebx dst $ do
          r2r eax src
          trapaddr <- emitSigIllTrap 7
          let patcher wbr = do
                offset <- liftIO $ fromIntegral <$> getFieldOffset rc (ntName fnt)
                mov ebx (Disp offset, eax)
                return wbr
          r2r dst ebx
          let ofp = ObjectField patcher
          modifyState (\s -> s { traps = M.insert trapaddr ofp (traps s)})
      y -> error $ "emit: irload: missing impl.: getfield or something: " ++ show y
  
  girEmitOO (IRLoad (RTArrayNew ta objType regmapping arrlen) (HIConstant 0) dst) = do
    freeRegFor ebx dst $ do
      let tsize = case decodeS (0 :: Integer) (B.pack [ta]) of
                    T_INT -> S4
                    T_CHAR -> S4
                    _ -> error "newarray: type not implemented yet"
      saveRegs
      r2r ebx arrlen
      lea eax (Disp $ 3 * ptrSize, ebx, tsize)
      push ebx -- save scratch ebx value
      push eax
      callMallocGCPoint regmapping
      restoreRegs
      pop ebx
      case objType of
        PrimitiveType -> mov (Disp arrayMagic, eax) (0x1228babe :: Word32)
        ReferenceType -> mov (Disp arrayMagic, eax) (0x1227babe :: Word32)
      mov (Disp arrayGC, eax) (0x0 :: Word32) -- gcinfo
      mov (Disp arrayLength, eax) ebx -- store length at offset 0
      r2r dst eax
  
  
  girEmitOO (IRLoad RTArrayLength src dst) = do -- arraylength
    r2r eax src
    mov eax (Disp arrayLength, eax)
    r2r dst eax
  
  girEmitOO (IRLoad (RTArrayIndex idx typ) src dst) =
      freeRegFor edx dst $ do
        case idx of
          HIConstant i -> mov eax $ (i32Tow32 i * typeSize typ) + arrayBase
          HIReg i -> lea eax (Disp arrayBase, i, typeSize' typ)
          SpillIReg d -> do
            mov eax (d, ebp)
            lea eax (Disp arrayBase, eax, typeSize' typ)
          y -> error $ "girEmitOO: irload: rtindex: idx: " ++ show y
        case src of
          HIReg s -> if s == edx then add eax (Disp 0, esp) else add eax s
          SpillIReg d -> add eax (d, ebp)
          y -> error $ "girEmitOO: irload: rtindex: src: " ++ show y
        case dst of
          HIReg d -> mov d (Disp 0, eax)
          SpillIReg d -> do
            mov edx (Disp 0, eax)
            mov (d, ebp) edx
          y -> error $ "girEmitOO: irload: rtindex: dst: " ++ show y
  
  girEmitOO (IRStore (RTPool x) obj src) = do
    cls <- classf <$> getState
    case constsPool cls M.! x of
      (CField rc fnt) ->
        if obj == HIConstant 0
          then do -- putstatic
            let sfi = StaticField $ StaticFieldInfo rc (ntName fnt)
            r2r eax src
            trapaddr <- getCurrentOffset
            mov (Addr 0) eax
            modifyState (\s -> s { traps = M.insert trapaddr sfi (traps s) })
          else do -- putfield
            push ebx
            r2r eax obj
            r2r ebx src
            -- like: 89 98 77 66 37 13       mov    %ebx,0x13376677(%eax)
            trapaddr <- emitSigIllTrap 6
            let patcher wbr = do
                  let (cname, fname) = buildFieldOffset cls x
                  offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
                  mov32RelEbxEax (Disp offset) -- set field
                  return wbr
            pop ebx
            modifyState (\s -> s{ traps = M.insert trapaddr (ObjectField patcher) (traps s)})
      e -> error $ "emit: irstore: missing impl.: " ++ show e
  girEmitOO (IRStore (RTArrayIndex idx typ) obj dst) =
      freeRegFor edx dst $ do
        case idx of
          HIConstant _ -> mov eax (0 :: Word32)
          HIReg i -> lea eax (Disp arrayBase, i, typeSize' typ)
          SpillIReg d -> do
            mov eax (d, ebp)
            lea eax (Disp arrayBase, eax, typeSize' typ)
          y -> error $ "girEmitOO: irstore: rtindex: idx: " ++ show y
        case obj of
          HIReg d -> if d == edx then add eax (Disp 0, esp) else add eax d
          SpillIReg d -> add eax (d, ebp)
          y -> error $ "girEmitOO: irstore: rtindex: dst: " ++ show y
        -- store array elem
        r2r edx dst
        case idx of
          HIConstant i -> mov (Disp ((+ arrayBase) . (* typeSize typ) $ i32Tow32 i), eax) edx
          _ -> mov (Disp 0, eax) edx
  
  girEmitOO ins@(IRStore{}) = error $ "irstore: emit: " ++ show ins
  girEmitOO (IRPush _ (HIReg x)) = push x
  girEmitOO (IRPush _ (HIConstant x)) = push (i32Tow32 x)
  girEmitOO (IRPush _ (SpillIReg d)) = push (d, ebp)
  girEmitOO (IRPrep SaveRegs regs) =
    forM_ regs $ \y -> case y of
      (HIReg x, _) -> mov (Disp (fromJust (saveReg x)), ebp) x
      _ -> return ()
  girEmitOO (IRPrep RestoreRegs regs) =
    forM_ regs $ \y -> case y of
      (HIReg x, _) -> mov x (Disp (fromJust (saveReg x)), ebp)
      _ -> return ()
  girEmitOO (IRMisc1 jins vreg) =
    case jins of
      ATHROW -> do
        r2r eax vreg
        trapaddr <- emitSigIllTrap 2
        let patcher wbr = do
              emitSigIllTrap 2
              liftIO $ handleExceptionPatcher wbr
        modifyState (\s -> s { traps = M.insert trapaddr (ThrowException patcher) (traps s) })
      CHECKCAST _ ->
        nop -- TODO ..
      x -> error $ "emit: misc1: " ++ show x
  girEmitOO (IRMisc2 jins dst src) =
    case jins of
      INSTANCEOF cpidx -> do
        cls <- classf <$> getState
        let movres :: Word32 -> CodeGen e s ()
            movres = r2r dst
        r2r eax src
        -- place something like `mov edx $mtable_of_objref' instead
        trapaddr <- emitSigIllTrap 4
        movres 0
        let patcher wbr = do
              emitSigIllTrap 4
              let classname = buildClassID cls cpidx
              check <- liftIO $ isInstanceOf (fromIntegral $ wbr M.! eax) classname
              movres (if check then 1 else 0)
              return $ M.update (Just . (+4)) eip wbr
        modifyState (\s -> s { traps = M.insert trapaddr (InstanceOf patcher) (traps s) })
      x -> error $ "emit: misc2: " ++ show x
  girEmitOO x = error $ "girEmitOO: insn not implemented: " ++ show x
  
  girStatic :: Word16 -> Maybe HVarX86 -> CallType -> PreGCPoint HVarX86
            -> CodeGen e CompileState ()
  girStatic cpidx haveReturn ct mapping = do
    cls <- classf <$> getState
    let hasThis = ct == CallSpecial
    let l = buildMethodID cls cpidx
    newNamedLabel (show l) >>= defineLabel
    -- like: call $0x01234567
    calladdr <- emitSigIllTrap 5
    let patcher wbr = do
          entryAddr <- liftIO $ lookupMethodEntry l
          call (fromIntegral (entryAddr - ((wbr M.! eip) + 5)) :: NativeWord)
          return wbr
    setGCPoint mapping
    -- discard arguments on stack
    let argcnt = ((if hasThis then 1 else 0)
                 + methodGetArgsCount (methodNameTypeByIdx cls cpidx)
                 ) * ptrSize
    when (argcnt > 0) (add esp argcnt)
  
    case haveReturn of
      Just (HIReg dst) -> when (dst /= eax) $ mov dst eax
      Just y -> error $ "girStatic: haveReturn: " ++ show y
      Nothing -> return ()
    modifyState (\s -> s { traps = M.insert calladdr (StaticMethod patcher) (traps s) })
  
  girVirtual :: Word16 -> Maybe HVarX86 -> CallType -> PreGCPoint HVarX86
             -> CodeGen e CompileState ()
  girVirtual cpidx haveReturn ct mapping = do
    let isInterface = ct == CallInterface
    cls <- classf <$> getState
    let mi@(MethodInfo methodname objname msig@(MethodSignature _ _)) =
            buildMethodID cls cpidx
    newNamedLabel (show mi) >>= defineLabel
    -- get method offset for call @ runtime
    let offset :: IO NativeWord
        offset =
          (if isInterface then getInterfaceMethodOffset else getMethodOffset)
            objname methodname (encode msig)
    -- objref lives somewhere on the argument stack
    mov ebx (Disp 0, esp)
    when isInterface $
      mov ebx (Disp objectMtable, ebx) -- get method-table-ptr, keep it in ebx
    -- get method-table-ptr (or interface-table-ptr)
    mov eax (Disp objectMtable, ebx)
    -- make actual (indirect) call
    calladdr <- getCurrentOffset
    -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
    emitSigIllTrap 6
    setGCPoint mapping
  
    -- discard arguments on stack (`+1' for "this")
    let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
    when (argcnt > 0) (add esp argcnt)
  
    case haveReturn of
      Just (HIReg dst) -> mov dst eax
      Nothing -> return ()
      Just y -> error $ "girVirtual: haveReturn: " ++ show y
    -- note, that "mi" has the wrong class reference here.
    -- we figure that out at run-time, in the methodpool,
    -- depending on the method-table-ptr
    modifyState (\s -> s { traps = M.insert calladdr
                          (VirtualCall isInterface mi offset)
                          (traps s) })
  
  setGCPoint :: [(HVarX86, VarType)] -> CodeGen e CompileState ()
  setGCPoint mapping = do
    ip <- getCurrentOffset
    -- liftIO $ printfJit "setGCPoint: unfiltered:\n"
    -- liftIO $ forM_ mapping $ \x -> do
    --               printfJit $ printf "\t%s\n" (show x)
    let filtered = filterJRefs mapping
    -- liftIO $ printfJit "setGCPoint: filtered:\n"
    -- liftIO $ forM_ filtered $ \x -> do
    --               printfJit $ printf "\t0x%08x\n" x
    modifyState (\s -> s { gcpoints = M.insert ip filtered (gcpoints s)})
  
  
  filterJRefs :: [(HVarX86, VarType)] -> GCPoint
  filterJRefs = mapMaybe frefs
    where
      frefs (SpillIReg (Disp d), JRef) = Just d
      frefs (HIReg reg32, JRef) = saveReg reg32
      frefs _ = Nothing
  
  freeRegFor :: Reg32 -> HVarX86 -> CodeGen e s r -> CodeGen e s r
  freeRegFor r32 dst body = do
    let isNotDst =
          case dst of
            HIReg dst' -> dst' /= r32
            _ -> True
    push r32
    res <- body
    if isNotDst
      then pop r32
      else add esp (4 :: Word32)
    return res
  
  -- transfer between "HVar" and real maschine registers
  class RegisterToRegister a b where
    r2r :: a -> b -> CodeGen e s ()
  
  instance RegisterToRegister HVarX86 Word32 where
    r2r (HIReg reg) src = mov reg src
    r2r (SpillIReg disp) src = mov (disp, ebp) src
    r2r i _ = error $ "r2r HVarX86 Word32: " ++ show i
  
  instance RegisterToRegister HVarX86 Reg32 where
    r2r (HIReg reg) src = mov reg src
    r2r (SpillIReg disp) src = mov (disp, ebp) src
    r2r i _ = error $ "r2r HVarX86 Reg32: " ++ show i
  
  instance RegisterToRegister Reg32 HVarX86 where
    r2r dst (HIReg reg) = mov dst reg
    r2r dst (SpillIReg disp) = mov dst (disp, ebp)
    r2r dst (HIConstant i32) = mov dst (i32Tow32 i32)
    r2r _ not_yet = error $ "r2r Reg32 HVarX86: not impl. yet: " ++ show not_yet
  
  hvarIsConst :: HVarX86 -> Bool
  hvarIsConst (HIConstant _) = True
  hvarIsConst (HFConstant _) = True
  hvarIsConst _ = False
  
  saveReg :: Reg32 -> Maybe Word32
  saveReg (Reg32 w8) =
    case w8 of
      0 {- eax -} -> Nothing
      1 {- ecx -} -> Just 0xfffffffc
      2 {- edx -} -> Just 0xfffffff8
      3 {- ebx -} -> Just 0xfffffff4
      4 {- esp -} -> error "saveReg: esp???"
      5 {- ebp -} -> error "saveReg: ebp???"
      6 {- esi -} -> Just 0xfffffff0
      7 {- edi -} -> Just 0xffffffec
      _ -> error "saveReg: ?????"
  
  saveRegs :: CodeGen e s ()
  saveRegs =
    forM_ x86callersave $ \x ->
      mov (Disp (fromJust (saveReg x)), ebp) x
  
  restoreRegs :: CodeGen e s ()
  restoreRegs =
    forM_ x86callersave $ \x ->
      mov x (Disp (fromJust (saveReg x)), ebp)
  
  -- helper
  callMalloc :: CodeGen e s ()
  callMalloc = do
    push ebp
    ip <- getCurrentOffset
    push ip
    call mallocObjectAddr
    add esp ((3 * ptrSize) :: Word32)
  
  callMallocGCPoint :: PreGCPoint HVarX86 -> CodeGen e CompileState ()
  callMallocGCPoint regmapping = do
    push ebp
    setGCPoint regmapping
    ip <- getCurrentOffset
    push ip
    call mallocObjectAddr
    add esp ((3 * ptrSize) :: Word32)
  
  
  -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
  -- however, this is bad for patching so we want to put always 32bit.
  
  -- push imm32
  push32 :: Word32 -> CodeGen e s ()
  push32 imm32 = emit8 0x68 >> emit32 imm32
  
  -- mov %ebx, disp32(%eax)
  mov32RelEbxEax :: Disp -> CodeGen e s ()
  mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32
  
  emitSigIllTrap :: Int -> CodeGen e s NativeWord
  emitSigIllTrap traplen = do
    when (traplen < 2) (error "emitSigIllTrap: trap len too short")
    trapaddr <- getCurrentOffset
    -- 0xffff causes SIGILL
    emit8 (0xff :: Word8); emit8 (0xff :: Word8)
    -- fill rest up with NOPs
    sequence_ [nop | _ <- [1 .. (traplen - 2)]]
    return trapaddr
  
  getCurrentOffset :: CodeGen e s Word32
  getCurrentOffset = do
    ep <- (fromIntegral . ptrToIntPtr) <$> getEntryPoint
    offset <- fromIntegral <$> getCodeOffset
    return $ ep + offset
  
  typeSize :: Num a => VarType -> a
  typeSize JInt = 4
  typeSize JRef = 4
  typeSize x = error $ "typeSize: " ++ show x
  
  typeSize' :: VarType -> Scale
  typeSize' vt = case typeSize vt :: Integer of
    1 -> S1; 2 -> S2; 4 -> S4
    y -> error $ "codegen: typeSize': not supported size: "
               ++ show y ++ ", " ++ show vt
  
  handleExceptionPatcher :: ExceptionHandler
  handleExceptionPatcher wbr' = do
    printfEx $ printf "eip of exception: %08x\n" (fromIntegral (wbr' M.! eip) :: Word32)
    handleException wbr'
      where
        unwindStack :: WriteBackRegs -> IO WriteBackRegs
        unwindStack wbr = do
          let rebp = wbr M.! ebp
          let nesp = rebp + 8
          -- get ebp of caller
          nebp <- peek . intPtrToPtr . fromIntegral $ nesp - 4
          printfEx $ printf "nebp: 0x%08x\n" (fromIntegral nebp :: Word32)
          printfEx $ printf "nesp: 0x%08x\n" (fromIntegral nesp :: Word32)
          printfEx $ printWbr wbr
          -- get return addr
          neip <- peek . intPtrToPtr . fromIntegral $ nesp
          printfEx $ printf "neip: 0x%08x\n" (fromIntegral neip :: Word32)
          wbrnew <- forM x86callersave $ \reg ->
                      peek (plusPtr
                              (intPtrToPtr . fromIntegral $ nebp)
                              (fromIntegral . fromJust $ saveReg reg))
          let wbrnew' = foldl (\m (reg,val) -> M.insert reg val m)
                              wbr (zip x86callersave wbrnew)
          handleException $ M.insert eip neip
                          $ M.insert ebp nebp
                          $ M.insert esp nesp wbrnew'
  
        handleException :: WriteBackRegs -> IO WriteBackRegs
        handleException wbr = do
          -- get full exception map from stack
          stblptr <- peek (intPtrToPtr . fromIntegral $ rebp) :: IO Word32
          let sptr = castPtrToStablePtr $ intPtrToPtr $ fromIntegral stblptr
          stackinfo <- deRefStablePtr sptr :: IO RuntimeStackInfo
          let exmap = rsiExceptionMap stackinfo
          printfEx $ printf "methodname: %s\n" (toString $ rsiMethodname stackinfo)
          printfEx $ printf "size: %d\n" (IM.size exmap)
          printfEx $ printf "exmap: %s\n" (show exmap)
  
          -- find the handler in a region. if there isn't a proper
          -- handler, go to the caller method (i.e. unwind the stack)
          let searchRegion :: [IM.Interval Word32] -> IO WriteBackRegs
              searchRegion [] = do
                printfEx "unwind stack now. good luck(x)\n\n"
                unwindStack wbr
              searchRegion (r:rs) = do
                -- let's see if there's a proper handler in this range
                res <- findHandler r exmap
                case res of
                  Just x -> return x
                  Nothing -> searchRegion rs
          searchRegion . map fst $ exmap `IM.containing` (fromIntegral (wbr M.! eip))
            where
              rebp = wbr M.! ebp
  
              findHandler :: IM.Interval Word32 -> ExceptionMap Word32 -> IO (Maybe WriteBackRegs)
              findHandler key exmap = do
                printfEx $ printf "key is: %s\n" (show key)
                -- reverse the list to get the innermost handler (see
                -- ./tests/Exception11.java )
                let handlerObjs = reverse
                                $ sortBy (comparing snd)
                                $ exmap IM.! key
                printfEx $ printf "handlerObjs: %s\n" (show handlerObjs)
  
                let myMapM :: (a -> IO (Maybe Word32)) -> [a] -> IO (Maybe WriteBackRegs)
                    myMapM _ [] = return Nothing
                    myMapM g (x:xs) = do
                      r <- g x
                      case r of
                        Just y -> return $ Just $ M.insert eip (fromIntegral y) wbr
                        Nothing -> myMapM g xs
                let f :: (B.ByteString, Word32) -> IO (Maybe Word32)
                    f (x, y) = do
                          printfEx $ printf "looking at @ %s\n" (show x)
                          -- on B.empty, it's the "generic handler"
                          -- (e.g. finally)
                          x' <- if x == B.empty then return True else isInstanceOf (fromIntegral (wbr M.! eax)) x
                          return $ if x' then Just y else Nothing
                -- by using myMapM, we avoid to look at *every* handler,
                -- but abort on the first match (yes, it's rather
                -- ugly :/ better solutions are welcome)
                myMapM f handlerObjs
  