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