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