compiler/codeGen/CgPrimOp.hs

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