compiler/codeGen/CgPrimOp.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for PrimOps.
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgPrimOp (
  10    cgPrimOp
  11  ) where
  12
  13 import ForeignCall
  14 import ClosureInfo
  15 import StgSyn
  16 import CgForeignCall
  17 import CgBindery
  18 import CgMonad
  19 import CgInfoTbls
  20 import CgUtils
  21 import Cmm
  22 import CLabel
  23 import CmmUtils
  24 import PrimOp
  25 import SMRep
  26 import Constants
  27 import Outputable
  28 import FastString
  29
  30 -- ---------------------------------------------------------------------------
  31 -- Code generation for PrimOps
  32
  33 cgPrimOp   :: CmmFormals        -- where to put the results
  34            -> PrimOp            -- the op
  35            -> [StgArg]          -- arguments
  36            -> StgLiveVars       -- live vars, in case we need to save them
  37            -> Code
  38
  39 cgPrimOp results op args live
  40   = do arg_exprs <- getArgAmodes args
  41        let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ]
  42        emitPrimOp results op non_void_args live
  43
  44
  45 emitPrimOp :: CmmFormals        -- where to put the results
  46            -> PrimOp            -- the op
  47            -> [CmmExpr]         -- arguments
  48            -> StgLiveVars       -- live vars, in case we need to save them
  49            -> Code
  50
  51 --  First we handle various awkward cases specially.  The remaining
  52 -- easy cases are then handled by translateOp, defined below.
  53
  54 emitPrimOp [res_r,res_c] IntAddCOp [aa,bb] _
  55 {-
  56    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
  57    C, and without needing any comparisons.  This may not be the
  58    fastest way to do it - if you have better code, please send it! --SDM
  59
  60    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
  61
  62    We currently don't make use of the r value if c is != 0 (i.e.
  63    overflow), we just convert to big integers and try again.  This
  64    could be improved by making r and c the correct values for
  65    plugging into a new J#.
  66
  67    { r = ((I_)(a)) + ((I_)(b));                                 \
  68      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
  69          >> (BITS_IN (I_) - 1);                                 \
  70    }
  71    Wading through the mass of bracketry, it seems to reduce to:
  72    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
  73
  74 -}
  75    = stmtsC [
  76         CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]),
  77         CmmAssign (CmmLocal res_c) $
  78           CmmMachOp mo_wordUShr [
  79                 CmmMachOp mo_wordAnd [
  80                     CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]],
  81                     CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
  82                 ],
  83                 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
  84           ]
  85      ]
  86
  87
  88 emitPrimOp [res_r,res_c] IntSubCOp [aa,bb] _
  89 {- Similarly:
  90    #define subIntCzh(r,c,a,b)                                   \
  91    { r = ((I_)(a)) - ((I_)(b));                                 \
  92      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
  93          >> (BITS_IN (I_) - 1);                                 \
  94    }
  95
  96    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
  97 -}
  98    = stmtsC [
  99         CmmAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]),
 100         CmmAssign (CmmLocal res_c) $
 101           CmmMachOp mo_wordUShr [
 102                 CmmMachOp mo_wordAnd [
 103                     CmmMachOp mo_wordXor [aa,bb],
 104                     CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
 105                 ],
 106                 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
 107           ]
 108      ]
 109
 110
 111 emitPrimOp [res] ParOp [arg] live
 112   = do
 113         -- for now, just implement this in a C function
 114         -- later, we might want to inline it.
 115     vols <- getVolatileRegs live
 116     emitForeignCall' PlayRisky
 117         [CmmHinted res NoHint]
 118         (CmmCallee newspark CCallConv)
 119         [   (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
 120           , (CmmHinted arg AddrHint)  ]
 121         (Just vols)
 122         NoC_SRT -- No SRT b/c we do PlayRisky
 123         CmmMayReturn
 124   where
 125         newspark = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "newSpark")))
 126
 127 emitPrimOp [res] ReadMutVarOp [mutv] _
 128    = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
 129
 130 emitPrimOp [] WriteMutVarOp [mutv,var] live
 131    = do
 132         stmtC (CmmStore (cmmOffsetW mutv fixedHdrSize) var)
 133         vols <- getVolatileRegs live
 134         emitForeignCall' PlayRisky
 135                 [{-no results-}]
 136                 (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
 137                          CCallConv)
 138                 [   (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
 139                   , (CmmHinted mutv AddrHint)  ]
 140                 (Just vols)
 141                 NoC_SRT -- No SRT b/c we do PlayRisky
 142                 CmmMayReturn
 143
 144 --  #define sizzeofByteArrayzh(r,a) \
 145 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
 146 emitPrimOp [res] SizeofByteArrayOp [arg] _
 147    = stmtC $
 148         CmmAssign (CmmLocal res) (CmmMachOp mo_wordMul [
 149                           cmmLoadIndexW arg fixedHdrSize bWord,
 150                           CmmLit (mkIntCLit wORD_SIZE)
 151                         ])
 152
 153 --  #define sizzeofMutableByteArrayzh(r,a) \
 154 --      r = (((StgArrWords *)(a))->words * sizeof(W_))
 155 emitPrimOp [res] SizeofMutableByteArrayOp [arg] live
 156    = emitPrimOp [res] SizeofByteArrayOp [arg] live
 157
 158
 159 --  #define touchzh(o)                  /* nothing */
 160 emitPrimOp [] TouchOp [_] _
 161    = nopC
 162
 163 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 164 emitPrimOp [res] ByteArrayContents_Char [arg] _
 165    = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize))
 166
 167 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 168 emitPrimOp [res] StableNameToIntOp [arg] _
 169    = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord))
 170
 171 --  #define eqStableNamezh(r,sn1,sn2)                                   \
 172 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 173 emitPrimOp [res] EqStableNameOp [arg1,arg2] _
 174    = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [
 175                                 cmmLoadIndexW arg1 fixedHdrSize bWord,
 176                                 cmmLoadIndexW arg2 fixedHdrSize bWord
 177                          ]))
 178
 179
 180 emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _
 181    = stmtC (CmmAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
 182
 183 --  #define addrToHValuezh(r,a) r=(P_)a
 184 emitPrimOp [res] AddrToHValueOp [arg] _
 185    = stmtC (CmmAssign (CmmLocal res) arg)
 186
 187 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 188 --  Note: argument may be tagged!
 189 emitPrimOp [res] DataToTagOp [arg] _
 190    = stmtC (CmmAssign (CmmLocal res) (getConstrTag (cmmUntag arg)))
 191
 192 {- Freezing arrays-of-ptrs requires changing an info table, for the
 193    benefit of the generational collector.  It needs to scavenge mutable
 194    objects, even if they are in old space.  When they become immutable,
 195    they can be removed from this scavenge list.  -}
 196
 197 --  #define unsafeFreezzeArrayzh(r,a)
 198 --      {
 199 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
 200 --        r = a;
 201 --      }
 202 emitPrimOp [res] UnsafeFreezeArrayOp [arg] _
 203    = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
 204              CmmAssign (CmmLocal res) arg ]
 205
 206 --  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
 207 emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _
 208    = stmtC (CmmAssign (CmmLocal res) arg)
 209
 210 -- Reading/writing pointer arrays
 211
 212 emitPrimOp [r] ReadArrayOp  [obj,ix]   _  = doReadPtrArrayOp r obj ix
 213 emitPrimOp [r] IndexArrayOp [obj,ix]   _  = doReadPtrArrayOp r obj ix
 214 emitPrimOp []  WriteArrayOp [obj,ix,v] _  = doWritePtrArrayOp obj ix v
 215
 216 -- IndexXXXoffAddr
 217
 218 emitPrimOp res IndexOffAddrOp_Char      args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
 219 emitPrimOp res IndexOffAddrOp_WideChar  args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 220 emitPrimOp res IndexOffAddrOp_Int       args _ = doIndexOffAddrOp Nothing bWord res args
 221 emitPrimOp res IndexOffAddrOp_Word      args _ = doIndexOffAddrOp Nothing bWord res args
 222 emitPrimOp res IndexOffAddrOp_Addr      args _ = doIndexOffAddrOp Nothing bWord res args
 223 emitPrimOp res IndexOffAddrOp_Float     args _ = doIndexOffAddrOp Nothing f32 res args
 224 emitPrimOp res IndexOffAddrOp_Double    args _ = doIndexOffAddrOp Nothing f64 res args
 225 emitPrimOp res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing bWord res args
 226 emitPrimOp res IndexOffAddrOp_Int8      args _ = doIndexOffAddrOp (Just mo_s_8ToWord)  b8  res args
 227 emitPrimOp res IndexOffAddrOp_Int16     args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
 228 emitPrimOp res IndexOffAddrOp_Int32     args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
 229 emitPrimOp res IndexOffAddrOp_Int64     args _ = doIndexOffAddrOp Nothing b64 res args
 230 emitPrimOp res IndexOffAddrOp_Word8     args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8   res args
 231 emitPrimOp res IndexOffAddrOp_Word16    args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
 232 emitPrimOp res IndexOffAddrOp_Word32    args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 233 emitPrimOp res IndexOffAddrOp_Word64    args _ = doIndexOffAddrOp Nothing b64 res args
 234
 235 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 236
 237 emitPrimOp res ReadOffAddrOp_Char      args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
 238 emitPrimOp res ReadOffAddrOp_WideChar  args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 239 emitPrimOp res ReadOffAddrOp_Int       args _ = doIndexOffAddrOp Nothing bWord res args
 240 emitPrimOp res ReadOffAddrOp_Word      args _ = doIndexOffAddrOp Nothing bWord res args
 241 emitPrimOp res ReadOffAddrOp_Addr      args _ = doIndexOffAddrOp Nothing bWord res args
 242 emitPrimOp res ReadOffAddrOp_Float     args _ = doIndexOffAddrOp Nothing f32 res args
 243 emitPrimOp res ReadOffAddrOp_Double    args _ = doIndexOffAddrOp Nothing f64 res args
 244 emitPrimOp res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing bWord res args
 245 emitPrimOp res ReadOffAddrOp_Int8      args _ = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
 246 emitPrimOp res ReadOffAddrOp_Int16     args _ = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
 247 emitPrimOp res ReadOffAddrOp_Int32     args _ = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
 248 emitPrimOp res ReadOffAddrOp_Int64     args _ = doIndexOffAddrOp Nothing b64 res args
 249 emitPrimOp res ReadOffAddrOp_Word8     args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
 250 emitPrimOp res ReadOffAddrOp_Word16    args _ = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
 251 emitPrimOp res ReadOffAddrOp_Word32    args _ = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 252 emitPrimOp res ReadOffAddrOp_Word64    args _ = doIndexOffAddrOp Nothing b64 res args
 253
 254 -- IndexXXXArray
 255
 256 emitPrimOp res IndexByteArrayOp_Char      args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
 257 emitPrimOp res IndexByteArrayOp_WideChar  args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
 258 emitPrimOp res IndexByteArrayOp_Int       args _ = doIndexByteArrayOp Nothing bWord res args
 259 emitPrimOp res IndexByteArrayOp_Word      args _ = doIndexByteArrayOp Nothing bWord res args
 260 emitPrimOp res IndexByteArrayOp_Addr      args _ = doIndexByteArrayOp Nothing bWord res args
 261 emitPrimOp res IndexByteArrayOp_Float     args _ = doIndexByteArrayOp Nothing f32 res args
 262 emitPrimOp res IndexByteArrayOp_Double    args _ = doIndexByteArrayOp Nothing f64 res args
 263 emitPrimOp res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing bWord res args
 264 emitPrimOp res IndexByteArrayOp_Int8      args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
 265 emitPrimOp res IndexByteArrayOp_Int16     args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
 266 emitPrimOp res IndexByteArrayOp_Int32     args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
 267 emitPrimOp res IndexByteArrayOp_Int64     args _ = doIndexByteArrayOp Nothing b64  res args
 268 emitPrimOp res IndexByteArrayOp_Word8     args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
 269 emitPrimOp res IndexByteArrayOp_Word16    args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
 270 emitPrimOp res IndexByteArrayOp_Word32    args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
 271 emitPrimOp res IndexByteArrayOp_Word64    args _ = doIndexByteArrayOp Nothing b64  res args
 272
 273 -- ReadXXXArray, identical to IndexXXXArray.
 274
 275 emitPrimOp res ReadByteArrayOp_Char       args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
 276 emitPrimOp res ReadByteArrayOp_WideChar   args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
 277 emitPrimOp res ReadByteArrayOp_Int        args _ = doIndexByteArrayOp Nothing bWord res args
 278 emitPrimOp res ReadByteArrayOp_Word       args _ = doIndexByteArrayOp Nothing bWord res args
 279 emitPrimOp res ReadByteArrayOp_Addr       args _ = doIndexByteArrayOp Nothing bWord res args
 280 emitPrimOp res ReadByteArrayOp_Float      args _ = doIndexByteArrayOp Nothing f32 res args
 281 emitPrimOp res ReadByteArrayOp_Double     args _ = doIndexByteArrayOp Nothing f64 res args
 282 emitPrimOp res ReadByteArrayOp_StablePtr  args _ = doIndexByteArrayOp Nothing bWord res args
 283 emitPrimOp res ReadByteArrayOp_Int8       args _ = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
 284 emitPrimOp res ReadByteArrayOp_Int16      args _ = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
 285 emitPrimOp res ReadByteArrayOp_Int32      args _ = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
 286 emitPrimOp res ReadByteArrayOp_Int64      args _ = doIndexByteArrayOp Nothing b64  res args
 287 emitPrimOp res ReadByteArrayOp_Word8      args _ = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
 288 emitPrimOp res ReadByteArrayOp_Word16     args _ = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
 289 emitPrimOp res ReadByteArrayOp_Word32     args _ = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
 290 emitPrimOp res ReadByteArrayOp_Word64     args _ = doIndexByteArrayOp Nothing b64  res args
 291
 292 -- WriteXXXoffAddr
 293
 294 emitPrimOp res WriteOffAddrOp_Char       args _ = doWriteOffAddrOp (Just mo_WordTo8) b8 res args
 295 emitPrimOp res WriteOffAddrOp_WideChar   args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args
 296 emitPrimOp res WriteOffAddrOp_Int        args _ = doWriteOffAddrOp Nothing bWord res args
 297 emitPrimOp res WriteOffAddrOp_Word       args _ = doWriteOffAddrOp Nothing bWord res args
 298 emitPrimOp res WriteOffAddrOp_Addr       args _ = doWriteOffAddrOp Nothing bWord res args
 299 emitPrimOp res WriteOffAddrOp_Float      args _ = doWriteOffAddrOp Nothing f32 res args
 300 emitPrimOp res WriteOffAddrOp_Double     args _ = doWriteOffAddrOp Nothing f64 res args
 301 emitPrimOp res WriteOffAddrOp_StablePtr  args _ = doWriteOffAddrOp Nothing bWord res args
 302 emitPrimOp res WriteOffAddrOp_Int8       args _ = doWriteOffAddrOp (Just mo_WordTo8) b8  res args
 303 emitPrimOp res WriteOffAddrOp_Int16      args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args
 304 emitPrimOp res WriteOffAddrOp_Int32      args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args
 305 emitPrimOp res WriteOffAddrOp_Int64      args _ = doWriteOffAddrOp Nothing b64 res args
 306 emitPrimOp res WriteOffAddrOp_Word8      args _ = doWriteOffAddrOp (Just mo_WordTo8) b8  res args
 307 emitPrimOp res WriteOffAddrOp_Word16     args _ = doWriteOffAddrOp (Just mo_WordTo16) b16 res args
 308 emitPrimOp res WriteOffAddrOp_Word32     args _ = doWriteOffAddrOp (Just mo_WordTo32) b32 res args
 309 emitPrimOp res WriteOffAddrOp_Word64     args _ = doWriteOffAddrOp Nothing b64 res args
 310
 311 -- WriteXXXArray
 312
 313 emitPrimOp res WriteByteArrayOp_Char      args _ = doWriteByteArrayOp (Just mo_WordTo8) b8 res args
 314 emitPrimOp res WriteByteArrayOp_WideChar  args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args
 315 emitPrimOp res WriteByteArrayOp_Int       args _ = doWriteByteArrayOp Nothing bWord res args
 316 emitPrimOp res WriteByteArrayOp_Word      args _ = doWriteByteArrayOp Nothing bWord res args
 317 emitPrimOp res WriteByteArrayOp_Addr      args _ = doWriteByteArrayOp Nothing bWord res args
 318 emitPrimOp res WriteByteArrayOp_Float     args _ = doWriteByteArrayOp Nothing f32 res args
 319 emitPrimOp res WriteByteArrayOp_Double    args _ = doWriteByteArrayOp Nothing f64 res args
 320 emitPrimOp res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing bWord res args
 321 emitPrimOp res WriteByteArrayOp_Int8      args _ = doWriteByteArrayOp (Just mo_WordTo8) b8  res args
 322 emitPrimOp res WriteByteArrayOp_Int16     args _ = doWriteByteArrayOp (Just mo_WordTo16) b16  res args
 323 emitPrimOp res WriteByteArrayOp_Int32     args _ = doWriteByteArrayOp (Just mo_WordTo32) b32  res args
 324 emitPrimOp res WriteByteArrayOp_Int64     args _ = doWriteByteArrayOp Nothing b64  res args
 325 emitPrimOp res WriteByteArrayOp_Word8     args _ = doWriteByteArrayOp (Just mo_WordTo8) b8  res args
 326 emitPrimOp res WriteByteArrayOp_Word16    args _ = doWriteByteArrayOp (Just mo_WordTo16) b16  res args
 327 emitPrimOp res WriteByteArrayOp_Word32    args _ = doWriteByteArrayOp (Just mo_WordTo32) b32  res args
 328 emitPrimOp res WriteByteArrayOp_Word64    args _ = doWriteByteArrayOp Nothing b64  res args
 329
 330
 331 -- The rest just translate straightforwardly
 332 emitPrimOp [res] op [arg] _
 333    | nopOp op
 334    = stmtC (CmmAssign (CmmLocal res) arg)
 335
 336    | Just (mop,rep) <- narrowOp op
 337    = stmtC (CmmAssign (CmmLocal res) $
 338             CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
 339
 340 emitPrimOp [res] op args live
 341    | Just prim <- callishOp op
 342    = do vols <- getVolatileRegs live
 343         emitForeignCall' PlayRisky
 344            [CmmHinted res NoHint]
 345            (CmmPrim prim)
 346            [CmmHinted a NoHint | a<-args]  -- ToDo: hints?
 347            (Just vols)
 348            NoC_SRT -- No SRT b/c we do PlayRisky
 349            CmmMayReturn
 350
 351    | Just mop <- translateOp op
 352    = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
 353      stmtC stmt
 354
 355 emitPrimOp _ op _ _
 356  = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
 357
 358
 359 -- These PrimOps are NOPs in Cmm
 360
 361 nopOp :: PrimOp -> Bool
 362 nopOp Int2WordOp     = True
 363 nopOp Word2IntOp     = True
 364 nopOp Int2AddrOp     = True
 365 nopOp Addr2IntOp     = True
 366 nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
 367 nopOp OrdOp          = True
 368 nopOp _              = False
 369
 370 -- These PrimOps turn into double casts
 371
 372 narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
 373 narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
 374 narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
 375 narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
 376 narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
 377 narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
 378 narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
 379 narrowOp _              = Nothing
 380
 381 -- Native word signless ops
 382
 383 translateOp :: PrimOp -> Maybe MachOp
 384 translateOp IntAddOp       = Just mo_wordAdd
 385 translateOp IntSubOp       = Just mo_wordSub
 386 translateOp WordAddOp      = Just mo_wordAdd
 387 translateOp WordSubOp      = Just mo_wordSub
 388 translateOp AddrAddOp      = Just mo_wordAdd
 389 translateOp AddrSubOp      = Just mo_wordSub
 390
 391 translateOp IntEqOp        = Just mo_wordEq
 392 translateOp IntNeOp        = Just mo_wordNe
 393 translateOp WordEqOp       = Just mo_wordEq
 394 translateOp WordNeOp       = Just mo_wordNe
 395 translateOp AddrEqOp       = Just mo_wordEq
 396 translateOp AddrNeOp       = Just mo_wordNe
 397
 398 translateOp AndOp          = Just mo_wordAnd
 399 translateOp OrOp           = Just mo_wordOr
 400 translateOp XorOp          = Just mo_wordXor
 401 translateOp NotOp          = Just mo_wordNot
 402 translateOp SllOp          = Just mo_wordShl
 403 translateOp SrlOp          = Just mo_wordUShr
 404
 405 translateOp AddrRemOp      = Just mo_wordURem
 406
 407 -- Native word signed ops
 408
 409 translateOp IntMulOp        = Just mo_wordMul
 410 translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
 411 translateOp IntQuotOp       = Just mo_wordSQuot
 412 translateOp IntRemOp        = Just mo_wordSRem
 413 translateOp IntNegOp        = Just mo_wordSNeg
 414
 415
 416 translateOp IntGeOp        = Just mo_wordSGe
 417 translateOp IntLeOp        = Just mo_wordSLe
 418 translateOp IntGtOp        = Just mo_wordSGt
 419 translateOp IntLtOp        = Just mo_wordSLt
 420
 421 translateOp ISllOp         = Just mo_wordShl
 422 translateOp ISraOp         = Just mo_wordSShr
 423 translateOp ISrlOp         = Just mo_wordUShr
 424
 425 -- Native word unsigned ops
 426
 427 translateOp WordGeOp       = Just mo_wordUGe
 428 translateOp WordLeOp       = Just mo_wordULe
 429 translateOp WordGtOp       = Just mo_wordUGt
 430 translateOp WordLtOp       = Just mo_wordULt
 431
 432 translateOp WordMulOp      = Just mo_wordMul
 433 translateOp WordQuotOp     = Just mo_wordUQuot
 434 translateOp WordRemOp      = Just mo_wordURem
 435
 436 translateOp AddrGeOp       = Just mo_wordUGe
 437 translateOp AddrLeOp       = Just mo_wordULe
 438 translateOp AddrGtOp       = Just mo_wordUGt
 439 translateOp AddrLtOp       = Just mo_wordULt
 440
 441 -- Char# ops
 442
 443 translateOp CharEqOp       = Just (MO_Eq wordWidth)
 444 translateOp CharNeOp       = Just (MO_Ne wordWidth)
 445 translateOp CharGeOp       = Just (MO_U_Ge wordWidth)
 446 translateOp CharLeOp       = Just (MO_U_Le wordWidth)
 447 translateOp CharGtOp       = Just (MO_U_Gt wordWidth)
 448 translateOp CharLtOp       = Just (MO_U_Lt wordWidth)
 449
 450 -- Double ops
 451
 452 translateOp DoubleEqOp     = Just (MO_F_Eq W64)
 453 translateOp DoubleNeOp     = Just (MO_F_Ne W64)
 454 translateOp DoubleGeOp     = Just (MO_F_Ge W64)
 455 translateOp DoubleLeOp     = Just (MO_F_Le W64)
 456 translateOp DoubleGtOp     = Just (MO_F_Gt W64)
 457 translateOp DoubleLtOp     = Just (MO_F_Lt W64)
 458
 459 translateOp DoubleAddOp    = Just (MO_F_Add W64)
 460 translateOp DoubleSubOp    = Just (MO_F_Sub W64)
 461 translateOp DoubleMulOp    = Just (MO_F_Mul W64)
 462 translateOp DoubleDivOp    = Just (MO_F_Quot W64)
 463 translateOp DoubleNegOp    = Just (MO_F_Neg W64)
 464
 465 -- Float ops
 466
 467 translateOp FloatEqOp     = Just (MO_F_Eq W32)
 468 translateOp FloatNeOp     = Just (MO_F_Ne W32)
 469 translateOp FloatGeOp     = Just (MO_F_Ge W32)
 470 translateOp FloatLeOp     = Just (MO_F_Le W32)
 471 translateOp FloatGtOp     = Just (MO_F_Gt W32)
 472 translateOp FloatLtOp     = Just (MO_F_Lt W32)
 473
 474 translateOp FloatAddOp    = Just (MO_F_Add  W32)
 475 translateOp FloatSubOp    = Just (MO_F_Sub  W32)
 476 translateOp FloatMulOp    = Just (MO_F_Mul  W32)
 477 translateOp FloatDivOp    = Just (MO_F_Quot W32)
 478 translateOp FloatNegOp    = Just (MO_F_Neg  W32)
 479
 480 -- Conversions
 481
 482 translateOp Int2DoubleOp   = Just (MO_SF_Conv wordWidth W64)
 483 translateOp Double2IntOp   = Just (MO_FS_Conv W64 wordWidth)
 484
 485 translateOp Int2FloatOp    = Just (MO_SF_Conv wordWidth W32)
 486 translateOp Float2IntOp    = Just (MO_FS_Conv W32 wordWidth)
 487
 488 translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
 489 translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
 490
 491 -- Word comparisons masquerading as more exotic things.
 492
 493 translateOp SameMutVarOp           = Just mo_wordEq
 494 translateOp SameMVarOp             = Just mo_wordEq
 495 translateOp SameMutableArrayOp     = Just mo_wordEq
 496 translateOp SameMutableByteArrayOp = Just mo_wordEq
 497 translateOp SameTVarOp             = Just mo_wordEq
 498 translateOp EqStablePtrOp          = Just mo_wordEq
 499
 500 translateOp _ = Nothing
 501
 502 -- These primops are implemented by CallishMachOps, because they sometimes
 503 -- turn into foreign calls depending on the backend.
 504
 505 callishOp :: PrimOp -> Maybe CallishMachOp
 506 callishOp DoublePowerOp  = Just MO_F64_Pwr
 507 callishOp DoubleSinOp    = Just MO_F64_Sin
 508 callishOp DoubleCosOp    = Just MO_F64_Cos
 509 callishOp DoubleTanOp    = Just MO_F64_Tan
 510 callishOp DoubleSinhOp   = Just MO_F64_Sinh
 511 callishOp DoubleCoshOp   = Just MO_F64_Cosh
 512 callishOp DoubleTanhOp   = Just MO_F64_Tanh
 513 callishOp DoubleAsinOp   = Just MO_F64_Asin
 514 callishOp DoubleAcosOp   = Just MO_F64_Acos
 515 callishOp DoubleAtanOp   = Just MO_F64_Atan
 516 callishOp DoubleLogOp    = Just MO_F64_Log
 517 callishOp DoubleExpOp    = Just MO_F64_Exp
 518 callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
 519
 520 callishOp FloatPowerOp  = Just MO_F32_Pwr
 521 callishOp FloatSinOp    = Just MO_F32_Sin
 522 callishOp FloatCosOp    = Just MO_F32_Cos
 523 callishOp FloatTanOp    = Just MO_F32_Tan
 524 callishOp FloatSinhOp   = Just MO_F32_Sinh
 525 callishOp FloatCoshOp   = Just MO_F32_Cosh
 526 callishOp FloatTanhOp   = Just MO_F32_Tanh
 527 callishOp FloatAsinOp   = Just MO_F32_Asin
 528 callishOp FloatAcosOp   = Just MO_F32_Acos
 529 callishOp FloatAtanOp   = Just MO_F32_Atan
 530 callishOp FloatLogOp    = Just MO_F32_Log
 531 callishOp FloatExpOp    = Just MO_F32_Exp
 532 callishOp FloatSqrtOp   = Just MO_F32_Sqrt
 533
 534 callishOp _ = Nothing
 535
 536 ------------------------------------------------------------------------------
 537 -- Helpers for translating various minor variants of array indexing.
 538
 539 -- Bytearrays outside the heap; hence non-pointers
 540 doIndexOffAddrOp, doIndexByteArrayOp
 541         :: Maybe MachOp -> CmmType
 542         -> [LocalReg] -> [CmmExpr] -> Code
 543 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
 544    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
 545 doIndexOffAddrOp _ _ _ _
 546    = panic "CgPrimOp: doIndexOffAddrOp"
 547
 548 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
 549    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
 550 doIndexByteArrayOp _ _ _ _
 551    = panic "CgPrimOp: doIndexByteArrayOp"
 552
 553 doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code
 554 doReadPtrArrayOp res addr idx
 555    = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
 556
 557
 558 doWriteOffAddrOp, doWriteByteArrayOp
 559         :: Maybe MachOp -> CmmType
 560         -> [LocalReg] -> [CmmExpr] -> Code
 561 doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val]
 562    = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
 563 doWriteOffAddrOp _ _ _ _
 564    = panic "CgPrimOp: doWriteOffAddrOp"
 565
 566 doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val]
 567    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
 568 doWriteByteArrayOp _ _ _ _
 569    = panic "CgPrimOp: doWriteByteArrayOp"
 570
 571 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code
 572 doWritePtrArrayOp addr idx val
 573    = do stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 574         mkBasicIndexedWrite arrPtrsHdrSize Nothing bWord addr idx val
 575
 576
 577 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
 578                    -> LocalReg -> CmmExpr -> CmmExpr -> Code
 579 mkBasicIndexedRead off Nothing read_rep res base idx
 580    = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx))
 581 mkBasicIndexedRead off (Just cast) read_rep res base idx
 582    = stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [
 583                                 cmmLoadIndexOffExpr off read_rep base idx]))
 584
 585 mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType
 586                     -> CmmExpr -> CmmExpr -> CmmExpr -> Code
 587 mkBasicIndexedWrite off Nothing write_rep base idx val
 588    = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) val)
 589 mkBasicIndexedWrite off (Just cast) write_rep base idx val
 590    = stmtC (CmmStore (cmmIndexOffExpr off write_rep base idx) (CmmMachOp cast [val]))
 591
 592 -- ----------------------------------------------------------------------------
 593 -- Misc utils
 594
 595 cmmIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
 596 cmmIndexOffExpr off rep base idx
 597    = cmmIndexExpr (typeWidth rep) (cmmOffsetB base off) idx
 598
 599 cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
 600 cmmLoadIndexOffExpr off rep base idx
 601    = CmmLoad (cmmIndexOffExpr off rep base idx) rep
 602
 603 setInfo :: CmmExpr -> CmmExpr -> CmmStmt
 604 setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
 605