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, ConTag )
  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(..),
  35                           isDynamicTarget, isCasmTarget )
  36 import StgSyn           ( StgOp(..) )
  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 import Maybe            ( isJust )
  44
  45 infixr 9 `thenFlt`
  46 \end{code}
  47
  48 Check if there is any real code in some Abstract~C.  If so, return it
  49 (@Just ...@); otherwise, return @Nothing@.  Don't be too strict!
  50
  51 It returns the "reduced" code in the Just part so that the work of
  52 discarding AbsCNops isn't lost, and so that if the caller uses
  53 the reduced version there's less danger of a big tree of AbsCNops getting
  54 materialised and causing a space leak.
  55
  56 \begin{code}
  57 nonemptyAbsC :: AbstractC -> Maybe AbstractC
  58 nonemptyAbsC  AbsCNop           = Nothing
  59 nonemptyAbsC (AbsCStmts s1 s2)  = case (nonemptyAbsC s1) of
  60                                     Nothing -> nonemptyAbsC s2
  61                                     Just x  -> Just (AbsCStmts x s2)
  62 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
  63                                     Nothing -> Nothing
  64                                     Just x  -> Just s
  65 nonemptyAbsC other              = Just other
  66 \end{code}
  67
  68 \begin{code}
  69 mkAbstractCs :: [AbstractC] -> AbstractC
  70 mkAbstractCs [] = AbsCNop
  71 mkAbstractCs cs = foldr1 mkAbsCStmts cs
  72
  73 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
  74 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
  75 mkAbsCStmts AbsCNop c = c
  76 mkAbsCStmts c AbsCNop = c
  77 mkAbsCStmts c1 c2     = c1 `AbsCStmts` c2
  78
  79 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
  80   = case (case (nonemptyAbsC abc2) of
  81             Nothing -> AbsCNop
  82             Just d2 -> d2)      of { abc2b ->
  83
  84     case (nonemptyAbsC abc1) of {
  85       Nothing -> abc2b;
  86       Just d1 -> AbsCStmts d1 abc2b
  87     } }
  88 -}
  89 \end{code}
  90
  91 Get the sho' 'nuff statements out of an @AbstractC@.
  92 \begin{code}
  93 mkAbsCStmtList :: AbstractC -> [AbstractC]
  94
  95 mkAbsCStmtList absC = mkAbsCStmtList' absC []
  96
  97 -- Optimised a la foldr/build!
  98
  99 mkAbsCStmtList'  AbsCNop r = r
 100
 101 mkAbsCStmtList' (AbsCStmts s1 s2) r
 102   = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
 103
 104 mkAbsCStmtList' s@(CSimultaneous c) r
 105   = if null (mkAbsCStmtList c) then r else s : r
 106
 107 mkAbsCStmtList' other r = other : r
 108 \end{code}
 109
 110 \begin{code}
 111 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
 112
 113 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
 114  | isJust (nonemptyAbsC deflt_absc)
 115         = CSwitch scrutinee (adjust tagged_alts) deflt_absc
 116  | otherwise
 117         = CSwitch scrutinee (adjust rest) first_alt
 118  where
 119    -- it's ok to convert one of the alts into a default if we don't already have
 120    -- one, because this is an algebraic case and we're guaranteed that the tag
 121    -- will match one of the branches.
 122    ((_,first_alt):rest) = tagged_alts
 123
 124    -- Adjust the tags in the switch to start at zero.
 125    -- This is the convention used by primitive ops which return algebraic
 126    -- data types.  Why?  Because for two-constructor types, zero is faster
 127    -- to create and distinguish from 1 than are 1 and 2.
 128
 129    -- We also need to convert to Literals to keep the CSwitch happy
 130    adjust tagged_alts
 131      = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
 132        | (tag, abs_c) <- tagged_alts ]
 133 \end{code}
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 magicIdPrimRep BaseReg              = PtrRep
 143 magicIdPrimRep (VanillaReg kind _) = kind
 144 magicIdPrimRep (FloatReg _)         = FloatRep
 145 magicIdPrimRep (DoubleReg _)        = DoubleRep
 146 magicIdPrimRep (LongReg kind _)     = kind
 147 magicIdPrimRep Sp                   = PtrRep
 148 magicIdPrimRep SpLim                = PtrRep
 149 magicIdPrimRep Hp                   = PtrRep
 150 magicIdPrimRep HpLim                = PtrRep
 151 magicIdPrimRep CurCostCentre        = CostCentreRep
 152 magicIdPrimRep VoidReg              = VoidRep
 153 magicIdPrimRep CurrentTSO           = PtrRep
 154 magicIdPrimRep CurrentNursery       = PtrRep
 155 magicIdPrimRep HpAlloc              = WordRep
 156 \end{code}
 157
 158 %************************************************************************
 159 %*                                                                      *
 160 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 See also the return conventions for unboxed things; currently living
 165 in @CgCon@ (next to the constructor return conventions).
 166
 167 ToDo: tiny tweaking may be in order
 168 \begin{code}
 169 getAmodeRep :: CAddrMode -> PrimRep
 170
 171 getAmodeRep (CVal _ kind)                   = kind
 172 getAmodeRep (CAddr _)                       = PtrRep
 173 getAmodeRep (CReg magic_id)                 = magicIdPrimRep magic_id
 174 getAmodeRep (CTemp uniq kind)               = kind
 175 getAmodeRep (CLbl _ kind)                   = kind
 176 getAmodeRep (CCharLike _)                   = PtrRep
 177 getAmodeRep (CIntLike _)                    = PtrRep
 178 getAmodeRep (CLit lit)                      = literalPrimRep lit
 179 getAmodeRep (CMacroExpr kind _ _)           = kind
 180 getAmodeRep (CJoinPoint _)                  = panic "getAmodeRep:CJoinPoint"
 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 entry)
 324   = flatAbsC entry              `thenFlt` \ (entry_heres, entry_tops) ->
 325     returnFlt (AbsCNop, mkAbstractCs [entry_tops,
 326        CClosureInfoAndCode cl_info entry_heres]
 327     )
 328
 329 flatAbsC (CCodeBlock lbl abs_C)
 330   = flatAbsC abs_C          `thenFlt` \ (absC_heres, absC_tops) ->
 331     returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
 332
 333 flatAbsC (CRetDirect uniq slow_code srt liveness)
 334   = flatAbsC slow_code          `thenFlt` \ (heres, tops) ->
 335     returnFlt (AbsCNop,
 336                 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
 337
 338 flatAbsC (CSwitch discrim alts deflt)
 339   = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
 340     flatAbsC deflt               `thenFlt` \ (flat_def_alt, def_tops) ->
 341     returnFlt (
 342       CSwitch discrim flat_alts flat_def_alt,
 343       mkAbstractCs (def_tops : flat_alts_tops)
 344     )
 345   where
 346     flat_alt (tag, absC)
 347       = flatAbsC absC   `thenFlt` \ (alt_heres, alt_tops) ->
 348         returnFlt ( (tag, alt_heres), alt_tops )
 349
 350 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
 351   |  is_dynamic                          -- Emit a typedef if its a dynamic call
 352      || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
 353   = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
 354   where
 355     is_dynamic = isDynamicTarget target
 356
 357 flatAbsC stmt@(CSimultaneous abs_c)
 358   = flatAbsC abs_c              `thenFlt` \ (stmts_here, tops) ->
 359     doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
 360     returnFlt (new_stmts_here, tops)
 361
 362 flatAbsC stmt@(CCheck macro amodes code)
 363   = flatAbsC code               `thenFlt` \ (code_here, code_tops) ->
 364     returnFlt (CCheck macro amodes code_here, code_tops)
 365
 366 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
 367 -- This is a HACK.
 368 flatAbsC stmt@(CCallProfCtrMacro str amodes)
 369   | str == FSLIT("TICK_CTR")    = returnFlt (AbsCNop, stmt)
 370   | otherwise                   = returnFlt (stmt, AbsCNop)
 371
 372 -- Some statements need no flattening at all:
 373 flatAbsC stmt@(CMacroStmt macro amodes)          = returnFlt (stmt, AbsCNop)
 374 flatAbsC stmt@(CCallProfCCMacro str amodes)      = returnFlt (stmt, AbsCNop)
 375 flatAbsC stmt@(CAssign dest source)              = returnFlt (stmt, AbsCNop)
 376 flatAbsC stmt@(CJump target)                     = returnFlt (stmt, AbsCNop)
 377 flatAbsC stmt@(CFallThrough target)              = returnFlt (stmt, AbsCNop)
 378 flatAbsC stmt@(CReturn target return_info)       = returnFlt (stmt, AbsCNop)
 379 flatAbsC stmt@(CInitHdr a b cc sz)               = returnFlt (stmt, AbsCNop)
 380 flatAbsC stmt@(CMachOpStmt res mop args m_vols)  = returnFlt (stmt, AbsCNop)
 381 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
 382                                                  = returnFlt (stmt, AbsCNop)
 383 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
 384    = dscCOpStmt (filter non_void_amode results) op
 385                 (filter non_void_amode args) vol_regs
 386                                 `thenFlt` \ simpl ->
 387      case simpl of
 388         COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt"   -- make sure we don't loop!
 389         other           -> flatAbsC other
 390      {-
 391         A gruesome hack for printing the names of inline primops when they
 392         are used.
 393                                   oink other
 394      where
 395         oink xxx
 396             = getUniqFlt `thenFlt` \ uu ->
 397               flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
 398
 399         moo uu op_str
 400            = COpStmt
 401                 []
 402                 (StgFCallOp
 403                     (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
 404                                       defaultCCallConv (PlaySafe False)))
 405                     uu
 406                 )
 407                 [CReg VoidReg]
 408                 []
 409         mktxt op_str
 410             = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
 411      -}
 412
 413 flatAbsC (CSequential abcs)
 414   = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
 415     returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
 416
 417
 418 -- Some statements only make sense at the top level, so we always float
 419 -- them.  This probably isn't necessary.
 420 flatAbsC stmt@(CStaticClosure _ _ _ _)          = returnFlt (AbsCNop, stmt)
 421 flatAbsC stmt@(CClosureTbl _)                   = returnFlt (AbsCNop, stmt)
 422 flatAbsC stmt@(CSRT _ _)                        = returnFlt (AbsCNop, stmt)
 423 flatAbsC stmt@(CSRTDesc _ _ _ _ _)              = 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 WordRep                     `thenFlt` \ t_hw_mask1 ->
 611      mkTemp WordRep                     `thenFlt` \ t_hw_mask2 ->
 612      let
 613          hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
 614
 615          a_hw_mask1
 616             = CMachOpStmt t_hw_mask1
 617                           MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
 618          a_hw_mask2
 619             = CMachOpStmt t_hw_mask2
 620                           MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
 621          final
 622 #        if WORDS_BIGENDIAN
 623             = CSequential [ a_hw_mask1, a_hw_mask2,
 624                  CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
 625               ]
 626 #        else
 627             = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
 628 #        endif
 629      in
 630          returnFlt final
 631
 632
 633 mkTemp :: PrimRep -> FlatM CAddrMode
 634 mkTemp rep
 635    = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
 636
 637 mkTemps = mapFlt mkTemp
 638
 639 -- Sigh.  This is done in 3 seperate places.  Should be
 640 -- commoned up (here, in pprAbsC of COpStmt, and presumably
 641 -- somewhere in the NCG).
 642 non_void_amode amode
 643    = case getAmodeRep amode of
 644         VoidRep -> False
 645         k       -> True
 646
 647 -- Helpers for translating various minor variants of array indexing.
 648
 649 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 650 mkDerefOff rep base off
 651    = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
 652
 653 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
 654 mkNoDerefOff rep base off
 655    = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
 656
 657
 658 -- Generates an address as follows
 659 --    base + sizeof(machine_word)*offw + sizeof(rep)*idx
 660 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
 661 mk_OSBI_addr offw rep base idx
 662    = CIndex (CAddr (CIndex base idx rep))
 663             (CLit (mkMachWord (fromIntegral offw)))
 664             PtrRep
 665
 666 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
 667 mk_OSBI_ref offw rep base idx
 668    = CVal (mk_OSBI_addr offw rep base idx) rep
 669
 670
 671 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
 672    = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
 673
 674 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
 675    = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
 676
 677 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
 678    = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
 679
 680 doReadPtrArrayOp res addr idx
 681    = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
 682
 683
 684 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
 685    = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
 686
 687 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
 688    = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
 689
 690 doWritePtrArrayOp addr idx val
 691    = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
 692
 693
 694
 695 mkBasicIndexedRead offw Nothing read_rep res base idx
 696    = returnFlt (
 697         CAssign res (mk_OSBI_ref offw read_rep base idx)
 698      )
 699 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
 700    = mkTemp read_rep                    `thenFlt` \ tmp ->
 701      (returnFlt . CSequential) [
 702         CAssign tmp (mk_OSBI_ref offw read_rep base idx),
 703         CMachOpStmt res cast_to_mop [tmp] Nothing
 704      ]
 705
 706 mkBasicIndexedWrite offw Nothing write_rep base idx val
 707    = returnFlt (
 708         CAssign (mk_OSBI_ref offw write_rep base idx) val
 709      )
 710 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
 711    = mkTemp write_rep                   `thenFlt` \ tmp ->
 712      (returnFlt . CSequential) [
 713         CMachOpStmt tmp cast_to_mop [val] Nothing,
 714         CAssign (mk_OSBI_ref offw write_rep base idx) tmp
 715      ]
 716
 717
 718 -- Simple dyadic op but one for which we need to cast first arg to
 719 -- be sure of correctness
 720 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
 721    = mkTemp cast_arg1_to                `thenFlt` \ arg1casted ->
 722      (returnFlt . CSequential) [
 723         CAssign arg1casted arg1,
 724         CMachOpStmt res mop [arg1casted,arg2]
 725            (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
 726      ]
 727
 728 -- IA64 mangler doesn't place tables next to code
 729 tablesNextToCode :: Bool
 730 #ifdef ia64_TARGET_ARCH
 731 tablesNextToCode = False
 732 #else
 733 tablesNextToCode = not opt_Unregisterised
 734 #endif
 735
 736 ------------------------------------------------------------------------------
 737
 738 -- This is the main top-level desugarer PrimOps into MachOps.  First we
 739 -- handle various awkward cases specially.  The remaining easy cases are
 740 -- then handled by translateOp, defined below.
 741
 742
 743 dscCOpStmt :: [CAddrMode]       -- Results
 744            -> PrimOp
 745            -> [CAddrMode]       -- Arguments
 746            -> [MagicId]         -- Potentially volatile/live registers
 747                                 -- (to save/restore around the op)
 748            -> FlatM AbstractC
 749
 750
 751 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
 752 {-
 753    With some bit-twiddling, we can define int{Add,Sub}Czh portably in
 754    C, and without needing any comparisons.  This may not be the
 755    fastest way to do it - if you have better code, please send it! --SDM
 756
 757    Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
 758
 759    We currently don't make use of the r value if c is != 0 (i.e.
 760    overflow), we just convert to big integers and try again.  This
 761    could be improved by making r and c the correct values for
 762    plugging into a new J#.
 763
 764    { r = ((I_)(a)) + ((I_)(b));                                 \
 765      c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
 766          >> (BITS_IN (I_) - 1);                                 \
 767    }
 768    Wading through the mass of bracketry, it seems to reduce to:
 769    c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
 770
 771    SSA-form:
 772    t1 = a^b
 773    t2 = ~t1
 774    t3 = a^r
 775    t4 = t2 & t3
 776    c  = t4 >>unsigned BITS_IN(I_)-1
 777 -}
 778    = mkTemps [IntRep,IntRep,IntRep,IntRep]      `thenFlt` \ [t1,t2,t3,t4] ->
 779      let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
 780      (returnFlt . CSequential) [
 781         CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
 782         CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
 783         CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
 784         CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
 785         CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
 786         CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing
 787      ]
 788
 789
 790 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
 791 {- Similarly:
 792    #define subIntCzh(r,c,a,b)                                   \
 793    { r = ((I_)(a)) - ((I_)(b));                                 \
 794      c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
 795          >> (BITS_IN (I_) - 1);                                 \
 796    }
 797
 798    c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
 799
 800    t1 = a^b
 801    t2 = a^r
 802    t3 = t1 & t2
 803    c  = t3 >>unsigned BITS_IN(I_)-1
 804 -}
 805    = mkTemps [IntRep,IntRep,IntRep]             `thenFlt` \ [t1,t2,t3] ->
 806      let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
 807      (returnFlt . CSequential) [
 808         CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
 809         CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
 810         CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
 811         CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
 812         CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing
 813      ]
 814
 815
 816 -- #define parzh(r,node) r = 1
 817 dscCOpStmt [res] ParOp [arg] vols
 818    = returnFlt
 819         (CAssign res (CLit (mkMachInt 1)))
 820
 821 -- #define readMutVarzh(r,a)     r=(P_)(((StgMutVar *)(a))->var)
 822 dscCOpStmt [res] ReadMutVarOp [mutv] vols
 823    = returnFlt
 824         (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
 825
 826 -- #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 827 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
 828    = returnFlt
 829         (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
 830
 831
 832 -- #define ForeignObj_CLOSURE_DATA(c)  (((StgForeignObj *)c)->data)
 833 -- #define foreignObjToAddrzh(r,fo)    r=ForeignObj_CLOSURE_DATA(fo)
 834 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
 835    = returnFlt
 836         (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
 837
 838 -- #define writeForeignObjzh(res,datum) \
 839 --    (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
 840 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
 841    = returnFlt
 842         (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
 843
 844
 845 -- #define sizzeofByteArrayzh(r,a) \
 846 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
 847 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
 848    = mkTemp WordRep                     `thenFlt` \ w ->
 849      (returnFlt . CSequential) [
 850         CAssign w (mkDerefOff WordRep arg fixedHdrSize),
 851         CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (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 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 res MO_Nat_Eq [sn1,sn2] Nothing
 887      ]
 888
 889 dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
 890    = mkTemps [WordRep, WordRep]         `thenFlt` \ [w1,w2] ->
 891      (returnFlt . CSequential) [
 892         CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
 893         CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
 894         CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
 895      ]
 896
 897 -- #define addrToHValuezh(r,a) r=(P_)a
 898 dscCOpStmt [res] AddrToHValueOp [arg] vols
 899    = returnFlt
 900         (CAssign res arg)
 901
 902 -- #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 903 --
 904 --   In the unregisterised case, we don't attempt to compute the location
 905 --   of the tag halfword, just a macro. For this build, fixing on layout
 906 --   info has only got drawbacks.
 907 --
 908 --   Should this arrangement deeply offend you for some reason, code which
 909 --   computes the offset can be found below also.
 910 --      -- sof 3/02
 911 --
 912 dscCOpStmt [res] DataToTagOp [arg] vols
 913    | not tablesNextToCode
 914    = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
 915    | otherwise
 916    = mkTemps [PtrRep, WordRep]          `thenFlt` \ [t_infoptr, t_theword] ->
 917      mkHalfWord_HIADDR res t_theword    `thenFlt` \ select_ops ->
 918      (returnFlt . CSequential) [
 919         CAssign t_infoptr (mkDerefOff PtrRep arg 0),
 920          {-
 921            Get at the tag within the info table; two cases to consider:
 922
 923               - reversed info tables next to the entry point code;
 924                 one word above the end of the info table (which is
 925                 what t_infoptr is really pointing to).
 926               - info tables with their entry points stored somewhere else,
 927                 which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
 928                 world operates.
 929
 930                 The t_infoptr points to the start of the info table, so add
 931                 the length of the info table & subtract one word.
 932          -}
 933         CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
 934 {- UNUSED - see above comment.
 935                                      (if opt_Unregisterised then
 936                                          (fixedItblSize - 1)
 937                                       else (-1))),
 938 -}
 939         select_ops
 940      ]
 941
 942
 943 {- Freezing arrays-of-ptrs requires changing an info table, for the
 944    benefit of the generational collector.  It needs to scavenge mutable
 945    objects, even if they are in old space.  When they become immutable,
 946    they can be removed from this scavenge list.  -}
 947
 948 -- #define unsafeFreezzeArrayzh(r,a)                                    \
 949 --      {                                                               \
 950 --        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info);        \
 951 --      r = a;                                                          \
 952 --      }
 953 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
 954    = (returnFlt . CSequential) [
 955         CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
 956         CAssign res arg
 957      ]
 958
 959 -- #define unsafeFreezzeByteArrayzh(r,a)        r=(a)
 960 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
 961    = returnFlt
 962         (CAssign res arg)
 963
 964 -- This ought to be trivial, but it's difficult to insert the casts
 965 -- required to keep the C compiler happy.
 966 dscCOpStmt [r] AddrRemOp [a1,a2] vols
 967    = mkTemp WordRep                     `thenFlt` \ a1casted ->
 968      (returnFlt . CSequential) [
 969         CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
 970         CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
 971      ]
 972
 973 -- not handled by translateOp because they need casts
 974 dscCOpStmt [r] SllOp [a1,a2] vols
 975    = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
 976 dscCOpStmt [r] SrlOp [a1,a2] vols
 977    = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
 978
 979 dscCOpStmt [r] ISllOp [a1,a2] vols
 980    = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
 981 dscCOpStmt [r] ISrlOp [a1,a2] vols
 982    = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
 983 dscCOpStmt [r] ISraOp [a1,a2] vols
 984    = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
 985
 986 -- Reading/writing pointer arrays
 987
 988 dscCOpStmt [r] ReadArrayOp  [obj,ix]   vols  = doReadPtrArrayOp r obj ix
 989 dscCOpStmt [r] IndexArrayOp [obj,ix]   vols  = doReadPtrArrayOp r obj ix
 990 dscCOpStmt []  WriteArrayOp [obj,ix,v] vols  = doWritePtrArrayOp obj ix v
 991
 992 -- IndexXXXoffForeignObj
 993
 994 dscCOpStmt [r] IndexOffForeignObjOp_Char      [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
 995 dscCOpStmt [r] IndexOffForeignObjOp_WideChar  [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
 996 dscCOpStmt [r] IndexOffForeignObjOp_Int       [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
 997 dscCOpStmt [r] IndexOffForeignObjOp_Word      [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
 998 dscCOpStmt [r] IndexOffForeignObjOp_Addr      [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
 999 dscCOpStmt [r] IndexOffForeignObjOp_Float     [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
1000 dscCOpStmt [r] IndexOffForeignObjOp_Double    [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
1001 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
1002
1003 dscCOpStmt [r] IndexOffForeignObjOp_Int8      [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep  r a i
1004 dscCOpStmt [r] IndexOffForeignObjOp_Int16     [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
1005 dscCOpStmt [r] IndexOffForeignObjOp_Int32     [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
1006 dscCOpStmt [r] IndexOffForeignObjOp_Int64     [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
1007
1008 dscCOpStmt [r] IndexOffForeignObjOp_Word8     [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep  r a i
1009 dscCOpStmt [r] IndexOffForeignObjOp_Word16    [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
1010 dscCOpStmt [r] IndexOffForeignObjOp_Word32    [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1011 dscCOpStmt [r] IndexOffForeignObjOp_Word64    [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
1012
1013 -- IndexXXXoffAddr
1014
1015 dscCOpStmt [r] IndexOffAddrOp_Char      [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1016 dscCOpStmt [r] IndexOffAddrOp_WideChar  [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1017 dscCOpStmt [r] IndexOffAddrOp_Int       [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1018 dscCOpStmt [r] IndexOffAddrOp_Word      [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1019 dscCOpStmt [r] IndexOffAddrOp_Addr      [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1020 dscCOpStmt [r] IndexOffAddrOp_Float     [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1021 dscCOpStmt [r] IndexOffAddrOp_Double    [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1022 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1023
1024 dscCOpStmt [r] IndexOffAddrOp_Int8      [a,i] vols = doIndexOffAddrOp Nothing Int8Rep  r a i
1025 dscCOpStmt [r] IndexOffAddrOp_Int16     [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1026 dscCOpStmt [r] IndexOffAddrOp_Int32     [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1027 dscCOpStmt [r] IndexOffAddrOp_Int64     [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1028
1029 dscCOpStmt [r] IndexOffAddrOp_Word8     [a,i] vols = doIndexOffAddrOp Nothing Word8Rep  r a i
1030 dscCOpStmt [r] IndexOffAddrOp_Word16    [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1031 dscCOpStmt [r] IndexOffAddrOp_Word32    [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1032 dscCOpStmt [r] IndexOffAddrOp_Word64    [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1033
1034 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1035
1036 dscCOpStmt [r] ReadOffAddrOp_Char      [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1037 dscCOpStmt [r] ReadOffAddrOp_WideChar  [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1038 dscCOpStmt [r] ReadOffAddrOp_Int       [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1039 dscCOpStmt [r] ReadOffAddrOp_Word      [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1040 dscCOpStmt [r] ReadOffAddrOp_Addr      [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1041 dscCOpStmt [r] ReadOffAddrOp_Float     [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1042 dscCOpStmt [r] ReadOffAddrOp_Double    [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1043 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1044
1045 dscCOpStmt [r] ReadOffAddrOp_Int8      [a,i] vols = doIndexOffAddrOp Nothing Int8Rep  r a i
1046 dscCOpStmt [r] ReadOffAddrOp_Int16     [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1047 dscCOpStmt [r] ReadOffAddrOp_Int32     [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1048 dscCOpStmt [r] ReadOffAddrOp_Int64     [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1049
1050 dscCOpStmt [r] ReadOffAddrOp_Word8     [a,i] vols = doIndexOffAddrOp Nothing Word8Rep  r a i
1051 dscCOpStmt [r] ReadOffAddrOp_Word16    [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1052 dscCOpStmt [r] ReadOffAddrOp_Word32    [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1053 dscCOpStmt [r] ReadOffAddrOp_Word64    [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1054
1055 -- IndexXXXArray
1056
1057 dscCOpStmt [r] IndexByteArrayOp_Char      [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1058 dscCOpStmt [r] IndexByteArrayOp_WideChar  [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1059 dscCOpStmt [r] IndexByteArrayOp_Int       [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1060 dscCOpStmt [r] IndexByteArrayOp_Word      [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1061 dscCOpStmt [r] IndexByteArrayOp_Addr      [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1062 dscCOpStmt [r] IndexByteArrayOp_Float     [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1063 dscCOpStmt [r] IndexByteArrayOp_Double    [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1064 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1065
1066 dscCOpStmt [r] IndexByteArrayOp_Int8      [a,i] vols = doIndexByteArrayOp Nothing Int8Rep  r a i
1067 dscCOpStmt [r] IndexByteArrayOp_Int16     [a,i] vols = doIndexByteArrayOp Nothing Int16Rep  r a i
1068 dscCOpStmt [r] IndexByteArrayOp_Int32     [a,i] vols = doIndexByteArrayOp Nothing Int32Rep  r a i
1069 dscCOpStmt [r] IndexByteArrayOp_Int64     [a,i] vols = doIndexByteArrayOp Nothing Int64Rep  r a i
1070
1071 dscCOpStmt [r] IndexByteArrayOp_Word8     [a,i] vols = doIndexByteArrayOp Nothing Word8Rep  r a i
1072 dscCOpStmt [r] IndexByteArrayOp_Word16    [a,i] vols = doIndexByteArrayOp Nothing Word16Rep  r a i
1073 dscCOpStmt [r] IndexByteArrayOp_Word32    [a,i] vols = doIndexByteArrayOp Nothing Word32Rep  r a i
1074 dscCOpStmt [r] IndexByteArrayOp_Word64    [a,i] vols = doIndexByteArrayOp Nothing Word64Rep  r a i
1075
1076 -- ReadXXXArray, identical to IndexXXXArray.
1077
1078 dscCOpStmt [r] ReadByteArrayOp_Char       [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1079 dscCOpStmt [r] ReadByteArrayOp_WideChar   [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1080 dscCOpStmt [r] ReadByteArrayOp_Int        [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1081 dscCOpStmt [r] ReadByteArrayOp_Word       [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1082 dscCOpStmt [r] ReadByteArrayOp_Addr       [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1083 dscCOpStmt [r] ReadByteArrayOp_Float      [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1084 dscCOpStmt [r] ReadByteArrayOp_Double     [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1085 dscCOpStmt [r] ReadByteArrayOp_StablePtr  [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1086
1087 dscCOpStmt [r] ReadByteArrayOp_Int8       [a,i] vols = doIndexByteArrayOp Nothing Int8Rep  r a i
1088 dscCOpStmt [r] ReadByteArrayOp_Int16      [a,i] vols = doIndexByteArrayOp Nothing Int16Rep  r a i
1089 dscCOpStmt [r] ReadByteArrayOp_Int32      [a,i] vols = doIndexByteArrayOp Nothing Int32Rep  r a i
1090 dscCOpStmt [r] ReadByteArrayOp_Int64      [a,i] vols = doIndexByteArrayOp Nothing Int64Rep  r a i
1091
1092 dscCOpStmt [r] ReadByteArrayOp_Word8      [a,i] vols = doIndexByteArrayOp Nothing Word8Rep  r a i
1093 dscCOpStmt [r] ReadByteArrayOp_Word16     [a,i] vols = doIndexByteArrayOp Nothing Word16Rep  r a i
1094 dscCOpStmt [r] ReadByteArrayOp_Word32     [a,i] vols = doIndexByteArrayOp Nothing Word32Rep  r a i
1095 dscCOpStmt [r] ReadByteArrayOp_Word64     [a,i] vols = doIndexByteArrayOp Nothing Word64Rep  r a i
1096
1097 -- WriteXXXoffAddr
1098
1099 dscCOpStmt [] WriteOffAddrOp_Char       [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1100 dscCOpStmt [] WriteOffAddrOp_WideChar   [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1101 dscCOpStmt [] WriteOffAddrOp_Int        [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1102 dscCOpStmt [] WriteOffAddrOp_Word       [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1103 dscCOpStmt [] WriteOffAddrOp_Addr       [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1104 dscCOpStmt [] WriteOffAddrOp_Float      [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1105 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x
1106 dscCOpStmt [] WriteOffAddrOp_Double     [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1107 dscCOpStmt [] WriteOffAddrOp_StablePtr  [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1108
1109 dscCOpStmt [] WriteOffAddrOp_Int8       [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep  a i x
1110 dscCOpStmt [] WriteOffAddrOp_Int16      [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1111 dscCOpStmt [] WriteOffAddrOp_Int32      [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1112 dscCOpStmt [] WriteOffAddrOp_Int64      [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1113
1114 dscCOpStmt [] WriteOffAddrOp_Word8      [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep  a i x
1115 dscCOpStmt [] WriteOffAddrOp_Word16     [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1116 dscCOpStmt [] WriteOffAddrOp_Word32     [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1117 dscCOpStmt [] WriteOffAddrOp_Word64     [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1118
1119 -- WriteXXXArray
1120
1121 dscCOpStmt [] WriteByteArrayOp_Char      [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1122 dscCOpStmt [] WriteByteArrayOp_WideChar  [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1123 dscCOpStmt [] WriteByteArrayOp_Int       [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1124 dscCOpStmt [] WriteByteArrayOp_Word      [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1125 dscCOpStmt [] WriteByteArrayOp_Addr      [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1126 dscCOpStmt [] WriteByteArrayOp_Float     [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1127 dscCOpStmt [] WriteByteArrayOp_Double    [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1128 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1129
1130 dscCOpStmt [] WriteByteArrayOp_Int8      [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep  a i x
1131 dscCOpStmt [] WriteByteArrayOp_Int16     [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep  a i x
1132 dscCOpStmt [] WriteByteArrayOp_Int32     [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep  a i x
1133 dscCOpStmt [] WriteByteArrayOp_Int64     [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep  a i x
1134
1135 dscCOpStmt [] WriteByteArrayOp_Word8     [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep  a i x
1136 dscCOpStmt [] WriteByteArrayOp_Word16    [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep  a i x
1137 dscCOpStmt [] WriteByteArrayOp_Word32    [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep  a i x
1138 dscCOpStmt [] WriteByteArrayOp_Word64    [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep  a i x
1139
1140
1141 -- Handle all others as simply as possible.
1142 dscCOpStmt ress op args vols
1143    = case translateOp ress op args of
1144         Nothing
1145            -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1146         Just (maybe_res, mop, args)
1147            -> returnFlt (
1148                  CMachOpStmt maybe_res mop args
1149                     (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1150               )
1151
1152 -- Native word signless ops
1153
1154 translateOp [r] IntAddOp       [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1155 translateOp [r] IntSubOp       [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1156 translateOp [r] WordAddOp      [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1157 translateOp [r] WordSubOp      [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1158 translateOp [r] AddrAddOp      [a1,a2] = Just (r, MO_Nat_Add,        [a1,a2])
1159 translateOp [r] AddrSubOp      [a1,a2] = Just (r, MO_Nat_Sub,        [a1,a2])
1160
1161 translateOp [r] IntEqOp        [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1162 translateOp [r] IntNeOp        [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1163 translateOp [r] WordEqOp       [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1164 translateOp [r] WordNeOp       [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1165 translateOp [r] AddrEqOp       [a1,a2] = Just (r, MO_Nat_Eq,         [a1,a2])
1166 translateOp [r] AddrNeOp       [a1,a2] = Just (r, MO_Nat_Ne,         [a1,a2])
1167
1168 translateOp [r] AndOp          [a1,a2] = Just (r, MO_Nat_And,        [a1,a2])
1169 translateOp [r] OrOp           [a1,a2] = Just (r, MO_Nat_Or,         [a1,a2])
1170 translateOp [r] XorOp          [a1,a2] = Just (r, MO_Nat_Xor,        [a1,a2])
1171 translateOp [r] NotOp          [a1]    = Just (r, MO_Nat_Not,        [a1])
1172
1173 -- Native word signed ops
1174
1175 translateOp [r] IntMulOp       [a1,a2] = Just (r, MO_NatS_Mul,       [a1,a2])
1176 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1177 translateOp [r] IntQuotOp      [a1,a2] = Just (r, MO_NatS_Quot,      [a1,a2])
1178 translateOp [r] IntRemOp       [a1,a2] = Just (r, MO_NatS_Rem,       [a1,a2])
1179 translateOp [r] IntNegOp       [a1]    = Just (r, MO_NatS_Neg,       [a1])
1180
1181 translateOp [r] IntGeOp        [a1,a2] = Just (r, MO_NatS_Ge,        [a1,a2])
1182 translateOp [r] IntLeOp        [a1,a2] = Just (r, MO_NatS_Le,        [a1,a2])
1183 translateOp [r] IntGtOp        [a1,a2] = Just (r, MO_NatS_Gt,        [a1,a2])
1184 translateOp [r] IntLtOp        [a1,a2] = Just (r, MO_NatS_Lt,        [a1,a2])
1185
1186
1187 -- Native word unsigned ops
1188
1189 translateOp [r] WordGeOp       [a1,a2] = Just (r, MO_NatU_Ge,        [a1,a2])
1190 translateOp [r] WordLeOp       [a1,a2] = Just (r, MO_NatU_Le,        [a1,a2])
1191 translateOp [r] WordGtOp       [a1,a2] = Just (r, MO_NatU_Gt,        [a1,a2])
1192 translateOp [r] WordLtOp       [a1,a2] = Just (r, MO_NatU_Lt,        [a1,a2])
1193
1194 translateOp [r] WordMulOp      [a1,a2] = Just (r, MO_NatU_Mul,       [a1,a2])
1195 translateOp [r] WordQuotOp     [a1,a2] = Just (r, MO_NatU_Quot,      [a1,a2])
1196 translateOp [r] WordRemOp      [a1,a2] = Just (r, MO_NatU_Rem,       [a1,a2])
1197
1198 translateOp [r] AddrGeOp       [a1,a2] = Just (r, MO_NatU_Ge,        [a1,a2])
1199 translateOp [r] AddrLeOp       [a1,a2] = Just (r, MO_NatU_Le,        [a1,a2])
1200 translateOp [r] AddrGtOp       [a1,a2] = Just (r, MO_NatU_Gt,        [a1,a2])
1201 translateOp [r] AddrLtOp       [a1,a2] = Just (r, MO_NatU_Lt,        [a1,a2])
1202
1203 -- 32-bit unsigned ops
1204
1205 translateOp [r] CharEqOp       [a1,a2] = Just (r, MO_32U_Eq,        [a1,a2])
1206 translateOp [r] CharNeOp       [a1,a2] = Just (r, MO_32U_Ne,        [a1,a2])
1207 translateOp [r] CharGeOp       [a1,a2] = Just (r, MO_32U_Ge,        [a1,a2])
1208 translateOp [r] CharLeOp       [a1,a2] = Just (r, MO_32U_Le,        [a1,a2])
1209 translateOp [r] CharGtOp       [a1,a2] = Just (r, MO_32U_Gt,        [a1,a2])
1210 translateOp [r] CharLtOp       [a1,a2] = Just (r, MO_32U_Lt,        [a1,a2])
1211
1212 -- Double ops
1213
1214 translateOp [r] DoubleEqOp     [a1,a2] = Just (r, MO_Dbl_Eq,      [a1,a2])
1215 translateOp [r] DoubleNeOp     [a1,a2] = Just (r, MO_Dbl_Ne,      [a1,a2])
1216 translateOp [r] DoubleGeOp     [a1,a2] = Just (r, MO_Dbl_Ge,      [a1,a2])
1217 translateOp [r] DoubleLeOp     [a1,a2] = Just (r, MO_Dbl_Le,      [a1,a2])
1218 translateOp [r] DoubleGtOp     [a1,a2] = Just (r, MO_Dbl_Gt,      [a1,a2])
1219 translateOp [r] DoubleLtOp     [a1,a2] = Just (r, MO_Dbl_Lt,      [a1,a2])
1220
1221 translateOp [r] DoubleAddOp    [a1,a2] = Just (r, MO_Dbl_Add,    [a1,a2])
1222 translateOp [r] DoubleSubOp    [a1,a2] = Just (r, MO_Dbl_Sub,    [a1,a2])
1223 translateOp [r] DoubleMulOp    [a1,a2] = Just (r, MO_Dbl_Mul,    [a1,a2])
1224 translateOp [r] DoubleDivOp    [a1,a2] = Just (r, MO_Dbl_Div,    [a1,a2])
1225 translateOp [r] DoublePowerOp  [a1,a2] = Just (r, MO_Dbl_Pwr,    [a1,a2])
1226
1227 translateOp [r] DoubleSinOp    [a1]    = Just (r, MO_Dbl_Sin,    [a1])
1228 translateOp [r] DoubleCosOp    [a1]    = Just (r, MO_Dbl_Cos,    [a1])
1229 translateOp [r] DoubleTanOp    [a1]    = Just (r, MO_Dbl_Tan,    [a1])
1230 translateOp [r] DoubleSinhOp   [a1]    = Just (r, MO_Dbl_Sinh,   [a1])
1231 translateOp [r] DoubleCoshOp   [a1]    = Just (r, MO_Dbl_Cosh,   [a1])
1232 translateOp [r] DoubleTanhOp   [a1]    = Just (r, MO_Dbl_Tanh,   [a1])
1233 translateOp [r] DoubleAsinOp   [a1]    = Just (r, MO_Dbl_Asin,    [a1])
1234 translateOp [r] DoubleAcosOp   [a1]    = Just (r, MO_Dbl_Acos,    [a1])
1235 translateOp [r] DoubleAtanOp   [a1]    = Just (r, MO_Dbl_Atan,    [a1])
1236 translateOp [r] DoubleLogOp    [a1]    = Just (r, MO_Dbl_Log,    [a1])
1237 translateOp [r] DoubleExpOp    [a1]    = Just (r, MO_Dbl_Exp,    [a1])
1238 translateOp [r] DoubleSqrtOp   [a1]    = Just (r, MO_Dbl_Sqrt,    [a1])
1239 translateOp [r] DoubleNegOp    [a1]    = Just (r, MO_Dbl_Neg,    [a1])
1240
1241 -- Float ops
1242
1243 translateOp [r] FloatEqOp     [a1,a2] = Just (r, MO_Flt_Eq,      [a1,a2])
1244 translateOp [r] FloatNeOp     [a1,a2] = Just (r, MO_Flt_Ne,      [a1,a2])
1245 translateOp [r] FloatGeOp     [a1,a2] = Just (r, MO_Flt_Ge,      [a1,a2])
1246 translateOp [r] FloatLeOp     [a1,a2] = Just (r, MO_Flt_Le,      [a1,a2])
1247 translateOp [r] FloatGtOp     [a1,a2] = Just (r, MO_Flt_Gt,      [a1,a2])
1248 translateOp [r] FloatLtOp     [a1,a2] = Just (r, MO_Flt_Lt,      [a1,a2])
1249
1250 translateOp [r] FloatAddOp    [a1,a2] = Just (r, MO_Flt_Add,    [a1,a2])
1251 translateOp [r] FloatSubOp    [a1,a2] = Just (r, MO_Flt_Sub,    [a1,a2])
1252 translateOp [r] FloatMulOp    [a1,a2] = Just (r, MO_Flt_Mul,    [a1,a2])
1253 translateOp [r] FloatDivOp    [a1,a2] = Just (r, MO_Flt_Div,    [a1,a2])
1254 translateOp [r] FloatPowerOp  [a1,a2] = Just (r, MO_Flt_Pwr,    [a1,a2])
1255
1256 translateOp [r] FloatSinOp    [a1]    = Just (r, MO_Flt_Sin,    [a1])
1257 translateOp [r] FloatCosOp    [a1]    = Just (r, MO_Flt_Cos,    [a1])
1258 translateOp [r] FloatTanOp    [a1]    = Just (r, MO_Flt_Tan,    [a1])
1259 translateOp [r] FloatSinhOp   [a1]    = Just (r, MO_Flt_Sinh,   [a1])
1260 translateOp [r] FloatCoshOp   [a1]    = Just (r, MO_Flt_Cosh,   [a1])
1261 translateOp [r] FloatTanhOp   [a1]    = Just (r, MO_Flt_Tanh,   [a1])
1262 translateOp [r] FloatAsinOp   [a1]    = Just (r, MO_Flt_Asin,    [a1])
1263 translateOp [r] FloatAcosOp   [a1]    = Just (r, MO_Flt_Acos,    [a1])
1264 translateOp [r] FloatAtanOp   [a1]    = Just (r, MO_Flt_Atan,    [a1])
1265 translateOp [r] FloatLogOp    [a1]    = Just (r, MO_Flt_Log,    [a1])
1266 translateOp [r] FloatExpOp    [a1]    = Just (r, MO_Flt_Exp,    [a1])
1267 translateOp [r] FloatSqrtOp   [a1]    = Just (r, MO_Flt_Sqrt,    [a1])
1268 translateOp [r] FloatNegOp    [a1]    = Just (r, MO_Flt_Neg,    [a1])
1269
1270 -- Conversions
1271
1272 translateOp [r] Int2DoubleOp   [a1]   = Just (r, MO_NatS_to_Dbl,   [a1])
1273 translateOp [r] Double2IntOp   [a1]   = Just (r, MO_Dbl_to_NatS,   [a1])
1274
1275 translateOp [r] Int2FloatOp    [a1]   = Just (r, MO_NatS_to_Flt,   [a1])
1276 translateOp [r] Float2IntOp    [a1]   = Just (r, MO_Flt_to_NatS,   [a1])
1277
1278 translateOp [r] Float2DoubleOp [a1]   = Just (r, MO_Flt_to_Dbl,    [a1])
1279 translateOp [r] Double2FloatOp [a1]   = Just (r, MO_Dbl_to_Flt,    [a1])
1280
1281 translateOp [r] Int2WordOp     [a1]   = Just (r, MO_NatS_to_NatU,  [a1])
1282 translateOp [r] Word2IntOp     [a1]   = Just (r, MO_NatU_to_NatS,  [a1])
1283
1284 translateOp [r] Int2AddrOp     [a1]   = Just (r, MO_NatS_to_NatP,  [a1])
1285 translateOp [r] Addr2IntOp     [a1]   = Just (r, MO_NatP_to_NatS,  [a1])
1286
1287 translateOp [r] OrdOp          [a1]   = Just (r, MO_32U_to_NatS,   [a1])
1288 translateOp [r] ChrOp          [a1]   = Just (r, MO_NatS_to_32U,   [a1])
1289
1290 translateOp [r] Narrow8IntOp   [a1]   = Just (r, MO_8S_to_NatS,    [a1])
1291 translateOp [r] Narrow16IntOp  [a1]   = Just (r, MO_16S_to_NatS,   [a1])
1292 translateOp [r] Narrow32IntOp  [a1]   = Just (r, MO_32S_to_NatS,   [a1])
1293
1294 translateOp [r] Narrow8WordOp   [a1]  = Just (r, MO_8U_to_NatU,    [a1])
1295 translateOp [r] Narrow16WordOp  [a1]  = Just (r, MO_16U_to_NatU,   [a1])
1296 translateOp [r] Narrow32WordOp  [a1]  = Just (r, MO_32U_to_NatU,   [a1])
1297
1298 -- Word comparisons masquerading as more exotic things.
1299
1300 translateOp [r] SameMutVarOp   [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1301 translateOp [r] SameMVarOp     [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1302 translateOp [r] SameMutableArrayOp  [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1303 translateOp [r] SameMutableByteArrayOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1304 translateOp [r] EqForeignObj [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1305 translateOp [r] EqStablePtrOp [a1,a2]  = Just (r, MO_Nat_Eq,    [a1,a2])
1306
1307 translateOp _ _ _ = Nothing
1308
1309 \end{code}