\ignore{
\begin{code}
module GCodeToJava where

import Control.Monad (when)
import Data.List

import Brianweb.Java as J

import GCode as G
import GCodeSysDeps
import GCodeUtils (fallsThrough)

import ForeignCall
import TysPrim 
import FastString
import Outputable
import Util
import OrdList
import Maybes

#include "HsVersions.h"
\end{code}
}

\begin{code}
cRTS :: String -> ClassRef
cRTS x = "org.haskell.ghc.rts." ++ x

cConc,cR,cPrim,cCode,cClosure,cClosureInd,cFun,cMutVar,cMVar,cTVar,cStableName :: ClassRef
cConc = cRTS "Conc";  
cR = cRTS "R"
cPrim = cRTS "Prim"
cCode = cRTS "Code"
cClosure = cRTS "Closure"
cClosureInd = cRTS "Closure$Ind"
cFun = cRTS "Closure$Fun"
cMutVar = cRTS "MutVar"
cMVar = cRTS "MVar"
cTVar = cRTS "TVar"
cStableName = cRTS "StableName"

tCode,tClosure,tClosureInd,tMutVar,tMVar,tTVar,tStableName :: J.Type
tCode = TClass cCode
tClosure = TClass cClosure
tClosureInd = TClass cClosureInd
tMutVar = TClass cMutVar
tMVar = TClass cMVar
tTVar = TClass cTVar
tStableName = TClass cStableName
\end{code}

\begin{code}
type Insn = Instruction
type Insns = OrdList Insn
newtype MethodM a = MethodM { runMethodM :: Label -> (a,Label,Insns) }

