diff options
Diffstat (limited to 'compiler/codeGen/StgCmmPrim.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 662 |
1 files changed, 662 insertions, 0 deletions
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs new file mode 100644 index 0000000000..96467fe781 --- /dev/null +++ b/compiler/codeGen/StgCmmPrim.hs @@ -0,0 +1,662 @@ +----------------------------------------------------------------------------- +-- +-- Stg to C--: primitive operations +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module StgCmmPrim ( + cgOpApp + ) where + +#include "HsVersions.h" + +import StgCmmLayout +import StgCmmForeign +import StgCmmEnv +import StgCmmMonad +import StgCmmUtils + +import MkZipCfgCmm +import StgSyn +import Cmm +import Type ( Type, tyConAppTyCon ) +import TyCon +import CLabel +import CmmUtils +import PrimOp +import SMRep +import Constants +import FastString +import Outputable + +------------------------------------------------------------------------ +-- Primitive operations and foreign calls +------------------------------------------------------------------------ + +{- Note [Foreign call results] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A foreign call always returns an unboxed tuple of results, one +of which is the state token. This seems to happen even for pure +calls. + +Even if we returned a single result for pure calls, it'd still be +right to wrap it in a singleton unboxed tuple, because the result +might be a Haskell closure pointer, we don't want to evaluate it. -} + +---------------------------------- +cgOpApp :: StgOp -- The op + -> [StgArg] -- Arguments + -> Type -- Result type (always an unboxed tuple) + -> FCode () + +-- Foreign calls +cgOpApp (StgFCallOp fcall _) stg_args res_ty + = do { (res_regs, res_hints) <- newUnboxedTupleRegs res_ty + -- Choose result regs r1, r2 + -- Note [Foreign call results] + ; cgForeignCall res_regs res_hints fcall stg_args + -- r1, r2 = foo( x, y ) + ; emitReturn (map (CmmReg . CmmLocal) res_regs) } + -- return (r1, r2) + +-- tagToEnum# is special: we need to pull the constructor +-- out of the table, and perform an appropriate return. + +cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty + = ASSERT(isEnumerationTyCon tycon) + do { amode <- getArgAmode arg + ; emitReturn [tagToClosure tycon amode] } + where + -- If you're reading this code in the attempt to figure + -- out why the compiler panic'ed here, it is probably because + -- you used tagToEnum# in a non-monomorphic setting, e.g., + -- intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x# + -- That won't work. + tycon = tyConAppTyCon res_ty + +cgOpApp (StgPrimOp primop) args res_ty + | primOpOutOfLine primop + = do { cmm_args <- getNonVoidArgAmodes args + ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + ; emitCall fun cmm_args } + + | ReturnsPrim VoidRep <- result_info + = do cgPrimOp [] primop args + emitReturn [] + + | ReturnsPrim rep <- result_info + = do res <- newTemp (primRepCmmType rep) + cgPrimOp [res] primop args + emitReturn [CmmReg (CmmLocal res)] + + | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon + = do (regs, _hints) <- newUnboxedTupleRegs res_ty + cgPrimOp regs primop args + emitReturn (map (CmmReg . CmmLocal) regs) + + | ReturnsAlg tycon <- result_info + , isEnumerationTyCon tycon + -- c.f. cgExpr (...TagToEnumOp...) + = do tag_reg <- newTemp bWord + cgPrimOp [tag_reg] primop args + emitReturn [tagToClosure tycon + (CmmReg (CmmLocal tag_reg))] + + | otherwise = panic "cgPrimop" + where + result_info = getPrimOpResultInfo primop + +--------------------------------------------------- +cgPrimOp :: [LocalReg] -- where to put the results + -> PrimOp -- the op + -> [StgArg] -- arguments + -> FCode () + +cgPrimOp results op args + = do arg_exprs <- getNonVoidArgAmodes args + emitPrimOp results op arg_exprs + + +------------------------------------------------------------------------ +-- Emitting code for a primop +------------------------------------------------------------------------ + +emitPrimOp :: [LocalReg] -- where to put the results + -> PrimOp -- the op + -> [CmmExpr] -- arguments + -> FCode () + +-- First we handle various awkward cases specially. The remaining +-- easy cases are then handled by translateOp, defined below. + +emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] +{- + With some bit-twiddling, we can define int{Add,Sub}Czh portably in + C, and without needing any comparisons. This may not be the + fastest way to do it - if you have better code, please send it! --SDM + + Return : r = a + b, c = 0 if no overflow, 1 on overflow. + + We currently don't make use of the r value if c is != 0 (i.e. + overflow), we just convert to big integers and try again. This + could be improved by making r and c the correct values for + plugging into a new J#. + + { r = ((I_)(a)) + ((I_)(b)); \ + c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + Wading through the mass of bracketry, it seems to reduce to: + c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1) + +-} + = emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp mo_wordUShr [ + CmmMachOp mo_wordAnd [ + CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]], + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + ], + CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + ] + ] + + +emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] +{- Similarly: + #define subIntCzh(r,c,a,b) \ + { r = ((I_)(a)) - ((I_)(b)); \ + c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \ + >> (BITS_IN (I_) - 1); \ + } + + c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1) +-} + = emit $ catAGraphs [ + mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]), + mkAssign (CmmLocal res_c) $ + CmmMachOp mo_wordUShr [ + CmmMachOp mo_wordAnd [ + CmmMachOp mo_wordXor [aa,bb], + CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)] + ], + CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1)) + ] + ] + + +emitPrimOp [res] ParOp [arg] + = + -- for now, just implement this in a C function + -- later, we might want to inline it. + emitCCall + [(res,NoHint)] + (CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark")))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] + +emitPrimOp [res] ReadMutVarOp [mutv] + = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) + +emitPrimOp [] WriteMutVarOp [mutv,var] + = do + emit (mkStore (cmmOffsetW mutv fixedHdrSize) var) + emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)] + +-- #define sizzeofByteArrayzh(r,a) \ +-- r = (((StgArrWords *)(a))->words * sizeof(W_)) +emitPrimOp [res] SizeofByteArrayOp [arg] + = emit $ + mkAssign (CmmLocal res) (CmmMachOp mo_wordMul [ + cmmLoadIndexW arg fixedHdrSize bWord, + CmmLit (mkIntCLit wORD_SIZE) + ]) + +-- #define sizzeofMutableByteArrayzh(r,a) \ +-- r = (((StgArrWords *)(a))->words * sizeof(W_)) +emitPrimOp [res] SizeofMutableByteArrayOp [arg] + = emitPrimOp [res] SizeofByteArrayOp [arg] + + +-- #define touchzh(o) /* nothing */ +emitPrimOp [] TouchOp [_arg] + = nopC + +-- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) +emitPrimOp [res] ByteArrayContents_Char [arg] + = emit (mkAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize)) + +-- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) +emitPrimOp [res] StableNameToIntOp [arg] + = emit (mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)) + +-- #define eqStableNamezh(r,sn1,sn2) \ +-- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn)) +emitPrimOp [res] EqStableNameOp [arg1,arg2] + = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [ + cmmLoadIndexW arg1 fixedHdrSize bWord, + cmmLoadIndexW arg2 fixedHdrSize bWord + ])) + + +emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] + = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2])) + +-- #define addrToHValuezh(r,a) r=(P_)a +emitPrimOp [res] AddrToHValueOp [arg] + = emit (mkAssign (CmmLocal res) arg) + +-- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info)) +-- Note: argument may be tagged! +emitPrimOp [res] DataToTagOp [arg] + = emit (mkAssign (CmmLocal res) (getConstrTag (cmmUntag arg))) + +{- Freezing arrays-of-ptrs requires changing an info table, for the + benefit of the generational collector. It needs to scavenge mutable + objects, even if they are in old space. When they become immutable, + they can be removed from this scavenge list. -} + +-- #define unsafeFreezzeArrayzh(r,a) +-- { +-- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info); +-- r = a; +-- } +emitPrimOp [res] UnsafeFreezeArrayOp [arg] + = emit $ catAGraphs + [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)), + mkAssign (CmmLocal res) arg ] + +-- #define unsafeFreezzeByteArrayzh(r,a) r=(a) +emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] + = emit (mkAssign (CmmLocal res) arg) + +-- Reading/writing pointer arrays + +emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix +emitPrimOp [r] IndexArrayOp [obj,ix] = doReadPtrArrayOp r obj ix +emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v + +-- IndexXXXoffAddr + +emitPrimOp res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res IndexOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res IndexOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res IndexOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res IndexOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res IndexOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp res IndexOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res IndexOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args +emitPrimOp res IndexOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args +emitPrimOp res IndexOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args +emitPrimOp res IndexOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp res IndexOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args +emitPrimOp res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args + +-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. + +emitPrimOp res ReadOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res ReadOffAddrOp_WideChar args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res ReadOffAddrOp_Int args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res ReadOffAddrOp_Word args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res ReadOffAddrOp_Addr args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res ReadOffAddrOp_Float args = doIndexOffAddrOp Nothing f32 res args +emitPrimOp res ReadOffAddrOp_Double args = doIndexOffAddrOp Nothing f64 res args +emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args +emitPrimOp res ReadOffAddrOp_Int8 args = doIndexOffAddrOp (Just mo_s_8ToWord) b8 res args +emitPrimOp res ReadOffAddrOp_Int16 args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args +emitPrimOp res ReadOffAddrOp_Int32 args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args +emitPrimOp res ReadOffAddrOp_Int64 args = doIndexOffAddrOp Nothing b64 res args +emitPrimOp res ReadOffAddrOp_Word8 args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args +emitPrimOp res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args + +-- IndexXXXArray + +emitPrimOp res IndexByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res IndexByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res IndexByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res IndexByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res IndexByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res IndexByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp res IndexByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res IndexByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args +emitPrimOp res IndexByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args +emitPrimOp res IndexByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args +emitPrimOp res IndexByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp res IndexByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args +emitPrimOp res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args + +-- ReadXXXArray, identical to IndexXXXArray. + +emitPrimOp res ReadByteArrayOp_Char args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res ReadByteArrayOp_WideChar args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res ReadByteArrayOp_Int args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res ReadByteArrayOp_Word args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res ReadByteArrayOp_Addr args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res ReadByteArrayOp_Float args = doIndexByteArrayOp Nothing f32 res args +emitPrimOp res ReadByteArrayOp_Double args = doIndexByteArrayOp Nothing f64 res args +emitPrimOp res ReadByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args +emitPrimOp res ReadByteArrayOp_Int8 args = doIndexByteArrayOp (Just mo_s_8ToWord) b8 res args +emitPrimOp res ReadByteArrayOp_Int16 args = doIndexByteArrayOp (Just mo_s_16ToWord) b16 res args +emitPrimOp res ReadByteArrayOp_Int32 args = doIndexByteArrayOp (Just mo_s_32ToWord) b32 res args +emitPrimOp res ReadByteArrayOp_Int64 args = doIndexByteArrayOp Nothing b64 res args +emitPrimOp res ReadByteArrayOp_Word8 args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args +emitPrimOp res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just mo_u_16ToWord) b16 res args +emitPrimOp res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args +emitPrimOp res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args + +-- WriteXXXoffAddr + +emitPrimOp res WriteOffAddrOp_Char args = doWriteOffAddrOp (Just mo_WordTo8) res args +emitPrimOp res WriteOffAddrOp_WideChar args = doWriteOffAddrOp (Just mo_WordTo32) res args +emitPrimOp res WriteOffAddrOp_Int args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_Word args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_Addr args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_Float args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_Double args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_StablePtr args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_Int8 args = doWriteOffAddrOp (Just mo_WordTo8) res args +emitPrimOp res WriteOffAddrOp_Int16 args = doWriteOffAddrOp (Just mo_WordTo16) res args +emitPrimOp res WriteOffAddrOp_Int32 args = doWriteOffAddrOp (Just mo_WordTo32) res args +emitPrimOp res WriteOffAddrOp_Int64 args = doWriteOffAddrOp Nothing res args +emitPrimOp res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (Just mo_WordTo8) res args +emitPrimOp res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just mo_WordTo16) res args +emitPrimOp res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just mo_WordTo32) res args +emitPrimOp res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing res args + +-- WriteXXXArray + +emitPrimOp res WriteByteArrayOp_Char args = doWriteByteArrayOp (Just mo_WordTo8) res args +emitPrimOp res WriteByteArrayOp_WideChar args = doWriteByteArrayOp (Just mo_WordTo32) res args +emitPrimOp res WriteByteArrayOp_Int args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_Word args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_Addr args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_Float args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_Double args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_Int8 args = doWriteByteArrayOp (Just mo_WordTo8) res args +emitPrimOp res WriteByteArrayOp_Int16 args = doWriteByteArrayOp (Just mo_WordTo16) res args +emitPrimOp res WriteByteArrayOp_Int32 args = doWriteByteArrayOp (Just mo_WordTo32) res args +emitPrimOp res WriteByteArrayOp_Int64 args = doWriteByteArrayOp Nothing res args +emitPrimOp res WriteByteArrayOp_Word8 args = doWriteByteArrayOp (Just mo_WordTo8) res args +emitPrimOp res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just mo_WordTo16) res args +emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args +emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args + + +-- The rest just translate straightforwardly +emitPrimOp [res] op [arg] + | nopOp op + = emit (mkAssign (CmmLocal res) arg) + + | Just (mop,rep) <- narrowOp op + = emit (mkAssign (CmmLocal res) $ + CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]]) + +emitPrimOp [res] op args + | Just prim <- callishOp op + = do emitPrimCall res prim args + + | Just mop <- translateOp op + = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in + emit stmt + +emitPrimOp _ op _ + = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op) + + +-- These PrimOps are NOPs in Cmm + +nopOp :: PrimOp -> Bool +nopOp Int2WordOp = True +nopOp Word2IntOp = True +nopOp Int2AddrOp = True +nopOp Addr2IntOp = True +nopOp ChrOp = True -- Int# and Char# are rep'd the same +nopOp OrdOp = True +nopOp _ = False + +-- These PrimOps turn into double casts + +narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width) +narrowOp Narrow8IntOp = Just (MO_SS_Conv, W8) +narrowOp Narrow16IntOp = Just (MO_SS_Conv, W16) +narrowOp Narrow32IntOp = Just (MO_SS_Conv, W32) +narrowOp Narrow8WordOp = Just (MO_UU_Conv, W8) +narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16) +narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32) +narrowOp _ = Nothing + +-- Native word signless ops + +translateOp :: PrimOp -> Maybe MachOp +translateOp IntAddOp = Just mo_wordAdd +translateOp IntSubOp = Just mo_wordSub +translateOp WordAddOp = Just mo_wordAdd +translateOp WordSubOp = Just mo_wordSub +translateOp AddrAddOp = Just mo_wordAdd +translateOp AddrSubOp = Just mo_wordSub + +translateOp IntEqOp = Just mo_wordEq +translateOp IntNeOp = Just mo_wordNe +translateOp WordEqOp = Just mo_wordEq +translateOp WordNeOp = Just mo_wordNe +translateOp AddrEqOp = Just mo_wordEq +translateOp AddrNeOp = Just mo_wordNe + +translateOp AndOp = Just mo_wordAnd +translateOp OrOp = Just mo_wordOr +translateOp XorOp = Just mo_wordXor +translateOp NotOp = Just mo_wordNot +translateOp SllOp = Just mo_wordShl +translateOp SrlOp = Just mo_wordUShr + +translateOp AddrRemOp = Just mo_wordURem + +-- Native word signed ops + +translateOp IntMulOp = Just mo_wordMul +translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth) +translateOp IntQuotOp = Just mo_wordSQuot +translateOp IntRemOp = Just mo_wordSRem +translateOp IntNegOp = Just mo_wordSNeg + + +translateOp IntGeOp = Just mo_wordSGe +translateOp IntLeOp = Just mo_wordSLe +translateOp IntGtOp = Just mo_wordSGt +translateOp IntLtOp = Just mo_wordSLt + +translateOp ISllOp = Just mo_wordShl +translateOp ISraOp = Just mo_wordSShr +translateOp ISrlOp = Just mo_wordUShr + +-- Native word unsigned ops + +translateOp WordGeOp = Just mo_wordUGe +translateOp WordLeOp = Just mo_wordULe +translateOp WordGtOp = Just mo_wordUGt +translateOp WordLtOp = Just mo_wordULt + +translateOp WordMulOp = Just mo_wordMul +translateOp WordQuotOp = Just mo_wordUQuot +translateOp WordRemOp = Just mo_wordURem + +translateOp AddrGeOp = Just mo_wordUGe +translateOp AddrLeOp = Just mo_wordULe +translateOp AddrGtOp = Just mo_wordUGt +translateOp AddrLtOp = Just mo_wordULt + +-- Char# ops + +translateOp CharEqOp = Just (MO_Eq wordWidth) +translateOp CharNeOp = Just (MO_Ne wordWidth) +translateOp CharGeOp = Just (MO_U_Ge wordWidth) +translateOp CharLeOp = Just (MO_U_Le wordWidth) +translateOp CharGtOp = Just (MO_U_Gt wordWidth) +translateOp CharLtOp = Just (MO_U_Lt wordWidth) + +-- Double ops + +translateOp DoubleEqOp = Just (MO_F_Eq W64) +translateOp DoubleNeOp = Just (MO_F_Ne W64) +translateOp DoubleGeOp = Just (MO_F_Ge W64) +translateOp DoubleLeOp = Just (MO_F_Le W64) +translateOp DoubleGtOp = Just (MO_F_Gt W64) +translateOp DoubleLtOp = Just (MO_F_Lt W64) + +translateOp DoubleAddOp = Just (MO_F_Add W64) +translateOp DoubleSubOp = Just (MO_F_Sub W64) +translateOp DoubleMulOp = Just (MO_F_Mul W64) +translateOp DoubleDivOp = Just (MO_F_Quot W64) +translateOp DoubleNegOp = Just (MO_F_Neg W64) + +-- Float ops + +translateOp FloatEqOp = Just (MO_F_Eq W32) +translateOp FloatNeOp = Just (MO_F_Ne W32) +translateOp FloatGeOp = Just (MO_F_Ge W32) +translateOp FloatLeOp = Just (MO_F_Le W32) +translateOp FloatGtOp = Just (MO_F_Gt W32) +translateOp FloatLtOp = Just (MO_F_Lt W32) + +translateOp FloatAddOp = Just (MO_F_Add W32) +translateOp FloatSubOp = Just (MO_F_Sub W32) +translateOp FloatMulOp = Just (MO_F_Mul W32) +translateOp FloatDivOp = Just (MO_F_Quot W32) +translateOp FloatNegOp = Just (MO_F_Neg W32) + +-- Conversions + +translateOp Int2DoubleOp = Just (MO_SF_Conv wordWidth W64) +translateOp Double2IntOp = Just (MO_FS_Conv W64 wordWidth) + +translateOp Int2FloatOp = Just (MO_SF_Conv wordWidth W32) +translateOp Float2IntOp = Just (MO_FS_Conv W32 wordWidth) + +translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64) +translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32) + +-- Word comparisons masquerading as more exotic things. + +translateOp SameMutVarOp = Just mo_wordEq +translateOp SameMVarOp = Just mo_wordEq +translateOp SameMutableArrayOp = Just mo_wordEq +translateOp SameMutableByteArrayOp = Just mo_wordEq +translateOp SameTVarOp = Just mo_wordEq +translateOp EqStablePtrOp = Just mo_wordEq + +translateOp _ = Nothing + +-- These primops are implemented by CallishMachOps, because they sometimes +-- turn into foreign calls depending on the backend. + +callishOp :: PrimOp -> Maybe CallishMachOp +callishOp DoublePowerOp = Just MO_F64_Pwr +callishOp DoubleSinOp = Just MO_F64_Sin +callishOp DoubleCosOp = Just MO_F64_Cos +callishOp DoubleTanOp = Just MO_F64_Tan +callishOp DoubleSinhOp = Just MO_F64_Sinh +callishOp DoubleCoshOp = Just MO_F64_Cosh +callishOp DoubleTanhOp = Just MO_F64_Tanh +callishOp DoubleAsinOp = Just MO_F64_Asin +callishOp DoubleAcosOp = Just MO_F64_Acos +callishOp DoubleAtanOp = Just MO_F64_Atan +callishOp DoubleLogOp = Just MO_F64_Log +callishOp DoubleExpOp = Just MO_F64_Exp +callishOp DoubleSqrtOp = Just MO_F64_Sqrt + +callishOp FloatPowerOp = Just MO_F32_Pwr +callishOp FloatSinOp = Just MO_F32_Sin +callishOp FloatCosOp = Just MO_F32_Cos +callishOp FloatTanOp = Just MO_F32_Tan +callishOp FloatSinhOp = Just MO_F32_Sinh +callishOp FloatCoshOp = Just MO_F32_Cosh +callishOp FloatTanhOp = Just MO_F32_Tanh +callishOp FloatAsinOp = Just MO_F32_Asin +callishOp FloatAcosOp = Just MO_F32_Acos +callishOp FloatAtanOp = Just MO_F32_Atan +callishOp FloatLogOp = Just MO_F32_Log +callishOp FloatExpOp = Just MO_F32_Exp +callishOp FloatSqrtOp = Just MO_F32_Sqrt + +callishOp _ = Nothing + +------------------------------------------------------------------------------ +-- Helpers for translating various minor variants of array indexing. + +doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () +doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx +doIndexOffAddrOp _ _ _ _ + = panic "CgPrimOp: doIndexOffAddrOp" + +doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () +doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] + = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx +doIndexByteArrayOp _ _ _ _ + = panic "CgPrimOp: doIndexByteArrayOp" + +doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> FCode () +doReadPtrArrayOp res addr idx + = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx + + +doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () +doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val] + = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val +doWriteOffAddrOp _ _ _ + = panic "CgPrimOp: doWriteOffAddrOp" + +doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode () +doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val] + = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val +doWriteByteArrayOp _ _ _ + = panic "CgPrimOp: doWriteByteArrayOp" + +doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doWritePtrArrayOp addr idx val + = do emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val + +mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType + -> LocalReg -> CmmExpr -> CmmExpr -> FCode () +mkBasicIndexedRead off Nothing read_rep res base idx + = emit (mkAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx)) +mkBasicIndexedRead off (Just cast) read_rep res base idx + = emit (mkAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr off read_rep base idx])) + +mkBasicIndexedWrite :: ByteOff -> Maybe MachOp + -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +mkBasicIndexedWrite off Nothing base idx val + = emit (mkStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val) +mkBasicIndexedWrite off (Just cast) base idx val + = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val]) + +-- ---------------------------------------------------------------------------- +-- Misc utils + +cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr +cmmIndexOffExpr off width base idx + = cmmIndexExpr width (cmmOffsetB base off) idx + +cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr +cmmLoadIndexOffExpr off ty base idx + = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty + +setInfo :: CmmExpr -> CmmExpr -> CmmAGraph +setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr + |