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