instance Monad MethodM where
    return x = MethodM $ \i -> (x,i,nilOL)
    m >>= k = MethodM $ \s1 -> 
        let
            (a,s2,is) = runMethodM m s1
            (b,s3,is') = runMethodM (k a) s2
        in (b,s3,is`appOL`is')

mFix :: (a -> MethodM a) -> MethodM a
mFix k = MethodM $ \s1 -> let (a,s2,is) = runMethodM (k a) s1 in (a,s2,is)

mInsns :: Insns -> MethodM ()
mInsns is = MethodM $ \s -> ((),s,is)

mInsn :: Insn -> MethodM ()
mInsn = mInsns . unitOL

mNewLabel :: MethodM Label
mNewLabel = MethodM $ \s -> (s,s+1,nilOL)
\end{code}

\begin{code}
javaSig :: Signature -> ([J.Type],Maybe J.Type)
javaSig sig@(args@(_:_),s:ret:rest)
    = ASSERT2(is_state (last args) && is_state s && null rest,ppr sig)
      (map javaType (init args),javaType_maybe ret)
    where
        is_state (PrimTy tc _) = tc == statePrimTyCon
        is_state _ = False
javaSig sig = pprPanic "javaSig" (ppr sig)
\end{code}

\begin{code}
buildModule :: GenModule Int -> Maybe FilePath -> [Class]
buildModule (Module name cs gs ss es) source 
    = map (\c -> c{c_sourcefile=source}) (top : cls)
    where
        this = unpackFS name
        fields = map buildGlobal gs
        is = buildMethod ss `snocOL` J.Return Nothing
        clinit = defaultMethod
            {m_flags=[],J.m_name="<clinit>"
            ,m_code=Just defaultCode{c_instructions=fromOL is}}
        exports = map (buildExport name) es
        top = defaultClass{c_this=this,c_fields=fields,c_methods=clinit:exports}
        cls = map (buildClosure name) cs
        
buildGlobal :: GlobalDecl -> J.Field
buildGlobal (GlobalDecl name ty exported) = defaultField
    {f_flags=(if exported then (Public:) else id) [Static,Final]
    ,f_name=unpackFS name
    ,f_type=javaType ty}
\end{code}

\begin{code}
buildExport :: Name -> Export -> Method
buildExport mod_name (Export name (JVMExport entity) sig@(args,rets))
    = defaultMethod
        {m_flags=[Public,Static],J.m_name=unpackFS entity
        ,m_args=jargs,m_ret=jret
        ,m_code=Just defaultCode{c_instructions=fromOL is}}
    where
        (jargs,jret) = javaSig sig
        is = prolog `appOL` buildMethod ss `appOL` epilog
        argLocs = zipWith Var args (scanl (\i ty -> i + typeSize ty) 0 args)
        retLocs = zipWith Var rets (scanl (\i ty -> i + typeSize ty) 0 rets)
        funLoc = Global LiftedTy (mod_name,name)
        prolog = toOL 
            [Invoke IStatic (MethodRef cConc "enterHaskell" [] Nothing)
            ,Note (Try 1 2 Nothing)]
        ss = toOL [Move var reg|(var,reg)<- allocRegs locType argLocs]
                `appOL` unitOL (Call (FunCall funLoc))
                `appOL` toOL [Move reg var|(var,reg)<-allocRegs locType retLocs]
        epilog = toOL
            [Note (Label 1)
            ,Invoke IStatic (MethodRef cConc "leaveHaskell" [] Nothing)
            ,maybe Nop (`Load`0) jret
            ,J.Return jret
            ,Note (Label 2)
            ,Invoke IStatic (MethodRef cConc "leaveHaskell" [] Nothing)
            ,Throw cThrowable]
buildExport _ (Export _ fexport _) = pprPanic "buildExport" (ppr fexport)
\end{code}

\begin{code}
buildMethod :: GenStmnts Int -> Insns
buildMethod ss = let (_,_,is) = runMethodM (mapM_ buildStmnt (fromOL ss)) 10 in is
\end{code}

\begin{code}
buildClosure :: Name -> GenClosure Int -> Class
buildClosure mod_name (Closure name payload thetag upd ss) 
    = defaultClass{c_this=this,c_super=Just super
                  ,c_interfaces=interfaces
                  ,c_fields=fields
                  ,c_methods=[init,exec,tag]}
    where
        is = buildMethod ss
        this = unpackFS mod_name ++ "$" ++ unpackFS name
        super = if isUpdatable upd then cClosureInd else cClosure
        interfaces = if isReEntrant upd then [cFun] else []
        fields = [defaultField{f_name='_':show i,f_type=javaType ty}
                 |(ty,i) <- payload `zip` [(0::Int)..]
                 ,not (typeIsVoid ty)]
        init = defaultMethod{J.m_name="<init>"
                            ,m_code=Just defaultCode{c_instructions=
                            [Load (TClass this) 0
                            ,Invoke ISpecial (MethodRef super "<init>" [] Nothing)
                            ,J.Return Nothing]}}
        exec = defaultMethod{J.m_name="exec",m_ret=Just tCode
                            ,m_code=Just defaultCode{c_instructions=
                            fromOL (prolog `appOL` is)}}
        tag  = defaultMethod{J.m_name="info",m_ret=Just TInt
                            ,m_code=Just defaultCode{c_instructions=
                            [Const (CInt thetag),J.Return (Just TInt)]}}
        prolog
            | isUpdatable upd = toOL
                [Load (TClass cClosureInd) 0,Get False (FieldRef cClosureInd "ind" tClosure) -- top = this.ind
                ,Dup tClosure,If (IsNull tClosure) 0 -- if(top != null) {
                ,Put True (FieldRef cR "c0" tClosure)-- c0 = top;
                ,Const CNull,J.Return (Just tCode)  -- return null;
                ,Note (Label 0), Pop tClosure]       -- }
            | otherwise = nilOL
\end{code}

\begin{code}
regClassType :: RegClass -> J.Type
regClassType 'c' = tClosure
regClassType 'o' = tObject
regClassType 'i' = TInt
regClassType 'l' = TLong
regClassType 'f' = TFloat
regClassType 'd' = TDouble
regClassType c = pprPanic "regClassType" (char c)
\end{code}

\begin{code}
push :: GenLoc Int -> MethodM ()
push loc | typeIsVoid (locType loc) = return ()
push (Var ty i) = mInsn (Load (javaType ty) (fromIntegral i))
push (G.Field o ty i) = do
    push o
    mInsn (Get False (FieldRef (unClass (javaType (locType o))) ('_':show i) (javaType ty)))
    case ty of
        PrimTy tc [] | tc == word8PrimTyCon -> mInsns (toOL [Const (CInt 0xff),Arith And TInt])
        _ -> return()
push(Reg ty i) = do
    mInsn (Get True (FieldRef cR (reg_class : show i) reg_ty))
    when (isRef reg_ty && real_ty /= reg_ty) (mInsn (CheckCast real_ty))
    where
        reg_class = regClass ty
        reg_ty = regClassType reg_class
        real_ty = javaType ty
push (Global ty (m,n)) = mInsn (Get True (FieldRef (unpackFS m) (unpackFS n) (javaType ty)))
push (Literal lit) = mInsn (Const (buildConst lit))
    where
        buildConst (LInt i) = CInt i
        buildConst (LLong l) = CLong l
        buildConst (LFloat f) = CFloat f
        buildConst (LDouble d) = CDouble d
        buildConst (LString s) = CString (unpackFS s)
        buildConst (LNull _) = CNull
\end{code}

\begin{code}
pop :: GenLoc Int -> MethodM () -> MethodM ()
pop loc gen | typeIsVoid (locType loc) = gen
pop (Var ty i) gen = gen >> mInsn (Store (javaType ty) (fromIntegral i))
pop (G.Field o ty i) gen = do
    push o
    gen
    mInsn (Put False (FieldRef (unClass (javaType (locType o))) ('_':show i) (javaType ty)))
pop (Reg ty i) gen = do
    gen
    mInsn (Put True (FieldRef cR (reg_class : show i) reg_ty))
    where
        reg_class = regClass ty
        reg_ty = regClassType reg_class
pop (Global ty (m,n)) gen = gen >> mInsn (Put True (FieldRef (unpackFS m) (unpackFS n) (javaType ty)))
pop (Literal lit) _ = pprPanic "pop" (ppr lit)
\end{code}

\begin{code}
buildStmnt :: GenStmnt Int -> MethodM ()
buildStmnt (Move src dst) = pop dst (push src)
buildStmnt (Alloc (m,n) loc) 
    = pop loc (mInsns (toOL 
        [New cr,Dup (TClass cr)
        ,Invoke ISpecial (MethodRef cr "<init>" [] Nothing)]))
    where
        cr = unpackFS m ++ "$" ++ unpackFS n
buildStmnt (G.Switch loc arms def) = buildSwitch loc arms def
buildStmnt (PrimOp op ty_args args rets) = buildPrimOp op ty_args args rets
buildStmnt (Foreign fcall sig args rets) = buildForeign fcall sig args rets
buildStmnt (Call call) = buildCall False call
buildStmnt (TailCall call) = buildCall True call
buildStmnt G.Return = mInsns (Const CNull `consOL` J.Return (Just tCode) `consOL` nilOL)
buildStmnt (Update loc) = do
    mInsn (Load tClosureInd 0)
    push loc
    mInsn (Put False (FieldRef cClosureInd "ind" tClosure))
buildStmnt (Trim _) = return ()
\end{code}

\begin{code}
buildCall :: Bool -> GenCall Int -> MethodM ()
buildCall tail call = do
    case call of
        FunCall loc -> push loc
        RtsCall name -> mInsn (Get True (FieldRef cPrim (unpackFS name) tCode))
    if tail
        then mInsn (J.Return (Just tCode))
        else do
            l <- mNewLabel
            mInsns (toOL
                [Note (Label l)
                ,Invoke IVirtual (MethodRef cCode "exec" [] (Just tCode))
                ,Dup tCode
                ,J.If (IsNonNull tCode) l
                ,Pop tCode])
\end{code}

\begin{code}
buildSwitch :: GenLoc Int -> [(Tag,GenStmnts Int)] -> GenStmnts Int -> MethodM ()
buildSwitch loc arms def = do
    push loc
    case locType loc of
        ty@PrimTy{} -> case javaType ty of
            TInt -> return ()
            TBool -> return ()
            _ -> pprPanic "buildSwitch" (ppr ty)
        _ -> mInsn (Invoke IVirtual (MethodRef cClosure "info" [] (Just TInt)))
    done <- mNewLabel
    case arms of
        [] -> mapM_ buildStmnt (fromOL def)
        [(tag,body)] -> do
            label <- mNewLabel
            mInsn (Const (CInt tag))
            mInsn (If CmpNe label)
            mapM_ buildStmnt (fromOL body)
            when (fallsThrough body) (mInsn (Goto done))
            mInsn (Note (Label label))
            mapM_ buildStmnt (fromOL def)
        _ -> 
            let
                buildArm (tag,body) = do
                    label <- mNewLabel
                    mInsn (Note (Label label))
                    mapM_ buildStmnt (fromOL body)
                    when (fallsThrough body) (mInsn (Goto done))
                    return (tag,label)
            in (mFix $ \switch_insn -> do
                mInsn switch_insn
                arms' <- mapM buildArm arms
                def' <- mNewLabel
                mInsn (Note (Label def'))
                mapM_ buildStmnt (fromOL def)
                return (J.Switch (switchType (map fst arms))  def' arms')
                ) >> return ()
    mInsn (Note (Label done))
\end{code}


\begin{code}
buildForeign :: ForeignCall -> Signature -> [GenLoc Int] -> [GenLoc Int] -> MethodM ()
buildForeign (JVMCall (JVMCallSpec target safety)) sig args rets
    = ASSERT(fst sig `equalLength` args && snd sig `equalLength` rets)
      foldr pop (mInsns pre >> mapM_ push args >> invoke') rets
    where
        pre = case target of
            JVMInit -> toOL [New ret_cr,Dup (TClass ret_cr)]
            _ -> nilOL
        invoke = case target of
            JVMInit -> ASSERT(maybeToBool jret) Invoke ISpecial (MethodRef ret_cr "<init>"  jargs Nothing)
            JVMMethod Nothing m -> ASSERT(notNull args) Invoke IVirtual (MethodRef arg_cr m (tail jargs) jret)
            JVMMethod (Just cr) m -> Invoke IStatic (MethodRef cr m jargs jret)
            JVMField Nothing f 
                | Just t <- jret -> ASSERT(jargs `lengthIs` 1) Get False (FieldRef arg_cr f t)
                | otherwise      -> ASSERT(jargs `lengthIs` 2) Put False (FieldRef arg_cr f (head (tail jargs)))
            JVMField (Just cr) f
                | Just t <- jret -> ASSERT(jargs `lengthIs` 0) Get True  (FieldRef cr f t)
                | otherwise      -> ASSERT(jargs `lengthIs` 1) Put True  (FieldRef cr f (head jargs))
        invoke'
            | playSafe safety = do
                l1 <- mNewLabel
                l2 <- mNewLabel
                mInsns $ toOL
                    [Invoke IStatic (MethodRef cConc "leaveHaskell" [] Nothing)
                    ,Note (Try l1 l1 Nothing)
                    ,invoke
                    ,Goto l2
                    ,Note (Label l1)
                    ,Invoke IStatic (MethodRef cConc "enterHaskell" [] Nothing)
                    ,Throw cThrowable
                    ,Note (Label l2)
                    ,Invoke IStatic (MethodRef cConc "enterHaskell" [] Nothing)]
            | otherwise = mInsn invoke
        (jargs,jret) = javaSig sig
        arg_cr = unClass (head jargs)
        ret_cr = unClass (expectJust "buildForeign" jret)
buildForeign fcall _ _ _ = pprPanic "buildForeign" (ppr fcall)
\end{code}

\begin{code}
buildPrimOp :: PrimOp -> [G.Type] -> [GenLoc Int] -> [GenLoc Int] -> MethodM ()
-- First we take care of the really weird ones
buildPrimOp IntAddCOp [] [a,b] [r,c] = carryOp False a b r c 
buildPrimOp IntSubCOp [] [a,b] [r,c] = carryOp True  a b r c
buildPrimOp IntMulMayOfloOp [] [a,b] [c] = mulIntMayOfloOp a b c
buildPrimOp NewArrayOp [a,_] [len,def,_] [_,r] 
    = pop r $ do
        push len
        mInsn (NewArray (javaType a) 1)
        mInsn (Dup (TArray (javaType a)))
        push def
        mInsn (Invoke IStatic (MethodRef "java.util.Arrays" "fill" [TArray tObject,tObject] Nothing))
buildPrimOp NewMutVarOp [a,_] [x,_] [_,r] 
    = pop r $ do
        mInsn (New cMutVar)
        mInsn (Dup tMutVar)
        push x
        mInsn (Invoke ISpecial (MethodRef cMutVar "<init>" [javaType a] Nothing))
buildPrimOp InstanceOfOp [u,v] [a] [r]
    = pop r $ do
        l1 <- mNewLabel
        l2 <- mNewLabel
        push a
        mInsns $ toOL
            [Dup (javaType u)
            ,InstanceOf (javaType v)
            ,If IsZero l1
            ,CheckCast (javaType v)
            ,Goto l2
            ,Note (Label l1)
            ,Pop (javaType u)
            ,Const CNull
            ,Note (Label l2)]
-- Comparison operations are all pretty much the same but some require conversons, widening, etc
buildPrimOp op ty_args args [r]
    | Just (widen,pre,test) <- primOpCmp op ty_args = cmpOp widen pre test args r
-- All the float trig ops need to be converted to Double first
buildPrimOp op [] args [ret]
    | Just insn <- primOpAsDouble op
    = pop ret $ do
        mapM_ (\a -> push a >> mInsn (Convert TFloat TDouble)) args
        mInsn insn
        mInsn (Convert TDouble TFloat)
-- Some word ops need to be converted to Long first
buildPrimOp op [] args [ret]
    | Just insn <- primOpAsLong op
    = pop ret $ do
        mapM_ (\a -> push a >> mInsns (toOL
            [Convert TInt TLong
            ,Const (CInt 0xffffffff)
            ,Arith And TLong])) args
        mInsn insn
        mInsn (Convert TLong TInt)
-- All the normal ones fall under primOpInsns
buildPrimOp op ty_args args rets 
    | Just insns <- primOpInsns op ty_args  = foldr pop (mapM_ push args >> mInsns insns) rets
buildPrimOp op _ _ _ = pprPanic "buildPrimOp" (ppr op)

primOpInsns :: PrimOp -> [G.Type] -> Maybe Insns
primOpInsns NotOp         [] = Just (toOL [Const (CInt (-1)),Arith Xor TInt])
primOpInsns IndexUArrayOp [PrimTy tc []]
    | tc == word8PrimTyCon = Just (toOL [ALoad TByte,Const (CInt 0xff),Arith And TInt])
primOpInsns ReadUArrayOp [_,PrimTy tc []]
    | tc == word8PrimTyCon = Just (toOL [ALoad TByte,Const (CInt 0xff),Arith And TInt])
primOpInsns ParOp         [a] = Just (toOL [Pop (javaType a),Const (CInt 1)]) -- Dummy version
primOpInsns CastOp [u,v] = castOp u v
primOpInsns op ty_args 
    | Just insn <- primOpInsn op ty_args = Just (unitOL insn)
primOpInsns op _ 
    | primOpNop op = Just nilOL
primOpInsns _ _ = Nothing

primOpInsn :: PrimOp -> [G.Type] -> Maybe Insn
primOpInsn IntAddOp  [] = Just (Arith Add TInt)
primOpInsn IntSubOp  [] = Just (Arith Sub TInt)
primOpInsn IntMulOp  [] = Just (Arith Mul TInt)
primOpInsn IntQuotOp [] = Just (Arith Div TInt)
primOpInsn IntRemOp  [] = Just (Arith Rem TInt)
primOpInsn IntNegOp  [] = Just (Arith Neg TInt)
primOpInsn ISllOp [] = Just (Arith Shl  TInt)
primOpInsn ISraOp [] = Just (Arith Shr  TInt)
primOpInsn ISrlOp [] = Just (Arith UShr TInt)

primOpInsn WordAddOp  [] = Just (Arith Add TInt)
primOpInsn WordSubOp  [] = Just (Arith Sub TInt)
primOpInsn WordMulOp  [] = Just (Arith Mul TInt)
primOpInsn AndOp      [] = Just (Arith And TInt)
primOpInsn OrOp       [] = Just (Arith Or  TInt)
primOpInsn XorOp      [] = Just (Arith Xor TInt)
primOpInsn SllOp      [] = Just (Arith Shl  TInt)
primOpInsn SrlOp      [] = Just (Arith UShr TInt)

primOpInsn DoubleAddOp [] = Just (Arith Add TDouble)
primOpInsn DoubleSubOp [] = Just (Arith Sub TDouble)
primOpInsn DoubleMulOp [] = Just (Arith Mul TDouble)
primOpInsn DoubleDivOp [] = Just (Arith Div TDouble)
primOpInsn DoubleNegOp [] = Just (Arith Neg TDouble)
primOpInsn DoubleExpOp  [] = Just (Invoke IStatic (MethodRef cMath "exp"  [TDouble] (Just TDouble)))
primOpInsn DoubleLogOp  [] = Just (Invoke IStatic (MethodRef cMath "log"  [TDouble] (Just TDouble)))
primOpInsn DoubleSqrtOp [] = Just (Invoke IStatic (MethodRef cMath "sqrt" [TDouble] (Just TDouble)))
primOpInsn DoubleSinOp  [] = Just (Invoke IStatic (MethodRef cMath "sin"  [TDouble] (Just TDouble)))
primOpInsn DoubleCosOp  [] = Just (Invoke IStatic (MethodRef cMath "cos"  [TDouble] (Just TDouble)))
primOpInsn DoubleTanOp  [] = Just (Invoke IStatic (MethodRef cMath "tan"  [TDouble] (Just TDouble)))
primOpInsn DoubleAsinOp [] = Just (Invoke IStatic (MethodRef cMath "asin" [TDouble] (Just TDouble)))
primOpInsn DoubleAcosOp [] = Just (Invoke IStatic (MethodRef cMath "acos" [TDouble] (Just TDouble)))
primOpInsn DoubleAtanOp [] = Just (Invoke IStatic (MethodRef cMath "atan" [TDouble] (Just TDouble)))
primOpInsn DoubleSinhOp [] = Just (Invoke IStatic (MethodRef cMath "sinh" [TDouble] (Just TDouble)))
primOpInsn DoubleCoshOp [] = Just (Invoke IStatic (MethodRef cMath "cosh" [TDouble] (Just TDouble)))
primOpInsn DoubleTanhOp [] = Just (Invoke IStatic (MethodRef cMath "tanh" [TDouble] (Just TDouble)))
primOpInsn DoublePowerOp [] = Just (Invoke IStatic (MethodRef cMath "pow" [TDouble,TDouble] (Just TDouble)))

primOpInsn FloatAddOp [] = Just (Arith Add TFloat)
primOpInsn FloatSubOp [] = Just (Arith Sub TFloat)
primOpInsn FloatMulOp [] = Just (Arith Mul TFloat)
primOpInsn FloatDivOp [] = Just (Arith Div TFloat)
primOpInsn FloatNegOp [] = Just (Arith Neg TFloat)

primOpInsn IndexArrayOp [a]   = Just (ALoad (javaType a))
primOpInsn ReadArrayOp  [a,_] = Just (ALoad (javaType a))
primOpInsn WriteArrayOp [a,_] = Just (AStore (javaType a))

primOpInsn NewUArrayOp           [_,u] = Just (NewArray (javaType u) 1)
primOpInsn NewPinnedUArrayOp     [_,u] = Just (NewArray (javaType u) 1)
primOpInsn UArrayLengthOp        [u]   = Just (ALength (javaType u))
primOpInsn MutableUArrayLengthOp [_,u] = Just (ALength (javaType u))
primOpInsn IndexUArrayOp         [u]   = Just (ALoad (javaType u))
primOpInsn ReadUArrayOp          [_,u] = Just (ALoad (javaType u))
primOpInsn WriteUArrayOp         [_,u] = Just (AStore (javaType u))
primOpInsn UArrayCopyOp          [_,_] = Just (Invoke IStatic (MethodRef "java.lang.System" "arraycopy" [tObject,TInt,tObject,TInt,TInt] Nothing))

primOpInsn CheckCastOp [_,v] = Just (CheckCast (javaType v))

primOpInsn ReadMutVarOp [a,_] = Just (Get False (FieldRef cMutVar "value" (javaType a)))
primOpInsn WriteMutVarOp [a,_] = Just (Put False (FieldRef cMutVar "value" (javaType a)))

primOpInsn MyThreadIdOp [] = Just (Invoke IStatic (MethodRef "java.lang.Thread" "currentThread" [] (Just (TClass "java.lang.Thread"))))

primOpInsn TouchOp [o] = Just (Pop (javaType o))

primOpInsn StableNameToIntOp [_] = Just (Invoke IVirtual (MethodRef cStableName "hashCode" [] (Just TInt)))

primOpInsn DataToTagOp [a] = Just (Invoke IVirtual (MethodRef (unClass (javaType a)) "info" [] (Just TInt)))

primOpInsn _ _ = Nothing

-- Returns
    -- What to do to the operands
    -- What to do before the test
    -- The test
primOpCmp :: PrimOp -> [G.Type] -> Maybe (Insns,Insns,Test)
primOpCmp CharGtOp [] = Just (nilOL,nilOL,CmpGt)
primOpCmp CharGeOp [] = Just (nilOL,nilOL,CmpGe)
primOpCmp CharEqOp [] = Just (nilOL,nilOL,CmpEq)
primOpCmp CharNeOp [] = Just (nilOL,nilOL,CmpNe)
primOpCmp CharLtOp [] = Just (nilOL,nilOL,CmpLt)
primOpCmp CharLeOp [] = Just (nilOL,nilOL,CmpLe)

primOpCmp IntGtOp [] = Just (nilOL,nilOL,CmpGt)
primOpCmp IntGeOp [] = Just (nilOL,nilOL,CmpGe)
primOpCmp IntEqOp [] = Just (nilOL,nilOL,CmpEq)
primOpCmp IntNeOp [] = Just (nilOL,nilOL,CmpNe)
primOpCmp IntLtOp [] = Just (nilOL,nilOL,CmpLt)
primOpCmp IntLeOp [] = Just (nilOL,nilOL,CmpLe)

primOpCmp WordGtOp [] = Just (toOL [Convert TInt TLong,Const (CLong 0xffffffff),Arith And TLong],unitOL (Cmp Nothing TLong),IsGtZero)
primOpCmp WordGeOp [] = Just (toOL [Convert TInt TLong,Const (CLong 0xffffffff),Arith And TLong],unitOL (Cmp Nothing TLong),IsGeZero)
primOpCmp WordEqOp [] = Just (nilOL,nilOL,CmpEq)
primOpCmp WordNeOp [] = Just (nilOL,nilOL,CmpNe)
primOpCmp WordLtOp [] = Just (toOL [Convert TInt TLong,Const (CLong 0xffffffff),Arith And TLong],unitOL (Cmp Nothing TLong),IsLtZero)
primOpCmp WordLeOp [] = Just (toOL [Convert TInt TLong,Const (CLong 0xffffffff),Arith And TLong],unitOL (Cmp Nothing TLong),IsLeZero)

primOpCmp DoubleGtOp [] = Just (nilOL,unitOL (Cmp (Just CmpL) TDouble),IsGtZero)
primOpCmp DoubleGeOp [] = Just (nilOL,unitOL (Cmp (Just CmpL) TDouble),IsGtZero)
primOpCmp DoubleEqOp [] = Just (nilOL,unitOL (Cmp Nothing     TDouble),IsZero)
primOpCmp DoubleNeOp [] = Just (nilOL,unitOL (Cmp Nothing     TDouble),IsNonZero)
primOpCmp DoubleLtOp [] = Just (nilOL,unitOL (Cmp (Just CmpG) TDouble),IsLtZero)
primOpCmp DoubleLeOp [] = Just (nilOL,unitOL (Cmp (Just CmpG) TDouble),IsLeZero)

primOpCmp FloatGtOp [] = Just (nilOL,unitOL (Cmp (Just CmpL) TFloat),IsGtZero)
primOpCmp FloatGeOp [] = Just (nilOL,unitOL (Cmp (Just CmpL) TFloat),IsGtZero)
primOpCmp FloatEqOp [] = Just (nilOL,unitOL (Cmp Nothing     TFloat),IsZero)
primOpCmp FloatNeOp [] = Just (nilOL,unitOL (Cmp Nothing     TFloat),IsNonZero)
primOpCmp FloatLtOp [] = Just (nilOL,unitOL (Cmp (Just CmpG) TFloat),IsLtZero)
primOpCmp FloatLeOp [] = Just (nilOL,unitOL (Cmp (Just CmpG) TFloat),IsLeZero)

primOpCmp EqStableNameOp      [_]   = Just (nilOL,nilOL,CmpRefEq tStableName)
primOpCmp PtrEqOp [u] = Just (nilOL,nilOL,CmpRefEq (javaType u))
primOpCmp PtrNeOp [u] = Just (nilOL,nilOL,CmpRefEq (javaType u))

primOpCmp _ _ = Nothing

primOpNop :: PrimOp -> Bool
primOpNop UnsafeFreezeArrayOp  = True
primOpNop UnsafeFreezeUArrayOp = True
primOpNop UnsafeThawArrayOp    = True
primOpNop _ = False

primOpAsDouble :: PrimOp -> Maybe Insn
primOpAsDouble FloatExpOp  = Just (Invoke IStatic (MethodRef cMath "exp"  [TDouble] (Just TDouble)))
primOpAsDouble FloatLogOp  = Just (Invoke IStatic (MethodRef cMath "log"  [TDouble] (Just TDouble)))
primOpAsDouble FloatSqrtOp = Just (Invoke IStatic (MethodRef cMath "sqrt" [TDouble] (Just TDouble)))
primOpAsDouble FloatSinOp  = Just (Invoke IStatic (MethodRef cMath "sin"  [TDouble] (Just TDouble)))
primOpAsDouble FloatCosOp  = Just (Invoke IStatic (MethodRef cMath "cos"  [TDouble] (Just TDouble)))
primOpAsDouble FloatTanOp  = Just (Invoke IStatic (MethodRef cMath "tan"  [TDouble] (Just TDouble)))
primOpAsDouble FloatAsinOp = Just (Invoke IStatic (MethodRef cMath "asin" [TDouble] (Just TDouble)))
primOpAsDouble FloatAcosOp = Just (Invoke IStatic (MethodRef cMath "acos" [TDouble] (Just TDouble)))
primOpAsDouble FloatAtanOp = Just (Invoke IStatic (MethodRef cMath "atan" [TDouble] (Just TDouble)))
primOpAsDouble FloatSinhOp = Just (Invoke IStatic (MethodRef cMath "sinh" [TDouble] (Just TDouble)))
primOpAsDouble FloatCoshOp = Just (Invoke IStatic (MethodRef cMath "cosh" [TDouble] (Just TDouble)))
primOpAsDouble FloatTanhOp = Just (Invoke IStatic (MethodRef cMath "tanh" [TDouble] (Just TDouble)))
primOpAsDouble FloatPowerOp = Just (Invoke IStatic (MethodRef cMath "pow" [TDouble,TDouble] (Just TDouble)))
primOpAsDouble _ = Nothing

primOpAsLong :: PrimOp -> Maybe Insn
primOpAsLong WordQuotOp = Just (Arith Div TLong)
primOpAsLong WordRemOp  = Just (Arith Rem TLong)
primOpAsLong _ = Nothing

castOp :: G.Type -> G.Type -> Maybe Insns
castOp u@(PrimTy tc_u []) v@(PrimTy tc_v [])
    -- Word8 -> Int8 needs sign extension (normally Byte -> Byte is a nop)
    | tc_u == word8PrimTyCon, tc_v == int8PrimTyCon 
    = Just (unitOL (Convert TByte TByte))
    -- Word8 is a subtype of Word16 (normally Byte -> Char needs masking)
    | tc_u == word8PrimTyCon, tc_v == word16PrimTyCon
    = Just nilOL
    -- Anything (except Word8) -> Word8 needs sign bits anded off (normally ?? -> Byte sign extends)
    | tc_u /= word8PrimTyCon, tc_v == word8PrimTyCon
    = fmap (\toint -> toOL toint `snocOL` Const (CInt 0xff) `snocOL` Arith And TByte)
           (convOps (javaType u) TInt)
    -- Word32 -> {Int,Word}64 needs the sign bits anded off (normally Int -> Long sign extends)
    | tc_u == word32PrimTyCon, TLong <- javaType v
    = Just (toOL [Convert TInt TLong,Const (CLong 0xffffffff),Arith And TLong])
    | TBool <- javaType u
    = fmap toOL (convOps TInt (javaType v))
castOp u v
    = fmap toOL (convOps (javaType u) (javaType v))

cmpOp :: Insns -> Insns -> Test -> [GenLoc Int] -> GenLoc Int -> MethodM ()
cmpOp widen pre test args r = pop r $ do
    mapM_ (\a -> push a >> mInsns widen) args
    mInsns pre
    l1 <- mNewLabel
    l2 <- mNewLabel
    mInsns $ toOL
        [If test l1
        ,Const (CInt 0)
        ,Goto l2
        ,Note (Label l1)
        ,Const (CInt 1)
        ,Note (Label l2)]

-- Based on CgPrimOp.emitPrimOp ... IntAddCOp
-- add: c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
-- sub: c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
carryOp :: Bool -> GenLoc Int -> GenLoc Int -> GenLoc Int -> GenLoc Int -> MethodM ()
carryOp sub a b r c = pop r $ pop c $ do
    push a
    push b
    mInsn (Arith op TInt) -- r
    mInsn (Dup TInt) -- r, r
    push a -- r, r, a
    mInsn (Arith Xor TInt) -- r, (a^r)
    push a
    push b
    mInsn (Arith Xor TInt) -- r, (a^r), (a^b)
    when (not sub) $ mInsns $ toOL 
        [Const (CInt (-1))
        ,Arith Xor TInt]    -- r, (a^r), ~(a^b)
    mInsns $ toOL
        [Arith And TInt     -- r, (~(a^b)) & (a^r)
        ,Const (CInt 31)
        ,Arith UShr TInt]   -- r, ((~(a^b)) & (a^r)) >> 31
    where
        op = if sub then Sub else Add

-- Based on Stg.h
{-
#define mulIntMayOflo(a,b)                      \
({                                              \
  StgInt32 r, c;                                \
  long_long_u z;                                \
  z.l = (StgInt64)a * (StgInt64)b;              \
  r = z.i[RTS_REM_IDX__];                       \
  c = z.i[RTS_CARRY_IDX__];                     \
  if (c == 0 || c == -1) {                      \
    c = ((StgWord)((a^b) ^ r))                  \
      >> (BITS_IN (I_) - 1);                    \
  }                                             \
  c;                                            \
})
-}

mulIntMayOfloOp :: GenLoc Int -> GenLoc Int -> GenLoc Int -> MethodM ()
mulIntMayOfloOp a b c = pop c $ do
    l1 <- mNewLabel
    l2 <- mNewLabel
    l3 <- mNewLabel
    push a
    mInsn (Convert TInt TLong)
    push b
    mInsn (Convert TInt TLong)
    mInsns $ toOL
        [Arith Mul TLong    -- z
        ,Dup TLong          -- z, z
        ,Const (CInt 32)
        ,Arith UShr TLong
        ,Convert TLong TInt -- z, c
        ,Dup TInt           -- z, c, c
        ,If IsZero l2       -- z, c
        ,Const (CInt (-1))
        ,If CmpEq l1        -- z
        ,Const (CInt 32)
        ,Arith UShr TLong
        ,Convert TLong TInt -- c
        ,Goto l3
        ,Note (Label l1)
        ,Const (CInt 0)     -- z, 0
        ,Note (Label l2)    -- z, dummy
        ,Pop TInt           -- z
        ,Convert TLong TInt]-- r
    push a
    push b
    mInsns $ toOL
        [Arith Xor TInt  -- r, a^b
        ,Arith Xor TInt  -- (a^b) ^ r
        ,Const (CInt 31)
        ,Arith UShr TInt -- (a^b) ^ r >> 31
        ,Note (Label l3)]
\end{code}