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 import StgCmmTicky
  21 import StgCmmHeap
  22 import StgCmmProf
  23
  24 import BasicTypes
  25 import MkGraph
  26 import StgSyn
  27 import CmmDecl
  28 import CmmExpr
  29 import Type     ( Type, tyConAppTyCon )
  30 import TyCon
  31 import CLabel
  32 import CmmUtils
  33 import PrimOp
  34 import SMRep
  35 import Constants
  36 import Module
  37 import FastString
  38 import Outputable
  39
  40 ------------------------------------------------------------------------
  41 --      Primitive operations and foreign calls
  42 ------------------------------------------------------------------------
  43
  44 {- Note [Foreign call results]
  45    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  46 A foreign call always returns an unboxed tuple of results, one
  47 of which is the state token.  This seems to happen even for pure
  48 calls.
  49
  50 Even if we returned a single result for pure calls, it'd still be
  51 right to wrap it in a singleton unboxed tuple, because the result
  52 might be a Haskell closure pointer, we don't want to evaluate it. -}
  53
  54 ----------------------------------
  55 cgOpApp :: StgOp        -- The op
  56         -> [StgArg]     -- Arguments
  57         -> Type         -- Result type (always an unboxed tuple)
  58         -> FCode ()
  59
  60 -- Foreign calls
  61 cgOpApp (StgFCallOp fcall _) stg_args res_ty
  62   = do  { (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
  63                 -- Choose result regs r1, r2
  64                 -- Note [Foreign call results]
  65         ; cgForeignCall res_regs res_hints fcall stg_args
  66                 -- r1, r2 = foo( x, y )
  67         ; emitReturn (map (CmmReg . CmmLocal) res_regs) }
  68                 -- return (r1, r2)
  69
  70 -- tagToEnum# is special: we need to pull the constructor
  71 -- out of the table, and perform an appropriate return.
  72
  73 cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
  74   = ASSERT(isEnumerationTyCon tycon)
  75     do  { args' <- getNonVoidArgAmodes [arg]
  76         ; let amode = case args' of [amode] -> amode
  77                                     _ -> panic "TagToEnumOp had void arg"
  78         ; emitReturn [tagToClosure tycon amode] }
  79    where
  80           -- If you're reading this code in the attempt to figure
  81           -- out why the compiler panic'ed here, it is probably because
  82           -- you used tagToEnum# in a non-monomorphic setting, e.g.,
  83           --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
  84           -- That won't work.
  85         tycon = tyConAppTyCon res_ty
  86
  87 cgOpApp (StgPrimOp primop) args res_ty
  88   | primOpOutOfLine primop
  89   = do  { cmm_args <- getNonVoidArgAmodes args
  90         ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
  91         ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
  92
  93   | ReturnsPrim VoidRep <- result_info
  94   = do cgPrimOp [] primop args
  95        emitReturn []
  96
  97   | ReturnsPrim rep <- result_info
  98   = do res <- newTemp (primRepCmmType rep)
  99        cgPrimOp [res] primop args
 100        emitReturn [CmmReg (CmmLocal res)]
 101
 102   | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
 103   = do (regs, _hints) <- newUnboxedTupleRegs res_ty
 104        cgPrimOp regs primop args
 105        emitReturn (map (CmmReg . CmmLocal) regs)
 106
 107   | ReturnsAlg tycon <- result_info
 108   , isEnumerationTyCon tycon
 109         -- c.f. cgExpr (...TagToEnumOp...)
 110   = do  tag_reg <- newTemp bWord
 111         cgPrimOp [tag_reg] primop args
 112         emitReturn [tagToClosure tycon
 113                         (CmmReg (CmmLocal tag_reg))]
 114
 115   | otherwise = panic "cgPrimop"
 116   where
 117      result_info = getPrimOpResultInfo primop
 118
 119 cgOpApp (StgPrimCallOp primcall) args _res_ty
 120   = do  { cmm_args <- getNonVoidArgAmodes args
 121         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
 122         ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
 123
 124 ---------------------------------------------------
 125 cgPrimOp   :: [LocalReg]        -- where to put the results
 126            -> PrimOp            -- the op
 127            -> [StgArg]          -- arguments
 128            -> FCode ()
 129
 130 cgPrimOp results op args
 131   = do arg_exprs <- getNonVoidArgAmodes args
 132        emitPrimOp results op arg_exprs
 133
 134
 135 ------------------------------------------------------------------------
 136 --      Emitting code for a primop
 137 ------------------------------------------------------------------------
 138
 139 emitPrimOp :: [LocalReg]        -- where to put the results
 140            -> PrimOp            -- the op
 141            -> [CmmExpr]         -- arguments
 142            -> FCode ()
 143
 144 -- First we handle various awkward cases specially.  The remaining
 145 -- easy cases are then handled by translateOp, defined below.
 146
 147 emitPrimOp [res_r,res_c] IntAddCOp [aa,bb]
 148 {-
 149    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 150    C, and without needing any comparisons.  This may not be the
 151    fastest way to do it - if you have better code, please send it! --SDM
 152
 153    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 154
 155    We currently don't make use of the r value if c is != 0 (i.e.
 156    overflow), we just convert to big integers and try again.  This
 157    could be improved by making r and c the correct values for
 158    plugging into a new J#.
 159
 160    { r = ((I_)(a)) + ((I_)(b));                                 \
 161      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
 162          >> (BITS_IN (I_) - 1);                                 \
 163    }
 164    Wading through the mass of bracketry, it seems to reduce to:
 165    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
 166
 167 -}
 168    = emit $ catAGraphs [
 169         mkAssign (CmmLocal res_r) (CmmMachOp mo_wordAdd [aa,bb]),
 170         mkAssign (CmmLocal res_c) $
 171           CmmMachOp mo_wordUShr [
 172                 CmmMachOp mo_wordAnd [
 173                     CmmMachOp mo_wordNot [CmmMachOp mo_wordXor [aa,bb]],
 174                     CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
 175                 ],
 176                 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
 177           ]
 178      ]
 179
 180
 181 emitPrimOp [res_r,res_c] IntSubCOp [aa,bb]
 182 {- Similarly:
 183    #define subIntCzh(r,c,a,b)                                   \
 184    { r = ((I_)(a)) - ((I_)(b));                                 \
 185      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
 186          >> (BITS_IN (I_) - 1);                                 \
 187    }
 188
 189    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
 190 -}
 191    = emit $ catAGraphs [
 192         mkAssign (CmmLocal res_r) (CmmMachOp mo_wordSub [aa,bb]),
 193         mkAssign (CmmLocal res_c) $
 194           CmmMachOp mo_wordUShr [
 195                 CmmMachOp mo_wordAnd [
 196                     CmmMachOp mo_wordXor [aa,bb],
 197                     CmmMachOp mo_wordXor [aa, CmmReg (CmmLocal res_r)]
 198                 ],
 199                 CmmLit (mkIntCLit (wORD_SIZE_IN_BITS - 1))
 200           ]
 201      ]
 202
 203
 204 emitPrimOp [res] ParOp [arg]
 205   =
 206         -- for now, just implement this in a C function
 207         -- later, we might want to inline it.
 208     emitCCall
 209         [(res,NoHint)]
 210         (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))))
 211         [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
 212
 213 emitPrimOp [res] ReadMutVarOp [mutv]
 214    = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord))
 215
 216 emitPrimOp [] WriteMutVarOp [mutv,var]
 217    = do
 218         emit (mkStore (cmmOffsetW mutv fixedHdrSize) var)
 219         emitCCall
 220                 [{-no results-}]
 221                 (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
 222                 [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]
 223
 224 --  #define sizzeofByteArrayzh(r,a) \
 225 --     r = ((StgArrWords *)(a))->bytes
 226 emitPrimOp [res] SizeofByteArrayOp [arg]
 227    = emit $
 228         mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord)
 229
 230 --  #define sizzeofMutableByteArrayzh(r,a) \
 231 --      r = ((StgArrWords *)(a))->bytes
 232 emitPrimOp [res] SizeofMutableByteArrayOp [arg]
 233    = emitPrimOp [res] SizeofByteArrayOp [arg]
 234
 235
 236 --  #define touchzh(o)                  /* nothing */
 237 emitPrimOp res@[] TouchOp args@[_arg]
 238    = do emitPrimCall res MO_Touch args
 239
 240 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 241 emitPrimOp [res] ByteArrayContents_Char [arg]
 242    = emit (mkAssign (CmmLocal res) (cmmOffsetB arg arrWordsHdrSize))
 243
 244 --  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 245 emitPrimOp [res] StableNameToIntOp [arg]
 246    = emit (mkAssign (CmmLocal res) (cmmLoadIndexW arg fixedHdrSize bWord))
 247
 248 --  #define eqStableNamezh(r,sn1,sn2)                                   \
 249 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 250 emitPrimOp [res] EqStableNameOp [arg1,arg2]
 251    = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [
 252                                 cmmLoadIndexW arg1 fixedHdrSize bWord,
 253                                 cmmLoadIndexW arg2 fixedHdrSize bWord
 254                          ]))
 255
 256
 257 emitPrimOp [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
 258    = emit (mkAssign (CmmLocal res) (CmmMachOp mo_wordEq [arg1,arg2]))
 259
 260 --  #define addrToHValuezh(r,a) r=(P_)a
 261 emitPrimOp [res] AddrToHValueOp [arg]
 262    = emit (mkAssign (CmmLocal res) arg)
 263
 264 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 265 --  Note: argument may be tagged!
 266 emitPrimOp [res] DataToTagOp [arg]
 267    = emit (mkAssign (CmmLocal res) (getConstrTag (cmmUntag arg)))
 268
 269 {- Freezing arrays-of-ptrs requires changing an info table, for the
 270    benefit of the generational collector.  It needs to scavenge mutable
 271    objects, even if they are in old space.  When they become immutable,
 272    they can be removed from this scavenge list.  -}
 273
 274 --  #define unsafeFreezzeArrayzh(r,a)
 275 --      {
 276 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
 277 --        r = a;
 278 --      }
 279 emitPrimOp [res] UnsafeFreezeArrayOp [arg]
 280    = emit $ catAGraphs
 281          [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
 282            mkAssign (CmmLocal res) arg ]
 283
 284 --  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
 285 emitPrimOp [res] UnsafeFreezeByteArrayOp [arg]
 286    = emit (mkAssign (CmmLocal res) arg)
 287
 288 -- Copying pointer arrays
 289
 290 emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] =
 291     doCopyArrayOp src src_off dst dst_off n
 292 emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] =
 293     doCopyMutableArrayOp src src_off dst dst_off n
 294 emitPrimOp [res] CloneArrayOp [src,src_off,n] =
 295     emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
 296 emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] =
 297     emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
 298 emitPrimOp [res] FreezeArrayOp [src,src_off,n] =
 299     emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n
 300 emitPrimOp [res] ThawArrayOp [src,src_off,n] =
 301     emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n
 302
 303 -- Reading/writing pointer arrays
 304
 305 emitPrimOp [r] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp r obj ix
 306 emitPrimOp [r] IndexArrayOp [obj,ix]    = doReadPtrArrayOp r obj ix
 307 emitPrimOp []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v
 308
 309 emitPrimOp [res] SizeofArrayOp [arg]
 310    = emit $     mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord)
 311 emitPrimOp [res] SizeofMutableArrayOp [arg]
 312    = emitPrimOp [res] SizeofArrayOp [arg]
 313
 314 -- IndexXXXoffAddr
 315
 316 emitPrimOp res IndexOffAddrOp_Char      args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
 317 emitPrimOp res IndexOffAddrOp_WideChar  args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 318 emitPrimOp res IndexOffAddrOp_Int       args = doIndexOffAddrOp Nothing bWord res args
 319 emitPrimOp res IndexOffAddrOp_Word      args = doIndexOffAddrOp Nothing bWord res args
 320 emitPrimOp res IndexOffAddrOp_Addr      args = doIndexOffAddrOp Nothing bWord res args
 321 emitPrimOp res IndexOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
 322 emitPrimOp res IndexOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
 323 emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
 324 emitPrimOp res IndexOffAddrOp_Int8      args = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
 325 emitPrimOp res IndexOffAddrOp_Int16     args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
 326 emitPrimOp res IndexOffAddrOp_Int32     args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
 327 emitPrimOp res IndexOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
 328 emitPrimOp res IndexOffAddrOp_Word8     args = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
 329 emitPrimOp res IndexOffAddrOp_Word16    args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
 330 emitPrimOp res IndexOffAddrOp_Word32    args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 331 emitPrimOp res IndexOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
 332
 333 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 334
 335 emitPrimOp res ReadOffAddrOp_Char      args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
 336 emitPrimOp res ReadOffAddrOp_WideChar  args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 337 emitPrimOp res ReadOffAddrOp_Int       args = doIndexOffAddrOp Nothing bWord res args
 338 emitPrimOp res ReadOffAddrOp_Word      args = doIndexOffAddrOp Nothing bWord res args
 339 emitPrimOp res ReadOffAddrOp_Addr      args = doIndexOffAddrOp Nothing bWord res args
 340 emitPrimOp res ReadOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
 341 emitPrimOp res ReadOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
 342 emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
 343 emitPrimOp res ReadOffAddrOp_Int8      args = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
 344 emitPrimOp res ReadOffAddrOp_Int16     args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
 345 emitPrimOp res ReadOffAddrOp_Int32     args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
 346 emitPrimOp res ReadOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
 347 emitPrimOp res ReadOffAddrOp_Word8     args = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
 348 emitPrimOp res ReadOffAddrOp_Word16    args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
 349 emitPrimOp res ReadOffAddrOp_Word32    args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 350 emitPrimOp res ReadOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
 351
 352 -- IndexXXXArray
 353
 354 emitPrimOp res IndexByteArrayOp_Char      args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
 355 emitPrimOp res IndexByteArrayOp_WideChar  args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
 356 emitPrimOp res IndexByteArrayOp_Int       args = doIndexByteArrayOp Nothing bWord res args
 357 emitPrimOp res IndexByteArrayOp_Word      args = doIndexByteArrayOp Nothing bWord res args
 358 emitPrimOp res IndexByteArrayOp_Addr      args = doIndexByteArrayOp Nothing bWord res args
 359 emitPrimOp res IndexByteArrayOp_Float     args = doIndexByteArrayOp Nothing f32 res args
 360 emitPrimOp res IndexByteArrayOp_Double    args = doIndexByteArrayOp Nothing f64 res args
 361 emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args
 362 emitPrimOp res IndexByteArrayOp_Int8      args = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
 363 emitPrimOp res IndexByteArrayOp_Int16     args = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
 364 emitPrimOp res IndexByteArrayOp_Int32     args = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
 365 emitPrimOp res IndexByteArrayOp_Int64     args = doIndexByteArrayOp Nothing b64  res args
 366 emitPrimOp res IndexByteArrayOp_Word8     args = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
 367 emitPrimOp res IndexByteArrayOp_Word16    args = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
 368 emitPrimOp res IndexByteArrayOp_Word32    args = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
 369 emitPrimOp res IndexByteArrayOp_Word64    args = doIndexByteArrayOp Nothing b64  res args
 370
 371 -- ReadXXXArray, identical to IndexXXXArray.
 372
 373 emitPrimOp res ReadByteArrayOp_Char       args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
 374 emitPrimOp res ReadByteArrayOp_WideChar   args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
 375 emitPrimOp res ReadByteArrayOp_Int        args = doIndexByteArrayOp Nothing bWord res args
 376 emitPrimOp res ReadByteArrayOp_Word       args = doIndexByteArrayOp Nothing bWord res args
 377 emitPrimOp res ReadByteArrayOp_Addr       args = doIndexByteArrayOp Nothing bWord res args
 378 emitPrimOp res ReadByteArrayOp_Float      args = doIndexByteArrayOp Nothing f32 res args
 379 emitPrimOp res ReadByteArrayOp_Double     args = doIndexByteArrayOp Nothing f64 res args
 380 emitPrimOp res ReadByteArrayOp_StablePtr  args = doIndexByteArrayOp Nothing bWord res args
 381 emitPrimOp res ReadByteArrayOp_Int8       args = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
 382 emitPrimOp res ReadByteArrayOp_Int16      args = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
 383 emitPrimOp res ReadByteArrayOp_Int32      args = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
 384 emitPrimOp res ReadByteArrayOp_Int64      args = doIndexByteArrayOp Nothing b64  res args
 385 emitPrimOp res ReadByteArrayOp_Word8      args = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
 386 emitPrimOp res ReadByteArrayOp_Word16     args = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
 387 emitPrimOp res ReadByteArrayOp_Word32     args = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
 388 emitPrimOp res ReadByteArrayOp_Word64     args = doIndexByteArrayOp Nothing b64  res args
 389
 390 -- WriteXXXoffAddr
 391
 392 emitPrimOp res WriteOffAddrOp_Char       args = doWriteOffAddrOp (Just mo_WordTo8)  res args
 393 emitPrimOp res WriteOffAddrOp_WideChar   args = doWriteOffAddrOp (Just mo_WordTo32) res args
 394 emitPrimOp res WriteOffAddrOp_Int        args = doWriteOffAddrOp Nothing res args
 395 emitPrimOp res WriteOffAddrOp_Word       args = doWriteOffAddrOp Nothing res args
 396 emitPrimOp res WriteOffAddrOp_Addr       args = doWriteOffAddrOp Nothing res args
 397 emitPrimOp res WriteOffAddrOp_Float      args = doWriteOffAddrOp Nothing res args
 398 emitPrimOp res WriteOffAddrOp_Double     args = doWriteOffAddrOp Nothing res args
 399 emitPrimOp res WriteOffAddrOp_StablePtr  args = doWriteOffAddrOp Nothing res args
 400 emitPrimOp res WriteOffAddrOp_Int8       args = doWriteOffAddrOp (Just mo_WordTo8)  res args
 401 emitPrimOp res WriteOffAddrOp_Int16      args = doWriteOffAddrOp (Just mo_WordTo16) res args
 402 emitPrimOp res WriteOffAddrOp_Int32      args = doWriteOffAddrOp (Just mo_WordTo32) res args
 403 emitPrimOp res WriteOffAddrOp_Int64      args = doWriteOffAddrOp Nothing res args
 404 emitPrimOp res WriteOffAddrOp_Word8      args = doWriteOffAddrOp (Just mo_WordTo8)  res args
 405 emitPrimOp res WriteOffAddrOp_Word16     args = doWriteOffAddrOp (Just mo_WordTo16) res args
 406 emitPrimOp res WriteOffAddrOp_Word32     args = doWriteOffAddrOp (Just mo_WordTo32) res args
 407 emitPrimOp res WriteOffAddrOp_Word64     args = doWriteOffAddrOp Nothing res args
 408
 409 -- WriteXXXArray
 410
 411 emitPrimOp res WriteByteArrayOp_Char      args = doWriteByteArrayOp (Just mo_WordTo8)  res args
 412 emitPrimOp res WriteByteArrayOp_WideChar  args = doWriteByteArrayOp (Just mo_WordTo32) res args
 413 emitPrimOp res WriteByteArrayOp_Int       args = doWriteByteArrayOp Nothing res args
 414 emitPrimOp res WriteByteArrayOp_Word      args = doWriteByteArrayOp Nothing res args
 415 emitPrimOp res WriteByteArrayOp_Addr      args = doWriteByteArrayOp Nothing res args
 416 emitPrimOp res WriteByteArrayOp_Float     args = doWriteByteArrayOp Nothing res args
 417 emitPrimOp res WriteByteArrayOp_Double    args = doWriteByteArrayOp Nothing res args
 418 emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
 419 emitPrimOp res WriteByteArrayOp_Int8      args = doWriteByteArrayOp (Just mo_WordTo8)  res args
 420 emitPrimOp res WriteByteArrayOp_Int16     args = doWriteByteArrayOp (Just mo_WordTo16) res args
 421 emitPrimOp res WriteByteArrayOp_Int32     args = doWriteByteArrayOp (Just mo_WordTo32) res args
 422 emitPrimOp res WriteByteArrayOp_Int64     args = doWriteByteArrayOp Nothing  res args
 423 emitPrimOp res WriteByteArrayOp_Word8     args = doWriteByteArrayOp (Just mo_WordTo8)  res args
 424 emitPrimOp res WriteByteArrayOp_Word16    args = doWriteByteArrayOp (Just mo_WordTo16) res args
 425 emitPrimOp res WriteByteArrayOp_Word32    args = doWriteByteArrayOp (Just mo_WordTo32) res args
 426 emitPrimOp res WriteByteArrayOp_Word64    args = doWriteByteArrayOp Nothing res args
 427
 428
 429 -- The rest just translate straightforwardly
 430 emitPrimOp [res] op [arg]
 431    | nopOp op
 432    = emit (mkAssign (CmmLocal res) arg)
 433
 434    | Just (mop,rep) <- narrowOp op
 435    = emit (mkAssign (CmmLocal res) $
 436            CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
 437
 438 emitPrimOp r@[res] op args
 439    | Just prim <- callishOp op
 440    = do emitPrimCall r prim args
 441
 442    | Just mop <- translateOp op
 443    = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
 444      emit stmt
 445
 446 emitPrimOp _ op _
 447  = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
 448
 449
 450 -- These PrimOps are NOPs in Cmm
 451
 452 nopOp :: PrimOp -> Bool
 453 nopOp Int2WordOp     = True
 454 nopOp Word2IntOp     = True
 455 nopOp Int2AddrOp     = True
 456 nopOp Addr2IntOp     = True
 457 nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
 458 nopOp OrdOp          = True
 459 nopOp _              = False
 460
 461 -- These PrimOps turn into double casts
 462
 463 narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
 464 narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
 465 narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
 466 narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
 467 narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
 468 narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
 469 narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
 470 narrowOp _              = Nothing
 471
 472 -- Native word signless ops
 473
 474 translateOp :: PrimOp -> Maybe MachOp
 475 translateOp IntAddOp       = Just mo_wordAdd
 476 translateOp IntSubOp       = Just mo_wordSub
 477 translateOp WordAddOp      = Just mo_wordAdd
 478 translateOp WordSubOp      = Just mo_wordSub
 479 translateOp AddrAddOp      = Just mo_wordAdd
 480 translateOp AddrSubOp      = Just mo_wordSub
 481
 482 translateOp IntEqOp        = Just mo_wordEq
 483 translateOp IntNeOp        = Just mo_wordNe
 484 translateOp WordEqOp       = Just mo_wordEq
 485 translateOp WordNeOp       = Just mo_wordNe
 486 translateOp AddrEqOp       = Just mo_wordEq
 487 translateOp AddrNeOp       = Just mo_wordNe
 488
 489 translateOp AndOp          = Just mo_wordAnd
 490 translateOp OrOp           = Just mo_wordOr
 491 translateOp XorOp          = Just mo_wordXor
 492 translateOp NotOp          = Just mo_wordNot
 493 translateOp SllOp          = Just mo_wordShl
 494 translateOp SrlOp          = Just mo_wordUShr
 495
 496 translateOp AddrRemOp      = Just mo_wordURem
 497
 498 -- Native word signed ops
 499
 500 translateOp IntMulOp        = Just mo_wordMul
 501 translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
 502 translateOp IntQuotOp       = Just mo_wordSQuot
 503 translateOp IntRemOp        = Just mo_wordSRem
 504 translateOp IntNegOp        = Just mo_wordSNeg
 505
 506
 507 translateOp IntGeOp        = Just mo_wordSGe
 508 translateOp IntLeOp        = Just mo_wordSLe
 509 translateOp IntGtOp        = Just mo_wordSGt
 510 translateOp IntLtOp        = Just mo_wordSLt
 511
 512 translateOp ISllOp         = Just mo_wordShl
 513 translateOp ISraOp         = Just mo_wordSShr
 514 translateOp ISrlOp         = Just mo_wordUShr
 515
 516 -- Native word unsigned ops
 517
 518 translateOp WordGeOp       = Just mo_wordUGe
 519 translateOp WordLeOp       = Just mo_wordULe
 520 translateOp WordGtOp       = Just mo_wordUGt
 521 translateOp WordLtOp       = Just mo_wordULt
 522
 523 translateOp WordMulOp      = Just mo_wordMul
 524 translateOp WordQuotOp     = Just mo_wordUQuot
 525 translateOp WordRemOp      = Just mo_wordURem
 526
 527 translateOp AddrGeOp       = Just mo_wordUGe
 528 translateOp AddrLeOp       = Just mo_wordULe
 529 translateOp AddrGtOp       = Just mo_wordUGt
 530 translateOp AddrLtOp       = Just mo_wordULt
 531
 532 -- Char# ops
 533
 534 translateOp CharEqOp       = Just (MO_Eq wordWidth)
 535 translateOp CharNeOp       = Just (MO_Ne wordWidth)
 536 translateOp CharGeOp       = Just (MO_U_Ge wordWidth)
 537 translateOp CharLeOp       = Just (MO_U_Le wordWidth)
 538 translateOp CharGtOp       = Just (MO_U_Gt wordWidth)
 539 translateOp CharLtOp       = Just (MO_U_Lt wordWidth)
 540
 541 -- Double ops
 542
 543 translateOp DoubleEqOp     = Just (MO_F_Eq W64)
 544 translateOp DoubleNeOp     = Just (MO_F_Ne W64)
 545 translateOp DoubleGeOp     = Just (MO_F_Ge W64)
 546 translateOp DoubleLeOp     = Just (MO_F_Le W64)
 547 translateOp DoubleGtOp     = Just (MO_F_Gt W64)
 548 translateOp DoubleLtOp     = Just (MO_F_Lt W64)
 549
 550 translateOp DoubleAddOp    = Just (MO_F_Add W64)
 551 translateOp DoubleSubOp    = Just (MO_F_Sub W64)
 552 translateOp DoubleMulOp    = Just (MO_F_Mul W64)
 553 translateOp DoubleDivOp    = Just (MO_F_Quot W64)
 554 translateOp DoubleNegOp    = Just (MO_F_Neg W64)
 555
 556 -- Float ops
 557
 558 translateOp FloatEqOp     = Just (MO_F_Eq W32)
 559 translateOp FloatNeOp     = Just (MO_F_Ne W32)
 560 translateOp FloatGeOp     = Just (MO_F_Ge W32)
 561 translateOp FloatLeOp     = Just (MO_F_Le W32)
 562 translateOp FloatGtOp     = Just (MO_F_Gt W32)
 563 translateOp FloatLtOp     = Just (MO_F_Lt W32)
 564
 565 translateOp FloatAddOp    = Just (MO_F_Add  W32)
 566 translateOp FloatSubOp    = Just (MO_F_Sub  W32)
 567 translateOp FloatMulOp    = Just (MO_F_Mul  W32)
 568 translateOp FloatDivOp    = Just (MO_F_Quot W32)
 569 translateOp FloatNegOp    = Just (MO_F_Neg  W32)
 570
 571 -- Conversions
 572
 573 translateOp Int2DoubleOp   = Just (MO_SF_Conv wordWidth W64)
 574 translateOp Double2IntOp   = Just (MO_FS_Conv W64 wordWidth)
 575
 576 translateOp Int2FloatOp    = Just (MO_SF_Conv wordWidth W32)
 577 translateOp Float2IntOp    = Just (MO_FS_Conv W32 wordWidth)
 578
 579 translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
 580 translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
 581
 582 -- Word comparisons masquerading as more exotic things.
 583
 584 translateOp SameMutVarOp           = Just mo_wordEq
 585 translateOp SameMVarOp             = Just mo_wordEq
 586 translateOp SameMutableArrayOp     = Just mo_wordEq
 587 translateOp SameMutableByteArrayOp = Just mo_wordEq
 588 translateOp SameTVarOp             = Just mo_wordEq
 589 translateOp EqStablePtrOp          = Just mo_wordEq
 590
 591 translateOp _ = Nothing
 592
 593 -- These primops are implemented by CallishMachOps, because they sometimes
 594 -- turn into foreign calls depending on the backend.
 595
 596 callishOp :: PrimOp -> Maybe CallishMachOp
 597 callishOp DoublePowerOp  = Just MO_F64_Pwr
 598 callishOp DoubleSinOp    = Just MO_F64_Sin
 599 callishOp DoubleCosOp    = Just MO_F64_Cos
 600 callishOp DoubleTanOp    = Just MO_F64_Tan
 601 callishOp DoubleSinhOp   = Just MO_F64_Sinh
 602 callishOp DoubleCoshOp   = Just MO_F64_Cosh
 603 callishOp DoubleTanhOp   = Just MO_F64_Tanh
 604 callishOp DoubleAsinOp   = Just MO_F64_Asin
 605 callishOp DoubleAcosOp   = Just MO_F64_Acos
 606 callishOp DoubleAtanOp   = Just MO_F64_Atan
 607 callishOp DoubleLogOp    = Just MO_F64_Log
 608 callishOp DoubleExpOp    = Just MO_F64_Exp
 609 callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
 610
 611 callishOp FloatPowerOp  = Just MO_F32_Pwr
 612 callishOp FloatSinOp    = Just MO_F32_Sin
 613 callishOp FloatCosOp    = Just MO_F32_Cos
 614 callishOp FloatTanOp    = Just MO_F32_Tan
 615 callishOp FloatSinhOp   = Just MO_F32_Sinh
 616 callishOp FloatCoshOp   = Just MO_F32_Cosh
 617 callishOp FloatTanhOp   = Just MO_F32_Tanh
 618 callishOp FloatAsinOp   = Just MO_F32_Asin
 619 callishOp FloatAcosOp   = Just MO_F32_Acos
 620 callishOp FloatAtanOp   = Just MO_F32_Atan
 621 callishOp FloatLogOp    = Just MO_F32_Log
 622 callishOp FloatExpOp    = Just MO_F32_Exp
 623 callishOp FloatSqrtOp   = Just MO_F32_Sqrt
 624
 625 callishOp _ = Nothing
 626
 627 ------------------------------------------------------------------------------
 628 -- Helpers for translating various minor variants of array indexing.
 629
 630 doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
 631 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
 632    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
 633 doIndexOffAddrOp _ _ _ _
 634    = panic "CgPrimOp: doIndexOffAddrOp"
 635
 636 doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
 637 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
 638    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
 639 doIndexByteArrayOp _ _ _ _
 640    = panic "CgPrimOp: doIndexByteArrayOp"
 641
 642 doReadPtrArrayOp ::  LocalReg -> CmmExpr -> CmmExpr -> FCode ()
 643 doReadPtrArrayOp res addr idx
 644    = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
 645
 646
 647 doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
 648 doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val]
 649    = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val
 650 doWriteOffAddrOp _ _ _
 651    = panic "CgPrimOp: doWriteOffAddrOp"
 652
 653 doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
 654 doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
 655    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val
 656 doWriteByteArrayOp _ _ _
 657    = panic "CgPrimOp: doWriteByteArrayOp"
 658
 659 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 660 doWritePtrArrayOp addr idx val
 661   = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val
 662        emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 663   -- the write barrier.  We must write a byte into the mark table:
 664   -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
 665        emit $ mkStore (
 666          cmmOffsetExpr
 667           (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
 668                          (loadArrPtrsSize addr))
 669           (CmmMachOp mo_wordUShr [idx,
 670                                   CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
 671          ) (CmmLit (CmmInt 1 W8))
 672
 673 loadArrPtrsSize :: CmmExpr -> CmmExpr
 674 loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord
 675  where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
 676
 677 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
 678                    -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
 679 mkBasicIndexedRead off Nothing read_rep res base idx
 680    = emit (mkAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx))
 681 mkBasicIndexedRead off (Just cast) read_rep res base idx
 682    = emit (mkAssign (CmmLocal res) (CmmMachOp cast [
 683                                 cmmLoadIndexOffExpr off read_rep base idx]))
 684
 685 mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
 686                    -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 687 mkBasicIndexedWrite off Nothing base idx val
 688    = emit (mkStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val)
 689 mkBasicIndexedWrite off (Just cast) base idx val
 690    = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])
 691
 692 -- ----------------------------------------------------------------------------
 693 -- Misc utils
 694
 695 cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr
 696 cmmIndexOffExpr off width base idx
 697    = cmmIndexExpr width (cmmOffsetB base off) idx
 698
 699 cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
 700 cmmLoadIndexOffExpr off ty base idx
 701    = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty
 702
 703 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
 704 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
 705
 706 -- ----------------------------------------------------------------------------
 707 -- Copying pointer arrays
 708
 709 -- EZY: This code has an unusually high amount of assignTemp calls, seen
 710 -- nowhere else in the code generator.  This is mostly because these
 711 -- "primitive" ops result in a surprisingly large amount of code.  It
 712 -- will likely be worthwhile to optimize what is emitted here, so that
 713 -- our optimization passes don't waste time repeatedly optimizing the
 714 -- same bits of code.
 715
 716 -- More closely imitates 'assignTemp' from the old code generator, which
 717 -- returns a CmmExpr rather than a LocalReg.
 718 assignTempE :: CmmExpr -> FCode CmmExpr
 719 assignTempE e = do
 720     t <- assignTemp e
 721     return (CmmReg (CmmLocal t))
 722
 723 -- | Takes a source 'Array#', an offset in the source array, a
 724 -- destination 'MutableArray#', an offset into the destination array,
 725 -- and the number of elements to copy.  Copies the given number of
 726 -- elements from the source array to the destination array.
 727 doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
 728               -> FCode ()
 729 doCopyArrayOp = emitCopyArray copy
 730   where
 731     -- Copy data (we assume the arrays aren't overlapping since
 732     -- they're of different types)
 733     copy _src _dst = emitMemcpyCall
 734
 735 -- | Takes a source 'MutableArray#', an offset in the source array, a
 736 -- destination 'MutableArray#', an offset into the destination array,
 737 -- and the number of elements to copy.  Copies the given number of
 738 -- elements from the source array to the destination array.
 739 doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
 740                      -> FCode ()
 741 doCopyMutableArrayOp = emitCopyArray copy
 742   where
 743     -- The only time the memory might overlap is when the two arrays
 744     -- we were provided are the same array!
 745     -- TODO: Optimize branch for common case of no aliasing.
 746     copy src dst dst_p src_p bytes = do
 747         [moveCall, cpyCall] <- forkAlts [
 748             getCode $ emitMemmoveCall dst_p src_p bytes,
 749             getCode $ emitMemcpyCall  dst_p src_p bytes
 750             ]
 751         emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall
 752
 753 emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
 754                   -> FCode ())
 755               -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
 756               -> FCode ()
 757 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
 758     -- Passed as arguments (be careful)
 759     src     <- assignTempE src0
 760     src_off <- assignTempE src_off0
 761     dst     <- assignTempE dst0
 762     dst_off <- assignTempE dst_off0
 763     n       <- assignTempE n0
 764
 765     -- Set the dirty bit in the header.
 766     emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 767
 768     dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize
 769     dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off
 770     src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
 771     bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
 772
 773     copy src dst dst_p src_p bytes
 774
 775     -- The base address of the destination card table
 776     dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
 777
 778     emitSetCards dst_off dst_cards_p n
 779
 780 -- | Takes an info table label, a register to return the newly
 781 -- allocated array in, a source array, an offset in the source array,
 782 -- and the number of elements to copy.  Allocates a new array and
 783 -- initializes it form the source array.
 784 emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
 785                -> FCode ()
 786 emitCloneArray info_p res_r src0 src_off0 n0 = do
 787     -- Passed as arguments (be careful)
 788     src     <- assignTempE src0
 789     src_off <- assignTempE src_off0
 790     n       <- assignTempE n0
 791
 792     card_words <- assignTempE $ (n `cmmUShrWord`
 793                                 (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
 794                   `cmmAddWord` CmmLit (mkIntCLit 1)
 795     size <- assignTempE $ n `cmmAddWord` card_words
 796     words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size
 797
 798     arr_r <- newTemp bWord
 799     emitAllocateCall arr_r myCapability words
 800     tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
 801         (CmmLit $ mkIntCLit 0)
 802
 803     let arr = CmmReg (CmmLocal arr_r)
 804     emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
 805     emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
 806                                     oFFSET_StgMutArrPtrs_ptrs)) n
 807     emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
 808                                     oFFSET_StgMutArrPtrs_size)) size
 809
 810     dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize
 811     src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
 812              src_off
 813
 814     emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize)
 815
 816     emitMemsetCall (cmmOffsetExprW dst_p n)
 817         (CmmLit (mkIntCLit 1))
 818         (card_words `cmmMulWord` wordSize)
 819     emit $ mkAssign (CmmLocal res_r) arr
 820   where
 821     arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
 822                       (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
 823     wordSize = CmmLit (mkIntCLit wORD_SIZE)
 824     myCapability = CmmReg baseReg `cmmSubWord`
 825                    CmmLit (mkIntCLit oFFSET_Capability_r)
 826
 827 -- | Takes and offset in the destination array, the base address of
 828 -- the card table, and the number of elements affected (*not* the
 829 -- number of cards).  Marks the relevant cards as dirty.
 830 emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 831 emitSetCards dst_start dst_cards_start n = do
 832     start_card <- assignTempE $ card dst_start
 833     emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
 834         (CmmLit (mkIntCLit 1))
 835         ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
 836          `cmmAddWord` CmmLit (mkIntCLit 1))
 837   where
 838     -- Convert an element index to a card index
 839     card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
 840
 841 -- | Emit a call to @memcpy@.
 842 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 843 emitMemcpyCall dst src n = do
 844     emitCCall
 845         [ {-no results-} ]
 846         memcpy
 847         [ (dst, AddrHint)
 848         , (src, AddrHint)
 849         , (n, NoHint)
 850         ]
 851   where
 852     memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
 853                                ForeignLabelInExternalPackage IsFunction))
 854
 855 -- | Emit a call to @memmove@.
 856 emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 857 emitMemmoveCall dst src n = do
 858     emitCCall
 859         [ {- no results -} ]
 860         memmove
 861         [ (dst, AddrHint)
 862         , (src, AddrHint)
 863         , (n, NoHint)
 864         ]
 865   where
 866     memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
 867                                ForeignLabelInExternalPackage IsFunction))
 868
 869 -- | Emit a call to @memset@.  The second argument must fit inside an
 870 -- unsigned char.
 871 emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 872 emitMemsetCall dst c n = do
 873     emitCCall
 874         [ {- no results -} ]
 875         memset
 876         [ (dst, AddrHint)
 877         , (c, NoHint)
 878         , (n, NoHint)
 879         ]
 880   where
 881     memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
 882                                ForeignLabelInExternalPackage IsFunction))
 883
 884 -- | Emit a call to @allocate@.
 885 emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> FCode ()
 886 emitAllocateCall res cap n = do
 887     emitCCall
 888         [ (res, AddrHint) ]
 889         allocate
 890         [ (cap, AddrHint)
 891         , (n, NoHint)
 892         ]
 893   where
 894     allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
 895                                  ForeignLabelInExternalPackage IsFunction))