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 emitPrimOp [res] SizeofArrayOp [arg]
 291    = emit $     mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord)
 292 emitPrimOp [res] SizeofMutableArrayOp [arg]
 293    = emitPrimOp [res] SizeofArrayOp [arg]
 294
 295 -- IndexXXXoffAddr
 296
 297 emitPrimOp res IndexOffAddrOp_Char      args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
 298 emitPrimOp res IndexOffAddrOp_WideChar  args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 299 emitPrimOp res IndexOffAddrOp_Int       args = doIndexOffAddrOp Nothing bWord res args
 300 emitPrimOp res IndexOffAddrOp_Word      args = doIndexOffAddrOp Nothing bWord res args
 301 emitPrimOp res IndexOffAddrOp_Addr      args = doIndexOffAddrOp Nothing bWord res args
 302 emitPrimOp res IndexOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
 303 emitPrimOp res IndexOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
 304 emitPrimOp res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
 305 emitPrimOp res IndexOffAddrOp_Int8      args = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
 306 emitPrimOp res IndexOffAddrOp_Int16     args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
 307 emitPrimOp res IndexOffAddrOp_Int32     args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
 308 emitPrimOp res IndexOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
 309 emitPrimOp res IndexOffAddrOp_Word8     args = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
 310 emitPrimOp res IndexOffAddrOp_Word16    args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
 311 emitPrimOp res IndexOffAddrOp_Word32    args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 312 emitPrimOp res IndexOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
 313
 314 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 315
 316 emitPrimOp res ReadOffAddrOp_Char      args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args
 317 emitPrimOp res ReadOffAddrOp_WideChar  args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 318 emitPrimOp res ReadOffAddrOp_Int       args = doIndexOffAddrOp Nothing bWord res args
 319 emitPrimOp res ReadOffAddrOp_Word      args = doIndexOffAddrOp Nothing bWord res args
 320 emitPrimOp res ReadOffAddrOp_Addr      args = doIndexOffAddrOp Nothing bWord res args
 321 emitPrimOp res ReadOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
 322 emitPrimOp res ReadOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
 323 emitPrimOp res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing bWord res args
 324 emitPrimOp res ReadOffAddrOp_Int8      args = doIndexOffAddrOp (Just mo_s_8ToWord) b8  res args
 325 emitPrimOp res ReadOffAddrOp_Int16     args = doIndexOffAddrOp (Just mo_s_16ToWord) b16 res args
 326 emitPrimOp res ReadOffAddrOp_Int32     args = doIndexOffAddrOp (Just mo_s_32ToWord) b32 res args
 327 emitPrimOp res ReadOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
 328 emitPrimOp res ReadOffAddrOp_Word8     args = doIndexOffAddrOp (Just mo_u_8ToWord) b8  res args
 329 emitPrimOp res ReadOffAddrOp_Word16    args = doIndexOffAddrOp (Just mo_u_16ToWord) b16 res args
 330 emitPrimOp res ReadOffAddrOp_Word32    args = doIndexOffAddrOp (Just mo_u_32ToWord) b32 res args
 331 emitPrimOp res ReadOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
 332
 333 -- IndexXXXArray
 334
 335 emitPrimOp res IndexByteArrayOp_Char      args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
 336 emitPrimOp res IndexByteArrayOp_WideChar  args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
 337 emitPrimOp res IndexByteArrayOp_Int       args = doIndexByteArrayOp Nothing bWord res args
 338 emitPrimOp res IndexByteArrayOp_Word      args = doIndexByteArrayOp Nothing bWord res args
 339 emitPrimOp res IndexByteArrayOp_Addr      args = doIndexByteArrayOp Nothing bWord res args
 340 emitPrimOp res IndexByteArrayOp_Float     args = doIndexByteArrayOp Nothing f32 res args
 341 emitPrimOp res IndexByteArrayOp_Double    args = doIndexByteArrayOp Nothing f64 res args
 342 emitPrimOp res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing bWord res args
 343 emitPrimOp res IndexByteArrayOp_Int8      args = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
 344 emitPrimOp res IndexByteArrayOp_Int16     args = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
 345 emitPrimOp res IndexByteArrayOp_Int32     args = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
 346 emitPrimOp res IndexByteArrayOp_Int64     args = doIndexByteArrayOp Nothing b64  res args
 347 emitPrimOp res IndexByteArrayOp_Word8     args = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
 348 emitPrimOp res IndexByteArrayOp_Word16    args = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
 349 emitPrimOp res IndexByteArrayOp_Word32    args = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
 350 emitPrimOp res IndexByteArrayOp_Word64    args = doIndexByteArrayOp Nothing b64  res args
 351
 352 -- ReadXXXArray, identical to IndexXXXArray.
 353
 354 emitPrimOp res ReadByteArrayOp_Char       args = doIndexByteArrayOp (Just mo_u_8ToWord) b8 res args
 355 emitPrimOp res ReadByteArrayOp_WideChar   args = doIndexByteArrayOp (Just mo_u_32ToWord) b32 res args
 356 emitPrimOp res ReadByteArrayOp_Int        args = doIndexByteArrayOp Nothing bWord res args
 357 emitPrimOp res ReadByteArrayOp_Word       args = doIndexByteArrayOp Nothing bWord res args
 358 emitPrimOp res ReadByteArrayOp_Addr       args = doIndexByteArrayOp Nothing bWord res args
 359 emitPrimOp res ReadByteArrayOp_Float      args = doIndexByteArrayOp Nothing f32 res args
 360 emitPrimOp res ReadByteArrayOp_Double     args = doIndexByteArrayOp Nothing f64 res args
 361 emitPrimOp res ReadByteArrayOp_StablePtr  args = doIndexByteArrayOp Nothing bWord res args
 362 emitPrimOp res ReadByteArrayOp_Int8       args = doIndexByteArrayOp (Just mo_s_8ToWord) b8  res args
 363 emitPrimOp res ReadByteArrayOp_Int16      args = doIndexByteArrayOp (Just mo_s_16ToWord) b16  res args
 364 emitPrimOp res ReadByteArrayOp_Int32      args = doIndexByteArrayOp (Just mo_s_32ToWord) b32  res args
 365 emitPrimOp res ReadByteArrayOp_Int64      args = doIndexByteArrayOp Nothing b64  res args
 366 emitPrimOp res ReadByteArrayOp_Word8      args = doIndexByteArrayOp (Just mo_u_8ToWord) b8  res args
 367 emitPrimOp res ReadByteArrayOp_Word16     args = doIndexByteArrayOp (Just mo_u_16ToWord) b16  res args
 368 emitPrimOp res ReadByteArrayOp_Word32     args = doIndexByteArrayOp (Just mo_u_32ToWord) b32  res args
 369 emitPrimOp res ReadByteArrayOp_Word64     args = doIndexByteArrayOp Nothing b64  res args
 370
 371 -- WriteXXXoffAddr
 372
 373 emitPrimOp res WriteOffAddrOp_Char       args = doWriteOffAddrOp (Just mo_WordTo8)  res args
 374 emitPrimOp res WriteOffAddrOp_WideChar   args = doWriteOffAddrOp (Just mo_WordTo32) res args
 375 emitPrimOp res WriteOffAddrOp_Int        args = doWriteOffAddrOp Nothing res args
 376 emitPrimOp res WriteOffAddrOp_Word       args = doWriteOffAddrOp Nothing res args
 377 emitPrimOp res WriteOffAddrOp_Addr       args = doWriteOffAddrOp Nothing res args
 378 emitPrimOp res WriteOffAddrOp_Float      args = doWriteOffAddrOp Nothing res args
 379 emitPrimOp res WriteOffAddrOp_Double     args = doWriteOffAddrOp Nothing res args
 380 emitPrimOp res WriteOffAddrOp_StablePtr  args = doWriteOffAddrOp Nothing res args
 381 emitPrimOp res WriteOffAddrOp_Int8       args = doWriteOffAddrOp (Just mo_WordTo8)  res args
 382 emitPrimOp res WriteOffAddrOp_Int16      args = doWriteOffAddrOp (Just mo_WordTo16) res args
 383 emitPrimOp res WriteOffAddrOp_Int32      args = doWriteOffAddrOp (Just mo_WordTo32) res args
 384 emitPrimOp res WriteOffAddrOp_Int64      args = doWriteOffAddrOp Nothing res args
 385 emitPrimOp res WriteOffAddrOp_Word8      args = doWriteOffAddrOp (Just mo_WordTo8)  res args
 386 emitPrimOp res WriteOffAddrOp_Word16     args = doWriteOffAddrOp (Just mo_WordTo16) res args
 387 emitPrimOp res WriteOffAddrOp_Word32     args = doWriteOffAddrOp (Just mo_WordTo32) res args
 388 emitPrimOp res WriteOffAddrOp_Word64     args = doWriteOffAddrOp Nothing res args
 389
 390 -- WriteXXXArray
 391
 392 emitPrimOp res WriteByteArrayOp_Char      args = doWriteByteArrayOp (Just mo_WordTo8)  res args
 393 emitPrimOp res WriteByteArrayOp_WideChar  args = doWriteByteArrayOp (Just mo_WordTo32) res args
 394 emitPrimOp res WriteByteArrayOp_Int       args = doWriteByteArrayOp Nothing res args
 395 emitPrimOp res WriteByteArrayOp_Word      args = doWriteByteArrayOp Nothing res args
 396 emitPrimOp res WriteByteArrayOp_Addr      args = doWriteByteArrayOp Nothing res args
 397 emitPrimOp res WriteByteArrayOp_Float     args = doWriteByteArrayOp Nothing res args
 398 emitPrimOp res WriteByteArrayOp_Double    args = doWriteByteArrayOp Nothing res args
 399 emitPrimOp res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
 400 emitPrimOp res WriteByteArrayOp_Int8      args = doWriteByteArrayOp (Just mo_WordTo8)  res args
 401 emitPrimOp res WriteByteArrayOp_Int16     args = doWriteByteArrayOp (Just mo_WordTo16) res args
 402 emitPrimOp res WriteByteArrayOp_Int32     args = doWriteByteArrayOp (Just mo_WordTo32) res args
 403 emitPrimOp res WriteByteArrayOp_Int64     args = doWriteByteArrayOp Nothing  res args
 404 emitPrimOp res WriteByteArrayOp_Word8     args = doWriteByteArrayOp (Just mo_WordTo8)  res args
 405 emitPrimOp res WriteByteArrayOp_Word16    args = doWriteByteArrayOp (Just mo_WordTo16) res args
 406 emitPrimOp res WriteByteArrayOp_Word32    args = doWriteByteArrayOp (Just mo_WordTo32) res args
 407 emitPrimOp res WriteByteArrayOp_Word64    args = doWriteByteArrayOp Nothing res args
 408
 409
 410 -- The rest just translate straightforwardly
 411 emitPrimOp [res] op [arg]
 412    | nopOp op
 413    = emit (mkAssign (CmmLocal res) arg)
 414
 415    | Just (mop,rep) <- narrowOp op
 416    = emit (mkAssign (CmmLocal res) $
 417            CmmMachOp (mop rep wordWidth) [CmmMachOp (mop wordWidth rep) [arg]])
 418
 419 emitPrimOp r@[res] op args
 420    | Just prim <- callishOp op
 421    = do emitPrimCall r prim args
 422
 423    | Just mop <- translateOp op
 424    = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
 425      emit stmt
 426
 427 emitPrimOp _ op _
 428  = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
 429
 430
 431 -- These PrimOps are NOPs in Cmm
 432
 433 nopOp :: PrimOp -> Bool
 434 nopOp Int2WordOp     = True
 435 nopOp Word2IntOp     = True
 436 nopOp Int2AddrOp     = True
 437 nopOp Addr2IntOp     = True
 438 nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
 439 nopOp OrdOp          = True
 440 nopOp _              = False
 441
 442 -- These PrimOps turn into double casts
 443
 444 narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
 445 narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
 446 narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
 447 narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
 448 narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
 449 narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
 450 narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
 451 narrowOp _              = Nothing
 452
 453 -- Native word signless ops
 454
 455 translateOp :: PrimOp -> Maybe MachOp
 456 translateOp IntAddOp       = Just mo_wordAdd
 457 translateOp IntSubOp       = Just mo_wordSub
 458 translateOp WordAddOp      = Just mo_wordAdd
 459 translateOp WordSubOp      = Just mo_wordSub
 460 translateOp AddrAddOp      = Just mo_wordAdd
 461 translateOp AddrSubOp      = Just mo_wordSub
 462
 463 translateOp IntEqOp        = Just mo_wordEq
 464 translateOp IntNeOp        = Just mo_wordNe
 465 translateOp WordEqOp       = Just mo_wordEq
 466 translateOp WordNeOp       = Just mo_wordNe
 467 translateOp AddrEqOp       = Just mo_wordEq
 468 translateOp AddrNeOp       = Just mo_wordNe
 469
 470 translateOp AndOp          = Just mo_wordAnd
 471 translateOp OrOp           = Just mo_wordOr
 472 translateOp XorOp          = Just mo_wordXor
 473 translateOp NotOp          = Just mo_wordNot
 474 translateOp SllOp          = Just mo_wordShl
 475 translateOp SrlOp          = Just mo_wordUShr
 476
 477 translateOp AddrRemOp      = Just mo_wordURem
 478
 479 -- Native word signed ops
 480
 481 translateOp IntMulOp        = Just mo_wordMul
 482 translateOp IntMulMayOfloOp = Just (MO_S_MulMayOflo wordWidth)
 483 translateOp IntQuotOp       = Just mo_wordSQuot
 484 translateOp IntRemOp        = Just mo_wordSRem
 485 translateOp IntNegOp        = Just mo_wordSNeg
 486
 487
 488 translateOp IntGeOp        = Just mo_wordSGe
 489 translateOp IntLeOp        = Just mo_wordSLe
 490 translateOp IntGtOp        = Just mo_wordSGt
 491 translateOp IntLtOp        = Just mo_wordSLt
 492
 493 translateOp ISllOp         = Just mo_wordShl
 494 translateOp ISraOp         = Just mo_wordSShr
 495 translateOp ISrlOp         = Just mo_wordUShr
 496
 497 -- Native word unsigned ops
 498
 499 translateOp WordGeOp       = Just mo_wordUGe
 500 translateOp WordLeOp       = Just mo_wordULe
 501 translateOp WordGtOp       = Just mo_wordUGt
 502 translateOp WordLtOp       = Just mo_wordULt
 503
 504 translateOp WordMulOp      = Just mo_wordMul
 505 translateOp WordQuotOp     = Just mo_wordUQuot
 506 translateOp WordRemOp      = Just mo_wordURem
 507
 508 translateOp AddrGeOp       = Just mo_wordUGe
 509 translateOp AddrLeOp       = Just mo_wordULe
 510 translateOp AddrGtOp       = Just mo_wordUGt
 511 translateOp AddrLtOp       = Just mo_wordULt
 512
 513 -- Char# ops
 514
 515 translateOp CharEqOp       = Just (MO_Eq wordWidth)
 516 translateOp CharNeOp       = Just (MO_Ne wordWidth)
 517 translateOp CharGeOp       = Just (MO_U_Ge wordWidth)
 518 translateOp CharLeOp       = Just (MO_U_Le wordWidth)
 519 translateOp CharGtOp       = Just (MO_U_Gt wordWidth)
 520 translateOp CharLtOp       = Just (MO_U_Lt wordWidth)
 521
 522 -- Double ops
 523
 524 translateOp DoubleEqOp     = Just (MO_F_Eq W64)
 525 translateOp DoubleNeOp     = Just (MO_F_Ne W64)
 526 translateOp DoubleGeOp     = Just (MO_F_Ge W64)
 527 translateOp DoubleLeOp     = Just (MO_F_Le W64)
 528 translateOp DoubleGtOp     = Just (MO_F_Gt W64)
 529 translateOp DoubleLtOp     = Just (MO_F_Lt W64)
 530
 531 translateOp DoubleAddOp    = Just (MO_F_Add W64)
 532 translateOp DoubleSubOp    = Just (MO_F_Sub W64)
 533 translateOp DoubleMulOp    = Just (MO_F_Mul W64)
 534 translateOp DoubleDivOp    = Just (MO_F_Quot W64)
 535 translateOp DoubleNegOp    = Just (MO_F_Neg W64)
 536
 537 -- Float ops
 538
 539 translateOp FloatEqOp     = Just (MO_F_Eq W32)
 540 translateOp FloatNeOp     = Just (MO_F_Ne W32)
 541 translateOp FloatGeOp     = Just (MO_F_Ge W32)
 542 translateOp FloatLeOp     = Just (MO_F_Le W32)
 543 translateOp FloatGtOp     = Just (MO_F_Gt W32)
 544 translateOp FloatLtOp     = Just (MO_F_Lt W32)
 545
 546 translateOp FloatAddOp    = Just (MO_F_Add  W32)
 547 translateOp FloatSubOp    = Just (MO_F_Sub  W32)
 548 translateOp FloatMulOp    = Just (MO_F_Mul  W32)
 549 translateOp FloatDivOp    = Just (MO_F_Quot W32)
 550 translateOp FloatNegOp    = Just (MO_F_Neg  W32)
 551
 552 -- Conversions
 553
 554 translateOp Int2DoubleOp   = Just (MO_SF_Conv wordWidth W64)
 555 translateOp Double2IntOp   = Just (MO_FS_Conv W64 wordWidth)
 556
 557 translateOp Int2FloatOp    = Just (MO_SF_Conv wordWidth W32)
 558 translateOp Float2IntOp    = Just (MO_FS_Conv W32 wordWidth)
 559
 560 translateOp Float2DoubleOp = Just (MO_FF_Conv W32 W64)
 561 translateOp Double2FloatOp = Just (MO_FF_Conv W64 W32)
 562
 563 -- Word comparisons masquerading as more exotic things.
 564
 565 translateOp SameMutVarOp           = Just mo_wordEq
 566 translateOp SameMVarOp             = Just mo_wordEq
 567 translateOp SameMutableArrayOp     = Just mo_wordEq
 568 translateOp SameMutableByteArrayOp = Just mo_wordEq
 569 translateOp SameTVarOp             = Just mo_wordEq
 570 translateOp EqStablePtrOp          = Just mo_wordEq
 571
 572 translateOp _ = Nothing
 573
 574 -- These primops are implemented by CallishMachOps, because they sometimes
 575 -- turn into foreign calls depending on the backend.
 576
 577 callishOp :: PrimOp -> Maybe CallishMachOp
 578 callishOp DoublePowerOp  = Just MO_F64_Pwr
 579 callishOp DoubleSinOp    = Just MO_F64_Sin
 580 callishOp DoubleCosOp    = Just MO_F64_Cos
 581 callishOp DoubleTanOp    = Just MO_F64_Tan
 582 callishOp DoubleSinhOp   = Just MO_F64_Sinh
 583 callishOp DoubleCoshOp   = Just MO_F64_Cosh
 584 callishOp DoubleTanhOp   = Just MO_F64_Tanh
 585 callishOp DoubleAsinOp   = Just MO_F64_Asin
 586 callishOp DoubleAcosOp   = Just MO_F64_Acos
 587 callishOp DoubleAtanOp   = Just MO_F64_Atan
 588 callishOp DoubleLogOp    = Just MO_F64_Log
 589 callishOp DoubleExpOp    = Just MO_F64_Exp
 590 callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
 591
 592 callishOp FloatPowerOp  = Just MO_F32_Pwr
 593 callishOp FloatSinOp    = Just MO_F32_Sin
 594 callishOp FloatCosOp    = Just MO_F32_Cos
 595 callishOp FloatTanOp    = Just MO_F32_Tan
 596 callishOp FloatSinhOp   = Just MO_F32_Sinh
 597 callishOp FloatCoshOp   = Just MO_F32_Cosh
 598 callishOp FloatTanhOp   = Just MO_F32_Tanh
 599 callishOp FloatAsinOp   = Just MO_F32_Asin
 600 callishOp FloatAcosOp   = Just MO_F32_Acos
 601 callishOp FloatAtanOp   = Just MO_F32_Atan
 602 callishOp FloatLogOp    = Just MO_F32_Log
 603 callishOp FloatExpOp    = Just MO_F32_Exp
 604 callishOp FloatSqrtOp   = Just MO_F32_Sqrt
 605
 606 callishOp _ = Nothing
 607
 608 ------------------------------------------------------------------------------
 609 -- Helpers for translating various minor variants of array indexing.
 610
 611 doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
 612 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
 613    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
 614 doIndexOffAddrOp _ _ _ _
 615    = panic "CgPrimOp: doIndexOffAddrOp"
 616
 617 doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
 618 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
 619    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
 620 doIndexByteArrayOp _ _ _ _
 621    = panic "CgPrimOp: doIndexByteArrayOp"
 622
 623 doReadPtrArrayOp ::  LocalReg -> CmmExpr -> CmmExpr -> FCode ()
 624 doReadPtrArrayOp res addr idx
 625    = mkBasicIndexedRead arrPtrsHdrSize Nothing gcWord res addr idx
 626
 627
 628 doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
 629 doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val]
 630    = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val
 631 doWriteOffAddrOp _ _ _
 632    = panic "CgPrimOp: doWriteOffAddrOp"
 633
 634 doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
 635 doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
 636    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast addr idx val
 637 doWriteByteArrayOp _ _ _
 638    = panic "CgPrimOp: doWriteByteArrayOp"
 639
 640 doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 641 doWritePtrArrayOp addr idx val
 642   = do mkBasicIndexedWrite arrPtrsHdrSize Nothing addr idx val
 643        emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 644   -- the write barrier.  We must write a byte into the mark table:
 645   -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
 646        emit $ mkStore (
 647          cmmOffsetExpr
 648           (cmmOffsetExprW (cmmOffsetB addr arrPtrsHdrSize)
 649                          (loadArrPtrsSize addr))
 650           (CmmMachOp mo_wordUShr [idx,
 651                                   CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
 652          ) (CmmLit (CmmInt 1 W8))
 653
 654 loadArrPtrsSize :: CmmExpr -> CmmExpr
 655 loadArrPtrsSize addr = CmmLoad (cmmOffsetB addr off) bWord
 656  where off = fixedHdrSize*wORD_SIZE + oFFSET_StgMutArrPtrs_ptrs
 657
 658 mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
 659                    -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
 660 mkBasicIndexedRead off Nothing read_rep res base idx
 661    = emit (mkAssign (CmmLocal res) (cmmLoadIndexOffExpr off read_rep base idx))
 662 mkBasicIndexedRead off (Just cast) read_rep res base idx
 663    = emit (mkAssign (CmmLocal res) (CmmMachOp cast [
 664                                 cmmLoadIndexOffExpr off read_rep base idx]))
 665
 666 mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
 667                    -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 668 mkBasicIndexedWrite off Nothing base idx val
 669    = emit (mkStore (cmmIndexOffExpr off (typeWidth (cmmExprType val)) base idx) val)
 670 mkBasicIndexedWrite off (Just cast) base idx val
 671    = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])
 672
 673 -- ----------------------------------------------------------------------------
 674 -- Misc utils
 675
 676 cmmIndexOffExpr :: ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr
 677 cmmIndexOffExpr off width base idx
 678    = cmmIndexExpr width (cmmOffsetB base off) idx
 679
 680 cmmLoadIndexOffExpr :: ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
 681 cmmLoadIndexOffExpr off ty base idx
 682    = CmmLoad (cmmIndexOffExpr off (typeWidth ty) base idx) ty
 683
 684 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
 685 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
 686