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