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