ghc/compiler/absCSyn/AbsCUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
   3 %
   4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
   5
   6 \begin{code}
   7 module AbsCUtils (
   8         nonemptyAbsC,
   9         mkAbstractCs, mkAbsCStmts,
  10         mkAlgAltsCSwitch,
  11         magicIdPrimRep,
  12         getAmodeRep,
  13         mixedTypeLocn, mixedPtrLocn,
  14         flattenAbsC,
  15         mkAbsCStmtList,
  16         shimFCallArg
  17         -- printing/forcing stuff comes from PprAbsC
  18     ) where
  19
  20 #include "HsVersions.h"
  21 #include "../includes/config.h"
  22
  23 import AbsCSyn
  24 import Type             ( tyConAppTyCon, repType )
  25 import TysPrim          ( foreignObjPrimTyCon, arrayPrimTyCon,
  26                           byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
  27                           mutableArrayPrimTyCon )
  28 import CLabel           ( mkMAP_FROZEN_infoLabel )
  29 import Digraph          ( stronglyConnComp, SCC(..) )
  30 import DataCon          ( fIRST_TAG, dataConTag )
  31 import Literal          ( literalPrimRep, mkMachWord, mkMachInt )
  32 import PrimRep          ( getPrimRepSize, PrimRep(..) )
  33 import PrimOp           ( PrimOp(..) )
  34 import MachOp           ( MachOp(..), isDefinitelyInlineMachOp )
  35 import Unique           ( Unique{-instance Eq-} )
  36 import UniqSupply       ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
  37                           UniqSupply )
  38 import CmdLineOpts      ( opt_EmitCExternDecls, opt_Unregisterised )
  39 import ForeignCall      ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
  40 import StgSyn           ( StgOp(..), stgArgType )
  41 import CoreSyn          ( AltCon(..) )
  42 import SMRep            ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
  43 import Outputable
  44 import Panic            ( panic )
  45 import FastTypes
  46 import Constants        ( wORD_SIZE, wORD_SIZE_IN_BITS )
  47
  48 infixr 9 `thenFlt`
  49 \end{code}
  50
  51 Check if there is any real code in some Abstract~C.  If so, return it
  52 (@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
  53
  54 It returns the "reduced" code in the Just part so that the work of
  55 discarding AbsCNops isn't lost, and so that if the caller uses
  56 the reduced version there's less danger of a big tree of AbsCNops getting
  57 materialised and causing a space leak.
  58
  59 \begin{code}
  60 nonemptyAbsC :: AbstractC -> Maybe AbstractC
  61 nonemptyAbsC  AbsCNop           = Nothing
  62 nonemptyAbsC (AbsCStmts s1 s2)  = case (nonemptyAbsC s1) of
  63                                     Nothing -> nonemptyAbsC s2
  64                                     Just x  -> Just (AbsCStmts x s2)
  65 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
  66                                     Nothing -> Nothing
  67                                     Just x  -> Just s
  68 nonemptyAbsC other              = Just other
  69 \end{code}
  70
  71 \begin{code}
  72 mkAbstractCs :: [AbstractC] -> AbstractC
  73 mkAbstractCs [] = AbsCNop
  74 mkAbstractCs cs = foldr1 mkAbsCStmts cs
  75
  76 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
  77 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
  78 mkAbsCStmts AbsCNop c = c
  79 mkAbsCStmts c AbsCNop = c
  80 mkAbsCStmts c1 c2     = c1 `AbsCStmts` c2
  81
  82 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
  83   = case (case (nonemptyAbsC abc2) of
  84             Nothing -> AbsCNop
  85             Just d2 -> d2)      of { abc2b ->
  86
  87     case (nonemptyAbsC abc1) of {
  88       Nothing -> abc2b;
  89       Just d1 -> AbsCStmts d1 abc2b
  90     } }
  91 -}
  92 \end{code}
  93
  94 Get the sho' 'nuff statements out of an @AbstractC@.
  95 \begin{code}
  96 mkAbsCStmtList :: AbstractC -> [AbstractC]
  97
  98 mkAbsCStmtList absC = mkAbsCStmtList' absC []
  99
 100 -- Optimised a la foldr/build!
 101
 102 mkAbsCStmtList'  AbsCNop r = r
 103
 104 mkAbsCStmtList' (AbsCStmts s1 s2) r
 105   = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
 106
 107 mkAbsCStmtList' s@(CSimultaneous c) r
 108   = if null (mkAbsCStmtList c) then r else s : r
 109
 110 mkAbsCStmtList' other r = other : r
 111 \end{code}
 112
 113 \begin{code}
 114 mkAlgAltsCSwitch :: CAddrMode -> [(AltCon, AbstractC)] -> AbstractC
 115
 116 mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
 117  = CSwitch scrutinee (adjust rest_alts) first_alt
 118  where
 119    -- We use the first alt as the default.  Either it *is* the DEFAULT,
 120    -- (which is always first if present), or the case is exhaustive,
 121    -- in which case we can use the first as the default anyway
 122
 123    -- Adjust the tags in the switch to start at zero.
 124    -- This is the convention used by primitive ops which return algebraic
 125    -- data types.  Why?  Because for two-constructor types, zero is faster
 126    -- to create and distinguish from 1 than are 1 and 2.
 127
 128    -- We also need to convert to Literals to keep the CSwitch happy
 129    adjust tagged_alts
 130      = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
 131        | (DataAlt dc, abs_c) <- tagged_alts ]
 132 \end{code}
 133
 134 %************************************************************************
 135 %*                                                                      *
 136 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
 137 %*                                                                      *
 138 %************************************************************************
 139
 140 \begin{code}
 141 magicIdPrimRep BaseReg              = PtrRep
 142 magicIdPrimRep (VanillaReg kind _) = kind
 143 magicIdPrimRep (FloatReg _)         = FloatRep
 144 magicIdPrimRep (DoubleReg _)        = DoubleRep
 145 magicIdPrimRep (LongReg kind _)     = kind
 146 magicIdPrimRep Sp                   = PtrRep
 147 magicIdPrimRep SpLim                = PtrRep
 148 magicIdPrimRep Hp                   = PtrRep
 149 magicIdPrimRep HpLim                = PtrRep
 150 magicIdPrimRep CurCostCentre        = CostCentreRep
 151 magicIdPrimRep VoidReg              = VoidRep
 152 magicIdPrimRep CurrentTSO           = PtrRep
 153 magicIdPrimRep CurrentNursery       = PtrRep
 154 magicIdPrimRep HpAlloc              = WordRep
 155 \end{code}
 156
 157 %************************************************************************
 158 %*                                                                      *
 159 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
 160 %*                                                                      *
 161 %************************************************************************
 162
 163 See also the return conventions for unboxed things; currently living
 164 in @CgCon@ (next to the constructor return conventions).
 165
 166 ToDo: tiny tweaking may be in order
 167 \begin{code}
 168 getAmodeRep :: CAddrMode -> PrimRep
 169
 170 getAmodeRep (CVal _ kind)                   = kind
 171 getAmodeRep (CAddr _)                       = PtrRep
 172 getAmodeRep (CReg magic_id)                 = magicIdPrimRep magic_id
 173 getAmodeRep (CTemp uniq kind)               = kind
 174 getAmodeRep (CLbl _ kind)                   = kind
 175 getAmodeRep (CCharLike _)                   = PtrRep
 176 getAmodeRep (CIntLike _)                    = PtrRep
 177 getAmodeRep (CLit lit)                      = literalPrimRep lit
 178 getAmodeRep (CMacroExpr kind _ _)           = kind
 179 getAmodeRep (CJoinPoint _)                  = panic "getAmodeRep:CJoinPoint"
 180 \end{code}
 181
 182 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
 183 location; that is, one which can contain values of various types.
 184
 185 \begin{code}
 186 mixedTypeLocn :: CAddrMode -> Bool
 187
 188 mixedTypeLocn (CVal (NodeRel _) _)      = True
 189 mixedTypeLocn (CVal (SpRel _)   _)      = True
 190 mixedTypeLocn (CVal (HpRel _)   _)      = True
 191 mixedTypeLocn other                     = False -- All the rest
 192 \end{code}
 193
 194 @mixedPtrLocn@ tells whether an amode identifies a
 195 location which can contain values of various pointer types.
 196
 197 \begin{code}
 198 mixedPtrLocn :: CAddrMode -> Bool
 199
 200 mixedPtrLocn (CVal (SpRel _)  _)        = True
 201 mixedPtrLocn other                      = False -- All the rest
 202 \end{code}
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 The following bits take ``raw'' Abstract~C, which may have all sorts of
 211 nesting, and flattens it into one long @AbsCStmtList@.  Mainly,
 212 @CClosureInfos@ and code for switches are pulled out to the top level.
 213
 214 The various functions herein tend to produce
 215 \begin{enumerate}
 216 \item
 217 A {\em flattened} \tr{<something>} of interest for ``here'', and
 218 \item
 219 Some {\em unflattened} Abstract~C statements to be carried up to the
 220 top-level.  The only real reason (now) that it is unflattened is
 221 because it means the recursive flattening can be done in just one
 222 place rather than having to remember lots of places.
 223 \end{enumerate}
 224
 225 Care is taken to reduce the occurrence of forward references, while still
 226 keeping laziness a much as possible.  Essentially, this means that:
 227 \begin{itemize}
 228 \item
 229 {\em All} the top-level C statements resulting from flattening a
 230 particular AbsC statement (whether the latter is nested or not) appear
 231 before {\em any} of the code for a subsequent AbsC statement;
 232 \item
 233 but stuff nested within any AbsC statement comes
 234 out before the code for the statement itself.
 235 \end{itemize}
 236
 237 The ``stuff to be carried up'' always includes a label: a
 238 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
 239 @CCodeBlock@.  The latter turns into a C function, and is never
 240 actually produced by the code generator.  Rather it always starts life
 241 as a @CCodeBlock@ addressing mode; when such an addr mode is
 242 flattened, the ``tops'' stuff is a @CCodeBlock@.
 243
 244 \begin{code}
 245 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
 246
 247 flattenAbsC us abs_C
 248   = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
 249     here `mkAbsCStmts` tops }
 250 \end{code}
 251
 252 %************************************************************************
 253 %*                                                                      *
 254 \subsubsection{Flattening monadery}
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 The flattener is monadised.  It's just a @UniqueSupply@.
 259
 260 \begin{code}
 261 type FlatM result =  UniqSupply -> result
 262
 263 initFlt :: UniqSupply -> FlatM a -> a
 264
 265 initFlt init_us m = m init_us
 266
 267 {-# INLINE thenFlt #-}
 268 {-# INLINE returnFlt #-}
 269
 270 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
 271
 272 thenFlt expr cont us
 273   = case (splitUniqSupply us)   of { (s1, s2) ->
 274     case (expr s1)              of { result ->
 275     cont result s2 }}
 276
 277 returnFlt :: a -> FlatM a
 278 returnFlt result us = result
 279
 280 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
 281
 282 mapFlt f []     = returnFlt []
 283 mapFlt f (x:xs)
 284   = f x         `thenFlt` \ r  ->
 285     mapFlt f xs `thenFlt` \ rs ->
 286     returnFlt (r:rs)
 287
 288 mapAndUnzipFlt  :: (a -> FlatM (b,c))   -> [a] -> FlatM ([b],[c])
 289
 290 mapAndUnzipFlt f [] = returnFlt ([],[])
 291 mapAndUnzipFlt f (x:xs)
 292   = f x                 `thenFlt` \ (r1,  r2)  ->
 293     mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
 294     returnFlt (r1:rs1, r2:rs2)
 295
 296 getUniqFlt :: FlatM Unique
 297 getUniqFlt us = uniqFromSupply us
 298
 299 getUniqsFlt :: FlatM [Unique]
 300 getUniqsFlt us = uniqsFromSupply us
 301 \end{code}
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsubsection{Flattening the top level}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 \begin{code}
 310 flatAbsC :: AbstractC
 311          -> FlatM (AbstractC,   -- Stuff to put inline          [Both are fully
 312                    AbstractC)   -- Stuff to put at top level     flattened]
 313
 314 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
 315
 316 flatAbsC (AbsCStmts s1 s2)
 317   = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
 318     flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
 319     returnFlt (mkAbsCStmts inline_s1 inline_s2,
 320                mkAbsCStmts top_s1    top_s2)
 321
 322 flatAbsC (CClosureInfoAndCode cl_info entry)
 323   = flatAbsC entry              `thenFlt` \ (entry_heres, entry_tops) ->
 324     returnFlt (AbsCNop, mkAbstractCs [entry_tops,
 325        CClosureInfoAndCode cl_info entry_heres]
 326     )
 327
 328 flatAbsC (CCodeBlock lbl abs_C)
 329   = flatAbsC abs_C          `thenFlt` \ (absC_heres, absC_tops) ->
 330     returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
 331
 332 flatAbsC (CRetDirect uniq slow_code srt liveness)
 333   = flatAbsC slow_code          `thenFlt` \ (heres, tops) ->
 334     returnFlt (AbsCNop,
 335                 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
 336
 337 flatAbsC (CSwitch discrim alts deflt)
 338   = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
 339     flatAbsC deflt               `thenFlt` \ (flat_def_alt, def_tops) ->
 340     returnFlt (
 341       CSwitch discrim flat_alts flat_def_alt,
 342       mkAbstractCs (def_tops : flat_alts_tops)
 343     )
 344   where
 345     flat_alt (tag, absC)
 346       = flatAbsC absC   `thenFlt` \ (alt_heres, alt_tops) ->
 347         returnFlt ( (tag, alt_heres), alt_tops )
 348
 349 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
 350   |  is_dynamic                -- Emit a typedef if its a dynamic call
 351      || (opt_EmitCExternDecls) -- or we want extern decls
 352   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
 353   where
 354     is_dynamic = isDynamicTarget target
 355
 356 flatAbsC stmt@(CSimultaneous abs_c)
 357   = flatAbsC abs_c              `thenFlt` \ (stmts_here, tops) ->
 358     doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
 359     returnFlt (new_stmts_here, tops)
 360
 361 flatAbsC stmt@(CCheck macro amodes code)
 362   = flatAbsC code               `thenFlt` \ (code_here, code_tops) ->
 363     returnFlt (CCheck macro amodes code_here, code_tops)
 364
 365 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
 366 -- This is a HACK.
 367 flatAbsC stmt@(CCallProfCtrMacro str amodes)
 368   | str == FSLIT("TICK_CTR")    = returnFlt (AbsCNop, stmt)
 369   | otherwise                   = returnFlt (stmt, AbsCNop)
 370
 371 -- Some statements need no flattening at all:
 372 flatAbsC stmt@(CMacroStmt macro amodes)          = returnFlt (stmt, AbsCNop)
 373 flatAbsC stmt@(CCallProfCCMacro str amodes)      = returnFlt (stmt, AbsCNop)
 374 flatAbsC stmt@(CAssign dest source)              = returnFlt (stmt, AbsCNop)
 375 flatAbsC stmt@(CJump target)                     = returnFlt (stmt, AbsCNop)
 376 flatAbsC stmt@(CFallThrough target)              = returnFlt (stmt, AbsCNop)
 377 flatAbsC stmt@(CReturn target return_info)       = returnFlt (stmt, AbsCNop)
 378 flatAbsC stmt@(CInitHdr a b cc sz)               = returnFlt (stmt, AbsCNop)
 379 flatAbsC stmt@(CMachOpStmt res mop args m_vols)  = returnFlt (stmt, AbsCNop)
 380 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
 381                                                  = returnFlt (stmt, AbsCNop)
 382 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
 383    = dscCOpStmt (filter non_void_amode results) op
 384                 (filter non_void_amode args) vol_regs
 385                                 `thenFlt` \ simpl ->
 386      case simpl of
 387         COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt"   -- make sure we don't loop!
 388         other           -> flatAbsC other
 389      {-
 390         A gruesome hack for printing the names of inline primops when they
 391         are used.
 392                                   oink other
 393      where
 394         oink xxx
 395             = getUniqFlt `thenFlt` \ uu ->
 396               flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
 397
 398         moo uu op_str
 399            = COpStmt
 400                 []
 401                 (StgFCallOp
 402                     (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
 403                                       defaultCCallConv (PlaySafe False)))
 404                     uu
 405                 )
 406                 [CReg VoidReg]
 407                 []
 408         mktxt op_str
 409             = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
 410      -}
 411
 412 flatAbsC (CSequential abcs)
 413   = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
 414     returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
 415
 416
 417 -- Some statements only make sense at the top level, so we always float
 418 -- them.  This probably isn't necessary.
 419 flatAbsC stmt@(CStaticClosure _ _ _ _)          = returnFlt (AbsCNop, stmt)
 420 flatAbsC stmt@(CClosureTbl _)                   = returnFlt (AbsCNop, stmt)
 421 flatAbsC stmt@(CSRT _ _)                        = returnFlt (AbsCNop, stmt)
 422 flatAbsC stmt@(CSRTDesc _ _ _ _ _)              = returnFlt (AbsCNop, stmt)
 423 flatAbsC stmt@(CBitmap _)                       = returnFlt (AbsCNop, stmt)
 424 flatAbsC stmt@(CCostCentreDecl _ _)             = returnFlt (AbsCNop, stmt)
 425 flatAbsC stmt@(CCostCentreStackDecl _)          = returnFlt (AbsCNop, stmt)
 426 flatAbsC stmt@(CSplitMarker)                    = returnFlt (AbsCNop, stmt)
 427 flatAbsC stmt@(CRetVector _ _ _ _)              = returnFlt (AbsCNop, stmt)
 428 flatAbsC stmt@(CModuleInitBlock _ _ _)          = returnFlt (AbsCNop, stmt)
 429 \end{code}
 430
 431 %************************************************************************
 432 %*                                                                      *
 433 \subsection[flat-simultaneous]{Doing things simultaneously}
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 \begin{code}
 438 doSimultaneously :: AbstractC -> FlatM AbstractC
 439 \end{code}
 440
 441 Generate code to perform the @CAssign@s and @COpStmt@s in the
 442 input simultaneously, using temporary variables when necessary.
 443
 444 We use the strongly-connected component algorithm, in which
 445         * the vertices are the statements
 446         * an edge goes from s1 to s2 iff
 447                 s1 assigns to something s2 uses
 448           that is, if s1 should *follow* s2 in the final order
 449
 450 \begin{code}
 451 type CVertex = (Int, AbstractC)  -- Give each vertex a unique number,
 452                                  -- for fast comparison
 453
 454 doSimultaneously abs_c
 455   = let
 456         enlisted = en_list abs_c
 457     in
 458     case enlisted of -- it's often just one stmt
 459       []  -> returnFlt AbsCNop
 460       [x] -> returnFlt x
 461       _   -> doSimultaneously1 (zip [(1::Int)..] enlisted)
 462
 463 -- en_list puts all the assignments in a list, filtering out Nops and
 464 -- assignments which do nothing
 465 en_list AbsCNop                               = []
 466 en_list (AbsCStmts a1 a2)                     = en_list a1 ++ en_list a2
 467 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
 468 en_list other                                 = [other]
 469
 470 sameAmode :: CAddrMode -> CAddrMode -> Bool
 471 -- ToDo: Move this function, or make CAddrMode an instance of Eq
 472 -- At the moment we put in just enough to catch the cases we want:
 473 --      the second (destination) argument is always a CVal.
 474 sameAmode (CReg r1)                  (CReg r2)               = r1 == r2
 475 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _)            = r1 ==# r2
 476 sameAmode other1                     other2                  = False
 477
 478 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
 479 doSimultaneously1 vertices
 480   = let
 481         edges = [ (vertex, key1, edges_from stmt1)
 482                 | vertex@(key1, stmt1) <- vertices
 483                 ]
 484         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 485                                     stmt1 `should_follow` stmt2
 486                            ]
 487         components = stronglyConnComp edges
 488
 489         -- do_components deal with one strongly-connected component
 490                 -- Not cyclic, or singleton?  Just do it
 491         do_component (AcyclicSCC (n,abs_c))  = returnFlt abs_c
 492         do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
 493
 494                 -- Cyclic?  Then go via temporaries.  Pick one to
 495                 -- break the loop and try again with the rest.
 496         do_component (CyclicSCC ((n,first_stmt) : rest))
 497           = doSimultaneously1 rest      `thenFlt` \ abs_cs ->
 498             go_via_temps first_stmt     `thenFlt` \ (to_temps, from_temps) ->
 499             returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
 500
 501         go_via_temps (CAssign dest src)
 502           = getUniqFlt                  `thenFlt` \ uniq ->
 503             let
 504                 the_temp = CTemp uniq (getAmodeRep dest)
 505             in
 506             returnFlt (CAssign the_temp src, CAssign dest the_temp)
 507
 508         go_via_temps (COpStmt dests op srcs vol_regs)
 509           = getUniqsFlt                 `thenFlt` \ uniqs ->
 510             let
 511                 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
 512             in
 513             returnFlt (COpStmt the_temps op srcs vol_regs,
 514                        mkAbstractCs (zipWith CAssign dests the_temps))
 515     in
 516     mapFlt do_component components `thenFlt` \ abs_cs ->
 517     returnFlt (mkAbstractCs abs_cs)
 518
 519   where
 520     should_follow :: AbstractC -> AbstractC -> Bool
 521     (CAssign dest1 _) `should_follow` (CAssign _ src2)
 522       = dest1 `conflictsWith` src2
 523     (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
 524       = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
 525     (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
 526       = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
 527     (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
 528       = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
 529 \end{code}
 530
 531 @conflictsWith@ tells whether an assignment to its first argument will
 532 screw up an access to its second.
 533
 534 \begin{code}
 535 conflictsWith :: CAddrMode -> CAddrMode -> Bool
 536 (CReg reg1)        `conflictsWith` (CReg reg2)          = reg1 == reg2
 537 (CReg reg)         `conflictsWith` (CVal reg_rel _)     = reg `regConflictsWithRR` reg_rel
 538 (CReg reg)         `conflictsWith` (CAddr reg_rel)      = reg `regConflictsWithRR` reg_rel
 539 (CTemp u1 _)       `conflictsWith` (CTemp u2 _)         = u1 == u2
 540 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
 541   = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
 542
 543 other1            `conflictsWith` other2                = False
 544 -- CAddr and literals are impossible on the LHS of an assignment
 545
 546 regConflictsWithRR :: MagicId -> RegRelative -> Bool
 547
 548 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1)    = True
 549 regConflictsWithRR Sp   (SpRel _)       = True
 550 regConflictsWithRR Hp   (HpRel _)       = True
 551 regConflictsWithRR _    _               = False
 552
 553 rrConflictsWithRR :: Int -> Int                 -- Sizes of two things
 554                   -> RegRelative -> RegRelative -- The two amodes
 555                   -> Bool
 556
 557 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
 558   where
 559     s1 = iUnbox s1b
 560     s2 = iUnbox s2b
 561
 562     rr (SpRel o1)    (SpRel o2)
 563         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 564         | s1 ==# (_ILIT 1)  && s2 ==# (_ILIT 1) = o1 ==# o2
 565         | otherwise          = (o1 +# s1) >=# o2  &&
 566                                (o2 +# s2) >=# o1
 567
 568     rr (NodeRel o1)      (NodeRel o2)
 569         | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
 570         | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
 571         | otherwise          = True             -- Give up
 572
 573     rr (HpRel _)         (HpRel _)    = True    -- Give up (ToDo)
 574
 575     rr other1            other2       = False
 576 \end{code}
 577
 578 %************************************************************************
 579 %*                                                                      *
 580 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 \begin{code}
 585
 586 -- We begin with some helper functions.  The main Dude here is
 587 -- dscCOpStmt, defined a little further down.
 588
 589 ------------------------------------------------------------------------------
 590
 591 -- Assumes no volatiles
 592 -- Creates
 593 --     res = arg >> (bits-per-word / 2)   when little-endian
 594 -- or
 595 --     res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
 596 --
 597 -- In other words, if arg had been stored in memory, makes res the
 598 -- halfword of arg which would have had the higher address.  This is
 599 -- why it needs to take into account endianness.
 600 --
 601 mkHalfWord_HIADDR res arg
 602    = mkTemp WordRep                     `thenFlt` \ t_hw_mask1 ->
 603      mkTemp WordRep                     `thenFlt` \ t_hw_mask2 ->
 604      let
 605          hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
 606
 607 #        if WORDS_BIGENDIAN
 608          a_hw_mask1
 609             = CMachOpStmt t_hw_mask1
 610                           MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
 611          a_hw_mask2
 612             = CMachOpStmt t_hw_mask2
 613                           MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
 614          final
 615             = CSequential [ a_hw_mask1, a_hw_mask2,
 616                  CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
 617               ]
 618 #        else
 619          final = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
 620 #        endif
 621      in
 622          returnFlt final
 623
 624
 625 mkTemp :: PrimRep -> FlatM CAddrMode
 626 mkTemp rep
 627    = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
 628
 629 mkTemps = mapFlt mkTemp
 630
 631 -- Sigh.  This is done in 3 seperate places.  Should be
 632 -- commoned up (here, in pprAbsC of COpStmt, and presumably
 633 -- somewhere in the NCG).
 634 non_void_amode amode
 635    = case getAmodeRep amode of
 636         VoidRep -> False
 637         k       -> True
 638
 639 -- Helpers for translating various minor variants of array indexing.
 640
 641 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 642 mkDerefOff rep base off
 643    = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
 644
 645 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 646 mkNoDerefOff rep base off
 647    = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
 648
 649
 650 -- Generates an address as follows
 651 --    base + sizeof(machine_word)*offw + sizeof(rep)*idx
 652 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
 653 mk_OSBI_addr offw rep base idx
 654    = CIndex (CAddr (CIndex base idx rep))
 655             (CLit (mkMachWord (fromIntegral offw)))
 656             PtrRep
 657
 658 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
 659 mk_OSBI_ref offw rep base idx
 660    = CVal (mk_OSBI_addr offw rep base idx) rep
 661
 662
 663 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
 664    = mkBasicIndexedRead 0 maybe_post_read_cast rep res (mkDerefOff WordRep addr fixedHdrSize) idx
 665
 666 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
 667    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
 668
 669 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
 670    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
 671
 672 doReadPtrArrayOp res addr idx
 673    = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
 674
 675
 676 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
 677    = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
 678
 679 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
 680    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
 681
 682 doWritePtrArrayOp addr idx val
 683    = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
 684
 685
 686
 687 mkBasicIndexedRead offw Nothing read_rep res base idx
 688    = returnFlt (
 689         CAssign res (mk_OSBI_ref offw read_rep base idx)
 690      )
 691 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
 692    = mkTemp read_rep                    `thenFlt` \ tmp ->
 693      (returnFlt . CSequential) [
 694         CAssign tmp (mk_OSBI_ref offw read_rep base idx),
 695         CMachOpStmt res cast_to_mop [tmp] Nothing
 696      ]
 697
 698 mkBasicIndexedWrite offw Nothing write_rep base idx val
 699    = returnFlt (
 700         CAssign (mk_OSBI_ref offw write_rep base idx) val
 701      )
 702 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
 703    = mkTemp write_rep                   `thenFlt` \ tmp ->
 704      (returnFlt . CSequential) [
 705         CMachOpStmt tmp cast_to_mop [val] Nothing,
 706         CAssign (mk_OSBI_ref offw write_rep base idx) tmp
 707      ]
 708
 709
 710 -- Simple dyadic op but one for which we need to cast first arg to
 711 -- be sure of correctness
 712 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
 713    = mkTemp cast_arg1_to                `thenFlt` \ arg1casted ->
 714      (returnFlt . CSequential) [
 715         CAssign arg1casted arg1,
 716         CMachOpStmt res mop [arg1casted,arg2]
 717            (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 718      ]
 719
 720 -- IA64 mangler doesn't place tables next to code
 721 tablesNextToCode :: Bool
 722 #ifdef ia64_TARGET_ARCH
 723 tablesNextToCode = False
 724 #else
 725 tablesNextToCode = not opt_Unregisterised
 726 #endif
 727
 728 ------------------------------------------------------------------------------
 729
 730 -- This is the main top-level desugarer PrimOps into MachOps.  First we
 731 -- handle various awkward cases specially.  The remaining easy cases are
 732 -- then handled by translateOp, defined below.
 733
 734
 735 dscCOpStmt :: [CAddrMode]       -- Results
 736            -> PrimOp
 737            -> [CAddrMode]       -- Arguments
 738            -> [MagicId]         -- Potentially volatile/live registers
 739                                 -- (to save/restore around the op)
 740            -> FlatM AbstractC
 741
 742
 743 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
 744 {-
 745    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 746    C, and without needing any comparisons.  This may not be the
 747    fastest way to do it - if you have better code, please send it! --SDM
 748
 749    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 750
 751    We currently don't make use of the r value if c is != 0 (i.e.
 752    overflow), we just convert to big integers and try again.  This
 753    could be improved by making r and c the correct values for
 754    plugging into a new J#.
 755
 756    { r = ((I_)(a)) + ((I_)(b));                                 \
 757      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
 758          >> (BITS_IN (I_) - 1);                                 \
 759    }
 760    Wading through the mass of bracketry, it seems to reduce to:
 761    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
 762
 763    SSA-form:
 764    t1 = a^b
 765    t2 = ~t1
 766    t3 = a^r
 767    t4 = t2 & t3
 768    c  = t4 >>unsigned BITS_IN(I_)-1
 769 -}
 770    = mkTemps [IntRep,IntRep,IntRep,IntRep]      `thenFlt` \ [t1,t2,t3,t4] ->
 771      let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
 772      (returnFlt . CSequential) [
 773         CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
 774         CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
 775         CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
 776         CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
 777         CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
 778         CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing
 779      ]
 780
 781
 782 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
 783 {- Similarly:
 784    #define subIntCzh(r,c,a,b)                                   \
 785    { r = ((I_)(a)) - ((I_)(b));                                 \
 786      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
 787          >> (BITS_IN (I_) - 1);                                 \
 788    }
 789
 790    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
 791
 792    t1 = a^b
 793    t2 = a^r
 794    t3 = t1 & t2
 795    c  = t3 >>unsigned BITS_IN(I_)-1
 796 -}
 797    = mkTemps [IntRep,IntRep,IntRep]             `thenFlt` \ [t1,t2,t3] ->
 798      let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
 799      (returnFlt . CSequential) [
 800         CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
 801         CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
 802         CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
 803         CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
 804         CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing
 805      ]
 806
 807
 808 -- #define parzh(r,node) r = 1
 809 dscCOpStmt [res] ParOp [arg] vols
 810    = returnFlt
 811         (CAssign res (CLit (mkMachInt 1)))
 812
 813 -- #define readMutVarzh(r,a)     r=(P_)(((StgMutVar *)(a))->var)
 814 dscCOpStmt [res] ReadMutVarOp [mutv] vols
 815    = returnFlt
 816         (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
 817
 818 -- #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 819 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
 820    = returnFlt
 821         (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
 822
 823
 824 -- #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 825 -- #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 826 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
 827    = returnFlt
 828         (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
 829
 830 -- #define writeForeignObjzh(res,datum) \
 831 --    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 832 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
 833    = returnFlt
 834         (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
 835
 836
 837 -- #define sizzeofByteArrayzh(r,a) \
 838 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
 839 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 840    = mkTemp WordRep                     `thenFlt` \ w ->
 841      (returnFlt . CSequential) [
 842         CAssign w (mkDerefOff WordRep arg fixedHdrSize),
 843         CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols),
 844         CAssign res w
 845      ]
 846
 847 -- #define sizzeofMutableByteArrayzh(r,a) \
 848 --      r = (((StgArrWords *)(a))->words * sizeof(W_))
 849 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
 850    = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 851
 852
 853 -- #define touchzh(o)                  /* nothing */
 854 dscCOpStmt [] TouchOp [arg] vols
 855    = returnFlt AbsCNop
 856
 857 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 858 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
 859    = mkTemp PtrRep                      `thenFlt` \ ptr ->
 860      (returnFlt . CSequential) [
 861          CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
 862          CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
 863          CAssign res ptr
 864      ]
 865
 866 -- #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
 867 dscCOpStmt [res] StableNameToIntOp [arg] vols
 868    = returnFlt
 869         (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
 870
 871 -- #define eqStableNamezh(r,sn1,sn2)                                    \
 872 --    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
 873 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
 874    = mkTemps [WordRep, WordRep]         `thenFlt` \ [sn1,sn2] ->
 875      (returnFlt . CSequential) [
 876         CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
 877         CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
 878         CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
 879      ]
 880
 881 dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
 882    = mkTemps [WordRep, WordRep]         `thenFlt` \ [w1,w2] ->
 883      (returnFlt . CSequential) [
 884         CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
 885         CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
 886         CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
 887      ]
 888
 889 -- #define addrToHValuezh(r,a) r=(P_)a
 890 dscCOpStmt [res] AddrToHValueOp [arg] vols
 891    = returnFlt
 892         (CAssign res arg)
 893
 894 -- #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 895 --
 896 --   In the unregisterised case, we don't attempt to compute the location
 897 --   of the tag halfword, just a macro. For this build, fixing on layout
 898 --   info has only got drawbacks.
 899 --
 900 --   Should this arrangement deeply offend you for some reason, code which
 901 --   computes the offset can be found below also.
 902 --      -- sof 3/02
 903 --
 904 dscCOpStmt [res] DataToTagOp [arg] vols
 905    | not tablesNextToCode
 906    = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
 907    | otherwise
 908    = mkTemps [PtrRep, WordRep]          `thenFlt` \ [t_infoptr, t_theword] ->
 909      mkHalfWord_HIADDR res t_theword    `thenFlt` \ select_ops ->
 910      (returnFlt . CSequential) [
 911         CAssign t_infoptr (mkDerefOff PtrRep arg 0),
 912          {-
 913            Get at the tag within the info table; two cases to consider:
 914
 915               - reversed info tables next to the entry point code;
 916                 one word above the end of the info table (which is
 917                 what t_infoptr is really pointing to).
 918               - info tables with their entry points stored somewhere else,
 919                 which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
 920                 world operates.
 921
 922                 The t_infoptr points to the start of the info table, so add
 923                 the length of the info table & subtract one word.
 924          -}
 925         CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
 926 {- UNUSED - see above comment.
 927                                      (if opt_Unregisterised then
 928                                          (fixedItblSize - 1)
 929                                       else (-1))),
 930 -}
 931         select_ops
 932      ]
 933
 934
 935 {- Freezing arrays-of-ptrs requires changing an info table, for the
 936    benefit of the generational collector.  It needs to scavenge mutable
 937    objects, even if they are in old space.  When they become immutable,
 938    they can be removed from this scavenge list.  -}
 939
 940 -- #define unsafeFreezzeArrayzh(r,a)                                    \
 941 --      {                                                               \
 942 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);        \
 943 --      r = a;                                                          \
 944 --      }
 945 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
 946    = (returnFlt . CSequential) [
 947         CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
 948         CAssign res arg
 949      ]
 950
 951 -- #define unsafeFreezzeByteArrayzh(r,a)        r=(a)
 952 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
 953    = returnFlt
 954         (CAssign res arg)
 955
 956 -- This ought to be trivial, but it's difficult to insert the casts
 957 -- required to keep the C compiler happy.
 958 dscCOpStmt [r] AddrRemOp [a1,a2] vols
 959    = mkTemp WordRep                     `thenFlt` \ a1casted ->
 960      (returnFlt . CSequential) [
 961         CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
 962         CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
 963      ]
 964
 965 -- not handled by translateOp because they need casts
 966 dscCOpStmt [r] SllOp [a1,a2] vols
 967    = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
 968 dscCOpStmt [r] SrlOp [a1,a2] vols
 969    = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
 970
 971 dscCOpStmt [r] ISllOp [a1,a2] vols
 972    = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
 973 dscCOpStmt [r] ISrlOp [a1,a2] vols
 974    = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
 975 dscCOpStmt [r] ISraOp [a1,a2] vols
 976    = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
 977
 978 -- Reading/writing pointer arrays
 979
 980 dscCOpStmt [r] ReadArrayOp  [obj,ix]   vols  = doReadPtrArrayOp r obj ix
 981 dscCOpStmt [r] IndexArrayOp [obj,ix]   vols  = doReadPtrArrayOp r obj ix
 982 dscCOpStmt []  WriteArrayOp [obj,ix,v] vols  = doWritePtrArrayOp obj ix v
 983
 984 -- IndexXXXoffForeignObj
 985
 986 dscCOpStmt [r] IndexOffForeignObjOp_Char      [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
 987 dscCOpStmt [r] IndexOffForeignObjOp_WideChar  [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
 988 dscCOpStmt [r] IndexOffForeignObjOp_Int       [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
 989 dscCOpStmt [r] IndexOffForeignObjOp_Word      [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
 990 dscCOpStmt [r] IndexOffForeignObjOp_Addr      [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
 991 dscCOpStmt [r] IndexOffForeignObjOp_Float     [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
 992 dscCOpStmt [r] IndexOffForeignObjOp_Double    [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
 993 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
 994
 995 dscCOpStmt [r] IndexOffForeignObjOp_Int8      [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep  r a i
 996 dscCOpStmt [r] IndexOffForeignObjOp_Int16     [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
 997 dscCOpStmt [r] IndexOffForeignObjOp_Int32     [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
 998 dscCOpStmt [r] IndexOffForeignObjOp_Int64     [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
 999
1000 dscCOpStmt [r] IndexOffForeignObjOp_Word8     [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep  r a i
1001 dscCOpStmt [r] IndexOffForeignObjOp_Word16    [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
1002 dscCOpStmt [r] IndexOffForeignObjOp_Word32    [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1003 dscCOpStmt [r] IndexOffForeignObjOp_Word64    [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
1004
1005 -- IndexXXXoffAddr
1006
1007 dscCOpStmt [r] IndexOffAddrOp_Char      [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1008 dscCOpStmt [r] IndexOffAddrOp_WideChar  [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1009 dscCOpStmt [r] IndexOffAddrOp_Int       [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1010 dscCOpStmt [r] IndexOffAddrOp_Word      [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1011 dscCOpStmt [r] IndexOffAddrOp_Addr      [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1012 dscCOpStmt [r] IndexOffAddrOp_Float     [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1013 dscCOpStmt [r] IndexOffAddrOp_Double    [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1014 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1015
1016 dscCOpStmt [r] IndexOffAddrOp_Int8      [a,i] vols = doIndexOffAddrOp Nothing Int8Rep  r a i
1017 dscCOpStmt [r] IndexOffAddrOp_Int16     [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1018 dscCOpStmt [r] IndexOffAddrOp_Int32     [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1019 dscCOpStmt [r] IndexOffAddrOp_Int64     [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1020
1021 dscCOpStmt [r] IndexOffAddrOp_Word8     [a,i] vols = doIndexOffAddrOp Nothing Word8Rep  r a i
1022 dscCOpStmt [r] IndexOffAddrOp_Word16    [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1023 dscCOpStmt [r] IndexOffAddrOp_Word32    [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1024 dscCOpStmt [r] IndexOffAddrOp_Word64    [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1025
1026 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1027
1028 dscCOpStmt [r] ReadOffAddrOp_Char      [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1029 dscCOpStmt [r] ReadOffAddrOp_WideChar  [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1030 dscCOpStmt [r] ReadOffAddrOp_Int       [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1031 dscCOpStmt [r] ReadOffAddrOp_Word      [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1032 dscCOpStmt [r] ReadOffAddrOp_Addr      [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1033 dscCOpStmt [r] ReadOffAddrOp_Float     [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1034 dscCOpStmt [r] ReadOffAddrOp_Double    [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1035 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1036
1037 dscCOpStmt [r] ReadOffAddrOp_Int8      [a,i] vols = doIndexOffAddrOp Nothing Int8Rep  r a i
1038 dscCOpStmt [r] ReadOffAddrOp_Int16     [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1039 dscCOpStmt [r] ReadOffAddrOp_Int32     [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1040 dscCOpStmt [r] ReadOffAddrOp_Int64     [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1041
1042 dscCOpStmt [r] ReadOffAddrOp_Word8     [a,i] vols = doIndexOffAddrOp Nothing Word8Rep  r a i
1043 dscCOpStmt [r] ReadOffAddrOp_Word16    [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1044 dscCOpStmt [r] ReadOffAddrOp_Word32    [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1045 dscCOpStmt [r] ReadOffAddrOp_Word64    [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1046
1047 -- IndexXXXArray
1048
1049 dscCOpStmt [r] IndexByteArrayOp_Char      [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1050 dscCOpStmt [r] IndexByteArrayOp_WideChar  [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1051 dscCOpStmt [r] IndexByteArrayOp_Int       [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1052 dscCOpStmt [r] IndexByteArrayOp_Word      [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1053 dscCOpStmt [r] IndexByteArrayOp_Addr      [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1054 dscCOpStmt [r] IndexByteArrayOp_Float     [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1055 dscCOpStmt [r] IndexByteArrayOp_Double    [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1056 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1057
1058 dscCOpStmt [r] IndexByteArrayOp_Int8      [a,i] vols = doIndexByteArrayOp Nothing Int8Rep  r a i
1059 dscCOpStmt [r] IndexByteArrayOp_Int16     [a,i] vols = doIndexByteArrayOp Nothing Int16Rep  r a i
1060 dscCOpStmt [r] IndexByteArrayOp_Int32     [a,i] vols = doIndexByteArrayOp Nothing Int32Rep  r a i
1061 dscCOpStmt [r] IndexByteArrayOp_Int64     [a,i] vols = doIndexByteArrayOp Nothing Int64Rep  r a i
1062
1063 dscCOpStmt [r] IndexByteArrayOp_Word8     [a,i] vols = doIndexByteArrayOp Nothing Word8Rep  r a i
1064 dscCOpStmt [r] IndexByteArrayOp_Word16    [a,i] vols = doIndexByteArrayOp Nothing Word16Rep  r a i
1065 dscCOpStmt [r] IndexByteArrayOp_Word32    [a,i] vols = doIndexByteArrayOp Nothing Word32Rep  r a i
1066 dscCOpStmt [r] IndexByteArrayOp_Word64    [a,i] vols = doIndexByteArrayOp Nothing Word64Rep  r a i
1067
1068 -- ReadXXXArray, identical to IndexXXXArray.
1069
1070 dscCOpStmt [r] ReadByteArrayOp_Char       [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1071 dscCOpStmt [r] ReadByteArrayOp_WideChar   [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1072 dscCOpStmt [r] ReadByteArrayOp_Int        [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1073 dscCOpStmt [r] ReadByteArrayOp_Word       [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1074 dscCOpStmt [r] ReadByteArrayOp_Addr       [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1075 dscCOpStmt [r] ReadByteArrayOp_Float      [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1076 dscCOpStmt [r] ReadByteArrayOp_Double     [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1077 dscCOpStmt [r] ReadByteArrayOp_StablePtr  [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1078
1079 dscCOpStmt [r] ReadByteArrayOp_Int8       [a,i] vols = doIndexByteArrayOp Nothing Int8Rep  r a i
1080 dscCOpStmt [r] ReadByteArrayOp_Int16      [a,i] vols = doIndexByteArrayOp Nothing Int16Rep  r a i
1081 dscCOpStmt [r] ReadByteArrayOp_Int32      [a,i] vols = doIndexByteArrayOp Nothing Int32Rep  r a i
1082 dscCOpStmt [r] ReadByteArrayOp_Int64      [a,i] vols = doIndexByteArrayOp Nothing Int64Rep  r a i
1083
1084 dscCOpStmt [r] ReadByteArrayOp_Word8      [a,i] vols = doIndexByteArrayOp Nothing Word8Rep  r a i
1085 dscCOpStmt [r] ReadByteArrayOp_Word16     [a,i] vols = doIndexByteArrayOp Nothing Word16Rep  r a i
1086 dscCOpStmt [r] ReadByteArrayOp_Word32     [a,i] vols = doIndexByteArrayOp Nothing Word32Rep  r a i
1087 dscCOpStmt [r] ReadByteArrayOp_Word64     [a,i] vols = doIndexByteArrayOp Nothing Word64Rep  r a i
1088
1089 -- WriteXXXoffAddr
1090
1091 dscCOpStmt [] WriteOffAddrOp_Char       [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1092 dscCOpStmt [] WriteOffAddrOp_WideChar   [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1093 dscCOpStmt [] WriteOffAddrOp_Int        [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1094 dscCOpStmt [] WriteOffAddrOp_Word       [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1095 dscCOpStmt [] WriteOffAddrOp_Addr       [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1096 dscCOpStmt [] WriteOffAddrOp_Float      [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1097 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x
1098 dscCOpStmt [] WriteOffAddrOp_Double     [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1099 dscCOpStmt [] WriteOffAddrOp_StablePtr  [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1100
1101 dscCOpStmt [] WriteOffAddrOp_Int8       [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep  a i x
1102 dscCOpStmt [] WriteOffAddrOp_Int16      [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1103 dscCOpStmt [] WriteOffAddrOp_Int32      [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1104 dscCOpStmt [] WriteOffAddrOp_Int64      [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1105
1106 dscCOpStmt [] WriteOffAddrOp_Word8      [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep  a i x
1107 dscCOpStmt [] WriteOffAddrOp_Word16     [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1108 dscCOpStmt [] WriteOffAddrOp_Word32     [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1109 dscCOpStmt [] WriteOffAddrOp_Word64     [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1110
1111 -- WriteXXXArray
1112
1113 dscCOpStmt [] WriteByteArrayOp_Char      [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1114 dscCOpStmt [] WriteByteArrayOp_WideChar  [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1115 dscCOpStmt [] WriteByteArrayOp_Int       [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1116 dscCOpStmt [] WriteByteArrayOp_Word      [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1117 dscCOpStmt [] WriteByteArrayOp_Addr      [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1118 dscCOpStmt [] WriteByteArrayOp_Float     [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1119 dscCOpStmt [] WriteByteArrayOp_Double    [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1120 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1121
1122 dscCOpStmt [] WriteByteArrayOp_Int8      [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep  a i x
1123 dscCOpStmt [] WriteByteArrayOp_Int16     [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep  a i x
1124 dscCOpStmt [] WriteByteArrayOp_Int32     [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep  a i x
1125 dscCOpStmt [] WriteByteArrayOp_Int64     [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep  a i x
1126
1127 dscCOpStmt [] WriteByteArrayOp_Word8     [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep  a i x
1128 dscCOpStmt [] WriteByteArrayOp_Word16    [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep  a i x
1129 dscCOpStmt [] WriteByteArrayOp_Word32    [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep  a i x
1130 dscCOpStmt [] WriteByteArrayOp_Word64    [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep  a i x
1131
1132
1133 -- Handle all others as simply as possible.
1134 dscCOpStmt ress op args vols
1135    = case translateOp ress op args of
1136         Nothing
1137            -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1138         Just (maybe_res, mop, args)
1139            -> returnFlt (
1140                  CMachOpStmt maybe_res mop args
1141                     (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1142               )
1143
1144 -- Native word signless ops
1145
1146 translateOp [r] IntAddOp       [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1147 translateOp [r] IntSubOp       [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1148 translateOp [r] WordAddOp      [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1149 translateOp [r] WordSubOp      [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1150 translateOp [r] AddrAddOp      [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1151 translateOp [r] AddrSubOp      [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1152
1153 translateOp [r] IntEqOp        [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1154 translateOp [r] IntNeOp        [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1155 translateOp [r] WordEqOp       [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1156 translateOp [r] WordNeOp       [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1157 translateOp [r] AddrEqOp       [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1158 translateOp [r] AddrNeOp       [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1159
1160 translateOp [r] AndOp          [a1,a2] = Just (r, MO_Nat_And,        [a1,a2])
1161 translateOp [r] OrOp           [a1,a2] = Just (r, MO_Nat_Or,         [a1,a2])
1162 translateOp [r] XorOp          [a1,a2] = Just (r, MO_Nat_Xor,        [a1,a2])
1163 translateOp [r] NotOp          [a1]    = Just (r, MO_Nat_Not,        [a1])
1164
1165 -- Native word signed ops
1166
1167 translateOp [r] IntMulOp       [a1,a2] = Just (r, MO_NatS_Mul,       [a1,a2])
1168 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1169 translateOp [r] IntQuotOp      [a1,a2] = Just (r, MO_NatS_Quot,      [a1,a2])
1170 translateOp [r] IntRemOp       [a1,a2] = Just (r, MO_NatS_Rem,       [a1,a2])
1171 translateOp [r] IntNegOp       [a1]    = Just (r, MO_NatS_Neg,       [a1])
1172
1173 translateOp [r] IntGeOp        [a1,a2] = Just (r, MO_NatS_Ge,        [a1,a2])
1174 translateOp [r] IntLeOp        [a1,a2] = Just (r, MO_NatS_Le,        [a1,a2])
1175 translateOp [r] IntGtOp        [a1,a2] = Just (r, MO_NatS_Gt,        [a1,a2])
1176 translateOp [r] IntLtOp        [a1,a2] = Just (r, MO_NatS_Lt,        [a1,a2])
1177
1178
1179 -- Native word unsigned ops
1180
1181 translateOp [r] WordGeOp       [a1,a2] = Just (r, MO_NatU_Ge,        [a1,a2])
1182 translateOp [r] WordLeOp       [a1,a2] = Just (r, MO_NatU_Le,        [a1,a2])
1183 translateOp [r] WordGtOp       [a1,a2] = Just (r, MO_NatU_Gt,        [a1,a2])
1184 translateOp [r] WordLtOp       [a1,a2] = Just (r, MO_NatU_Lt,        [a1,a2])
1185
1186 translateOp [r] WordMulOp      [a1,a2] = Just (r, MO_NatU_Mul,       [a1,a2])
1187 translateOp [r] WordQuotOp     [a1,a2] = Just (r, MO_NatU_Quot,      [a1,a2])
1188 translateOp [r] WordRemOp      [a1,a2] = Just (r, MO_NatU_Rem,       [a1,a2])
1189
1190 translateOp [r] AddrGeOp       [a1,a2] = Just (r, MO_NatU_Ge,        [a1,a2])
1191 translateOp [r] AddrLeOp       [a1,a2] = Just (r, MO_NatU_Le,        [a1,a2])
1192 translateOp [r] AddrGtOp       [a1,a2] = Just (r, MO_NatU_Gt,        [a1,a2])
1193 translateOp [r] AddrLtOp       [a1,a2] = Just (r, MO_NatU_Lt,        [a1,a2])
1194
1195 -- 32-bit unsigned ops
1196
1197 translateOp [r] CharEqOp       [a1,a2] = Just (r, MO_32U_Eq,        [a1,a2])
1198 translateOp [r] CharNeOp       [a1,a2] = Just (r, MO_32U_Ne,        [a1,a2])
1199 translateOp [r] CharGeOp       [a1,a2] = Just (r, MO_32U_Ge,        [a1,a2])
1200 translateOp [r] CharLeOp       [a1,a2] = Just (r, MO_32U_Le,        [a1,a2])
1201 translateOp [r] CharGtOp       [a1,a2] = Just (r, MO_32U_Gt,        [a1,a2])
1202 translateOp [r] CharLtOp       [a1,a2] = Just (r, MO_32U_Lt,        [a1,a2])
1203
1204 -- Double ops
1205
1206 translateOp [r] DoubleEqOp     [a1,a2] = Just (r, MO_Dbl_Eq,      [a1,a2])
1207 translateOp [r] DoubleNeOp     [a1,a2] = Just (r, MO_Dbl_Ne,      [a1,a2])
1208 translateOp [r] DoubleGeOp     [a1,a2] = Just (r, MO_Dbl_Ge,      [a1,a2])
1209 translateOp [r] DoubleLeOp     [a1,a2] = Just (r, MO_Dbl_Le,      [a1,a2])
1210 translateOp [r] DoubleGtOp     [a1,a2] = Just (r, MO_Dbl_Gt,      [a1,a2])
1211 translateOp [r] DoubleLtOp     [a1,a2] = Just (r, MO_Dbl_Lt,      [a1,a2])
1212
1213 translateOp [r] DoubleAddOp    [a1,a2] = Just (r, MO_Dbl_Add,    [a1,a2])
1214 translateOp [r] DoubleSubOp    [a1,a2] = Just (r, MO_Dbl_Sub,    [a1,a2])
1215 translateOp [r] DoubleMulOp    [a1,a2] = Just (r, MO_Dbl_Mul,    [a1,a2])
1216 translateOp [r] DoubleDivOp    [a1,a2] = Just (r, MO_Dbl_Div,    [a1,a2])
1217 translateOp [r] DoublePowerOp  [a1,a2] = Just (r, MO_Dbl_Pwr,    [a1,a2])
1218
1219 translateOp [r] DoubleSinOp    [a1]    = Just (r, MO_Dbl_Sin,    [a1])
1220 translateOp [r] DoubleCosOp    [a1]    = Just (r, MO_Dbl_Cos,    [a1])
1221 translateOp [r] DoubleTanOp    [a1]    = Just (r, MO_Dbl_Tan,    [a1])
1222 translateOp [r] DoubleSinhOp   [a1]    = Just (r, MO_Dbl_Sinh,   [a1])
1223 translateOp [r] DoubleCoshOp   [a1]    = Just (r, MO_Dbl_Cosh,   [a1])
1224 translateOp [r] DoubleTanhOp   [a1]    = Just (r, MO_Dbl_Tanh,   [a1])
1225 translateOp [r] DoubleAsinOp   [a1]    = Just (r, MO_Dbl_Asin,    [a1])
1226 translateOp [r] DoubleAcosOp   [a1]    = Just (r, MO_Dbl_Acos,    [a1])
1227 translateOp [r] DoubleAtanOp   [a1]    = Just (r, MO_Dbl_Atan,    [a1])
1228 translateOp [r] DoubleLogOp    [a1]    = Just (r, MO_Dbl_Log,    [a1])
1229 translateOp [r] DoubleExpOp    [a1]    = Just (r, MO_Dbl_Exp,    [a1])
1230 translateOp [r] DoubleSqrtOp   [a1]    = Just (r, MO_Dbl_Sqrt,    [a1])
1231 translateOp [r] DoubleNegOp    [a1]    = Just (r, MO_Dbl_Neg,    [a1])
1232
1233 -- Float ops
1234
1235 translateOp [r] FloatEqOp     [a1,a2] = Just (r, MO_Flt_Eq,      [a1,a2])
1236 translateOp [r] FloatNeOp     [a1,a2] = Just (r, MO_Flt_Ne,      [a1,a2])
1237 translateOp [r] FloatGeOp     [a1,a2] = Just (r, MO_Flt_Ge,      [a1,a2])
1238 translateOp [r] FloatLeOp     [a1,a2] = Just (r, MO_Flt_Le,      [a1,a2])
1239 translateOp [r] FloatGtOp     [a1,a2] = Just (r, MO_Flt_Gt,      [a1,a2])
1240 translateOp [r] FloatLtOp     [a1,a2] = Just (r, MO_Flt_Lt,      [a1,a2])
1241
1242 translateOp [r] FloatAddOp    [a1,a2] = Just (r, MO_Flt_Add,    [a1,a2])
1243 translateOp [r] FloatSubOp    [a1,a2] = Just (r, MO_Flt_Sub,    [a1,a2])
1244 translateOp [r] FloatMulOp    [a1,a2] = Just (r, MO_Flt_Mul,    [a1,a2])
1245 translateOp [r] FloatDivOp    [a1,a2] = Just (r, MO_Flt_Div,    [a1,a2])
1246 translateOp [r] FloatPowerOp  [a1,a2] = Just (r, MO_Flt_Pwr,    [a1,a2])
1247
1248 translateOp [r] FloatSinOp    [a1]    = Just (r, MO_Flt_Sin,    [a1])
1249 translateOp [r] FloatCosOp    [a1]    = Just (r, MO_Flt_Cos,    [a1])
1250 translateOp [r] FloatTanOp    [a1]    = Just (r, MO_Flt_Tan,    [a1])
1251 translateOp [r] FloatSinhOp   [a1]    = Just (r, MO_Flt_Sinh,   [a1])
1252 translateOp [r] FloatCoshOp   [a1]    = Just (r, MO_Flt_Cosh,   [a1])
1253 translateOp [r] FloatTanhOp   [a1]    = Just (r, MO_Flt_Tanh,   [a1])
1254 translateOp [r] FloatAsinOp   [a1]    = Just (r, MO_Flt_Asin,    [a1])
1255 translateOp [r] FloatAcosOp   [a1]    = Just (r, MO_Flt_Acos,    [a1])
1256 translateOp [r] FloatAtanOp   [a1]    = Just (r, MO_Flt_Atan,    [a1])
1257 translateOp [r] FloatLogOp    [a1]    = Just (r, MO_Flt_Log,    [a1])
1258 translateOp [r] FloatExpOp    [a1]    = Just (r, MO_Flt_Exp,    [a1])
1259 translateOp [r] FloatSqrtOp   [a1]    = Just (r, MO_Flt_Sqrt,    [a1])
1260 translateOp [r] FloatNegOp    [a1]    = Just (r, MO_Flt_Neg,    [a1])
1261
1262 -- Conversions
1263
1264 translateOp [r] Int2DoubleOp   [a1]   = Just (r, MO_NatS_to_Dbl,   [a1])
1265 translateOp [r] Double2IntOp   [a1]   = Just (r, MO_Dbl_to_NatS,   [a1])
1266
1267 translateOp [r] Int2FloatOp    [a1]   = Just (r, MO_NatS_to_Flt,   [a1])
1268 translateOp [r] Float2IntOp    [a1]   = Just (r, MO_Flt_to_NatS,   [a1])
1269
1270 translateOp [r] Float2DoubleOp [a1]   = Just (r, MO_Flt_to_Dbl,    [a1])
1271 translateOp [r] Double2FloatOp [a1]   = Just (r, MO_Dbl_to_Flt,    [a1])
1272
1273 translateOp [r] Int2WordOp     [a1]   = Just (r, MO_NatS_to_NatU,  [a1])
1274 translateOp [r] Word2IntOp     [a1]   = Just (r, MO_NatU_to_NatS,  [a1])
1275
1276 translateOp [r] Int2AddrOp     [a1]   = Just (r, MO_NatS_to_NatP,  [a1])
1277 translateOp [r] Addr2IntOp     [a1]   = Just (r, MO_NatP_to_NatS,  [a1])
1278
1279 translateOp [r] OrdOp          [a1]   = Just (r, MO_32U_to_NatS,   [a1])
1280 translateOp [r] ChrOp          [a1]   = Just (r, MO_NatS_to_32U,   [a1])
1281
1282 translateOp [r] Narrow8IntOp   [a1]   = Just (r, MO_8S_to_NatS,    [a1])
1283 translateOp [r] Narrow16IntOp  [a1]   = Just (r, MO_16S_to_NatS,   [a1])
1284 translateOp [r] Narrow32IntOp  [a1]   = Just (r, MO_32S_to_NatS,   [a1])
1285
1286 translateOp [r] Narrow8WordOp   [a1]  = Just (r, MO_8U_to_NatU,    [a1])
1287 translateOp [r] Narrow16WordOp  [a1]  = Just (r, MO_16U_to_NatU,   [a1])
1288 translateOp [r] Narrow32WordOp  [a1]  = Just (r, MO_32U_to_NatU,   [a1])
1289
1290 -- Word comparisons masquerading as more exotic things.
1291
1292 translateOp [r] SameMutVarOp   [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1293 translateOp [r] SameMVarOp     [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1294 translateOp [r] SameMutableArrayOp  [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1295 translateOp [r] SameMutableByteArrayOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1296 translateOp [r] EqForeignObj [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1297 translateOp [r] EqStablePtrOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1298
1299 translateOp _ _ _ = Nothing
1300 \end{code}
1301
1302
1303 \begin{code}
1304 shimFCallArg arg amode
1305   | tycon == foreignObjPrimTyCon
1306         = CMacroExpr AddrRep ForeignObj_CLOSURE_DATA [amode]
1307   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
1308         = CMacroExpr PtrRep PTRS_ARR_CTS [amode]
1309   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
1310         = CMacroExpr AddrRep BYTE_ARR_CTS [amode]
1311   | otherwise = amode
1312   where
1313         -- should be a tycon app, since this is a foreign call
1314         tycon = tyConAppTyCon (repType (stgArgType arg))
1315 \end{code}