compiler/codeGen/StgCmmPrim.hs

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