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