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