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, ConTag )
26 import Literal ( literalPrimRep, mkMachWord, mkMachInt )
27 import PrimRep ( getPrimRepSize, PrimRep(..) )
28 import PrimOp ( PrimOp(..) )
29 import MachOp ( MachOp(..), isDefinitelyInlineMachOp )
30 import Unique ( Unique{-instance Eq-} )
31 import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
33 import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
34 import ForeignCall ( ForeignCall(..), CCallSpec(..),
35 isDynamicTarget, isCasmTarget )
36 import StgSyn ( StgOp(..) )
37 import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
39 import Panic ( panic )
42 import Maybe ( isJust )
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 -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
112 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
113 | isJust (nonemptyAbsC deflt_absc)
114 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
116 = CSwitch scrutinee (adjust rest) first_alt
118 -- it's ok to convert one of the alts into a default if we don't already have
119 -- one, because this is an algebraic case and we're guaranteed that the tag
120 -- will match one of the branches.
121 ((_,first_alt):rest) = tagged_alts
123 -- Adjust the tags in the switch to start at zero.
124 -- This is the convention used by primitive ops which return algebraic
125 -- data types. Why? Because for two-constructor types, zero is faster
126 -- to create and distinguish from 1 than are 1 and 2.
128 -- We also need to convert to Literals to keep the CSwitch happy
130 = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
131 | (tag, abs_c) <- tagged_alts ]
134 %************************************************************************
136 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
138 %************************************************************************
141 magicIdPrimRep BaseReg = PtrRep
142 magicIdPrimRep (VanillaReg kind _) = kind
143 magicIdPrimRep (FloatReg _) = FloatRep
144 magicIdPrimRep (DoubleReg _) = DoubleRep
145 magicIdPrimRep (LongReg kind _) = kind
146 magicIdPrimRep Sp = PtrRep
147 magicIdPrimRep SpLim = PtrRep
148 magicIdPrimRep Hp = PtrRep
149 magicIdPrimRep HpLim = PtrRep
150 magicIdPrimRep CurCostCentre = CostCentreRep
151 magicIdPrimRep VoidReg = VoidRep
152 magicIdPrimRep CurrentTSO = PtrRep
153 magicIdPrimRep CurrentNursery = PtrRep
154 magicIdPrimRep HpAlloc = WordRep
157 %************************************************************************
159 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
161 %************************************************************************
163 See also the return conventions for unboxed things; currently living
164 in @CgCon@ (next to the constructor return conventions).
166 ToDo: tiny tweaking may be in order
168 getAmodeRep :: CAddrMode -> PrimRep
170 getAmodeRep (CVal _ kind) = kind
171 getAmodeRep (CAddr _) = PtrRep
172 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
173 getAmodeRep (CTemp uniq kind) = kind
174 getAmodeRep (CLbl _ kind) = kind
175 getAmodeRep (CCharLike _) = PtrRep
176 getAmodeRep (CIntLike _) = PtrRep
177 getAmodeRep (CLit lit) = literalPrimRep lit
178 getAmodeRep (CMacroExpr kind _ _) = kind
179 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
182 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
183 location; that is, one which can contain values of various types.
186 mixedTypeLocn :: CAddrMode -> Bool
188 mixedTypeLocn (CVal (NodeRel _) _) = True
189 mixedTypeLocn (CVal (SpRel _) _) = True
190 mixedTypeLocn (CVal (HpRel _) _) = True
191 mixedTypeLocn other = False -- All the rest
194 @mixedPtrLocn@ tells whether an amode identifies a
195 location which can contain values of various pointer types.
198 mixedPtrLocn :: CAddrMode -> Bool
200 mixedPtrLocn (CVal (SpRel _) _) = True
201 mixedPtrLocn other = False -- All the rest
204 %************************************************************************
206 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
208 %************************************************************************
210 The following bits take ``raw'' Abstract~C, which may have all sorts of
211 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
212 @CClosureInfos@ and code for switches are pulled out to the top level.
214 The various functions herein tend to produce
217 A {\em flattened} \tr{<something>} of interest for ``here'', and
219 Some {\em unflattened} Abstract~C statements to be carried up to the
220 top-level. The only real reason (now) that it is unflattened is
221 because it means the recursive flattening can be done in just one
222 place rather than having to remember lots of places.
225 Care is taken to reduce the occurrence of forward references, while still
226 keeping laziness a much as possible. Essentially, this means that:
229 {\em All} the top-level C statements resulting from flattening a
230 particular AbsC statement (whether the latter is nested or not) appear
231 before {\em any} of the code for a subsequent AbsC statement;
233 but stuff nested within any AbsC statement comes
234 out before the code for the statement itself.
237 The ``stuff to be carried up'' always includes a label: a
238 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
239 @CCodeBlock@. The latter turns into a C function, and is never
240 actually produced by the code generator. Rather it always starts life
241 as a @CCodeBlock@ addressing mode; when such an addr mode is
242 flattened, the ``tops'' stuff is a @CCodeBlock@.
245 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
248 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
249 here `mkAbsCStmts` tops }
252 %************************************************************************
254 \subsubsection{Flattening monadery}
256 %************************************************************************
258 The flattener is monadised. It's just a @UniqueSupply@.
261 type FlatM result = UniqSupply -> result
263 initFlt :: UniqSupply -> FlatM a -> a
265 initFlt init_us m = m init_us
267 {-# INLINE thenFlt #-}
268 {-# INLINE returnFlt #-}
270 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
273 = case (splitUniqSupply us) of { (s1, s2) ->
274 case (expr s1) of { result ->
277 returnFlt :: a -> FlatM a
278 returnFlt result us = result
280 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
282 mapFlt f [] = returnFlt []
284 = f x `thenFlt` \ r ->
285 mapFlt f xs `thenFlt` \ rs ->
288 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
290 mapAndUnzipFlt f [] = returnFlt ([],[])
291 mapAndUnzipFlt f (x:xs)
292 = f x `thenFlt` \ (r1, r2) ->
293 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
294 returnFlt (r1:rs1, r2:rs2)
296 getUniqFlt :: FlatM Unique
297 getUniqFlt us = uniqFromSupply us
299 getUniqsFlt :: FlatM [Unique]
300 getUniqsFlt us = uniqsFromSupply us
303 %************************************************************************
305 \subsubsection{Flattening the top level}
307 %************************************************************************
310 flatAbsC :: AbstractC
311 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
312 AbstractC) -- Stuff to put at top level flattened]
314 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
316 flatAbsC (AbsCStmts s1 s2)
317 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
318 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
319 returnFlt (mkAbsCStmts inline_s1 inline_s2,
320 mkAbsCStmts top_s1 top_s2)
322 flatAbsC (CClosureInfoAndCode cl_info entry)
323 = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) ->
324 returnFlt (AbsCNop, mkAbstractCs [entry_tops,
325 CClosureInfoAndCode cl_info entry_heres]
328 flatAbsC (CCodeBlock lbl abs_C)
329 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
330 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
332 flatAbsC (CRetDirect uniq slow_code srt liveness)
333 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
335 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
337 flatAbsC (CSwitch discrim alts deflt)
338 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
339 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
341 CSwitch discrim flat_alts flat_def_alt,
342 mkAbstractCs (def_tops : flat_alts_tops)
346 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
347 returnFlt ( (tag, alt_heres), alt_tops )
349 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
350 | is_dynamic -- Emit a typedef if its a dynamic call
351 || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
352 = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
354 is_dynamic = isDynamicTarget target
356 flatAbsC stmt@(CSimultaneous abs_c)
357 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
358 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
359 returnFlt (new_stmts_here, tops)
361 flatAbsC stmt@(CCheck macro amodes code)
362 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
363 returnFlt (CCheck macro amodes code_here, code_tops)
365 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
367 flatAbsC stmt@(CCallProfCtrMacro str amodes)
368 | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
369 | otherwise = returnFlt (stmt, AbsCNop)
371 -- Some statements need no flattening at all:
372 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
373 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
374 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
375 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
376 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
377 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
378 flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop)
379 flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop)
380 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
381 = returnFlt (stmt, AbsCNop)
382 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
383 = dscCOpStmt (filter non_void_amode results) op
384 (filter non_void_amode args) vol_regs
387 COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop!
388 other -> flatAbsC other
390 A gruesome hack for printing the names of inline primops when they
395 = getUniqFlt `thenFlt` \ uu ->
396 flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
402 (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
403 defaultCCallConv (PlaySafe False)))
409 = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
412 flatAbsC (CSequential abcs)
413 = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
414 returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
417 -- Some statements only make sense at the top level, so we always float
418 -- them. This probably isn't necessary.
419 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
420 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
421 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
422 flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt)
423 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
424 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
425 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
426 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
427 flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt)
431 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
432 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
433 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
434 returnFlt (Just heres, tops)
437 %************************************************************************
439 \subsection[flat-simultaneous]{Doing things simultaneously}
441 %************************************************************************
444 doSimultaneously :: AbstractC -> FlatM AbstractC
447 Generate code to perform the @CAssign@s and @COpStmt@s in the
448 input simultaneously, using temporary variables when necessary.
450 We use the strongly-connected component algorithm, in which
451 * the vertices are the statements
452 * an edge goes from s1 to s2 iff
453 s1 assigns to something s2 uses
454 that is, if s1 should *follow* s2 in the final order
457 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
458 -- for fast comparison
460 doSimultaneously abs_c
462 enlisted = en_list abs_c
464 case enlisted of -- it's often just one stmt
465 [] -> returnFlt AbsCNop
467 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
469 -- en_list puts all the assignments in a list, filtering out Nops and
470 -- assignments which do nothing
472 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
473 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
474 en_list other = [other]
476 sameAmode :: CAddrMode -> CAddrMode -> Bool
477 -- ToDo: Move this function, or make CAddrMode an instance of Eq
478 -- At the moment we put in just enough to catch the cases we want:
479 -- the second (destination) argument is always a CVal.
480 sameAmode (CReg r1) (CReg r2) = r1 == r2
481 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
482 sameAmode other1 other2 = False
484 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
485 doSimultaneously1 vertices
487 edges = [ (vertex, key1, edges_from stmt1)
488 | vertex@(key1, stmt1) <- vertices
490 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
491 stmt1 `should_follow` stmt2
493 components = stronglyConnComp edges
495 -- do_components deal with one strongly-connected component
496 -- Not cyclic, or singleton? Just do it
497 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
498 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
500 -- Cyclic? Then go via temporaries. Pick one to
501 -- break the loop and try again with the rest.
502 do_component (CyclicSCC ((n,first_stmt) : rest))
503 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
504 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
505 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
507 go_via_temps (CAssign dest src)
508 = getUniqFlt `thenFlt` \ uniq ->
510 the_temp = CTemp uniq (getAmodeRep dest)
512 returnFlt (CAssign the_temp src, CAssign dest the_temp)
514 go_via_temps (COpStmt dests op srcs vol_regs)
515 = getUniqsFlt `thenFlt` \ uniqs ->
517 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
519 returnFlt (COpStmt the_temps op srcs vol_regs,
520 mkAbstractCs (zipWith CAssign dests the_temps))
522 mapFlt do_component components `thenFlt` \ abs_cs ->
523 returnFlt (mkAbstractCs abs_cs)
526 should_follow :: AbstractC -> AbstractC -> Bool
527 (CAssign dest1 _) `should_follow` (CAssign _ src2)
528 = dest1 `conflictsWith` src2
529 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
530 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
531 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
532 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
533 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
534 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
537 @conflictsWith@ tells whether an assignment to its first argument will
538 screw up an access to its second.
541 conflictsWith :: CAddrMode -> CAddrMode -> Bool
542 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
543 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
544 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
545 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
546 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
547 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
549 other1 `conflictsWith` other2 = False
550 -- CAddr and literals are impossible on the LHS of an assignment
552 regConflictsWithRR :: MagicId -> RegRelative -> Bool
554 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True
555 regConflictsWithRR Sp (SpRel _) = True
556 regConflictsWithRR Hp (HpRel _) = True
557 regConflictsWithRR _ _ = False
559 rrConflictsWithRR :: Int -> Int -- Sizes of two things
560 -> RegRelative -> RegRelative -- The two amodes
563 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
568 rr (SpRel o1) (SpRel o2)
569 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
570 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
571 | otherwise = (o1 +# s1) >=# o2 &&
574 rr (NodeRel o1) (NodeRel o2)
575 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
576 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
577 | otherwise = True -- Give up
579 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
581 rr other1 other2 = False
584 %************************************************************************
586 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
588 %************************************************************************
592 -- We begin with some helper functions. The main Dude here is
593 -- dscCOpStmt, defined a little further down.
595 ------------------------------------------------------------------------------
597 -- Assumes no volatiles
599 -- res = arg >> (bits-per-word / 2) when little-endian
601 -- res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
603 -- In other words, if arg had been stored in memory, makes res the
604 -- halfword of arg which would have had the higher address. This is
605 -- why it needs to take into account endianness.
607 mkHalfWord_HIADDR res arg
608 = mkTemp IntRep `thenFlt` \ t_hw_shift ->
609 mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
610 mkTemp WordRep `thenFlt` \ t_hw_mask2 ->
612 = CMachOpStmt t_hw_shift
613 MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing
615 = CMachOpStmt t_hw_mask1
616 MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing
618 = CMachOpStmt t_hw_mask2
619 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
622 = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2,
623 CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
626 = CSequential [ a_hw_shift,
627 CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing
634 mkTemp :: PrimRep -> FlatM CAddrMode
636 = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
638 mkTemps = mapFlt mkTemp
640 -- Sigh. This is done in 3 seperate places. Should be
641 -- commoned up (here, in pprAbsC of COpStmt, and presumably
642 -- somewhere in the NCG).
644 = case getAmodeRep amode of
648 -- Helpers for translating various minor variants of array indexing.
650 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
651 mkDerefOff rep base off
652 = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
654 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
655 mkNoDerefOff rep base off
656 = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
659 -- Generates an address as follows
660 -- base + sizeof(machine_word)*offw + sizeof(rep)*idx
661 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
662 mk_OSBI_addr offw rep base idx
663 = CIndex (CAddr (CIndex base idx rep))
664 (CLit (mkMachWord (fromIntegral offw)))
667 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
668 mk_OSBI_ref offw rep base idx
669 = CVal (mk_OSBI_addr offw rep base idx) rep
672 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
673 = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
675 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
676 = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
678 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
679 = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
681 doReadPtrArrayOp res addr idx
682 = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
685 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
686 = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
688 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
689 = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
691 doWritePtrArrayOp addr idx val
692 = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
696 mkBasicIndexedRead offw Nothing read_rep res base idx
698 CAssign res (mk_OSBI_ref offw read_rep base idx)
700 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
701 = mkTemp read_rep `thenFlt` \ tmp ->
702 (returnFlt . CSequential) [
703 CAssign tmp (mk_OSBI_ref offw read_rep base idx),
704 CMachOpStmt res cast_to_mop [tmp] Nothing
707 mkBasicIndexedWrite offw Nothing write_rep base idx val
709 CAssign (mk_OSBI_ref offw write_rep base idx) val
711 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
712 = mkTemp write_rep `thenFlt` \ tmp ->
713 (returnFlt . CSequential) [
714 CMachOpStmt tmp cast_to_mop [val] Nothing,
715 CAssign (mk_OSBI_ref offw write_rep base idx) tmp
719 -- Simple dyadic op but one for which we need to cast first arg to
720 -- be sure of correctness
721 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
722 = mkTemp cast_arg1_to `thenFlt` \ arg1casted ->
723 (returnFlt . CSequential) [
724 CAssign arg1casted arg1,
725 CMachOpStmt res mop [arg1casted,arg2]
726 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
729 getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode)
731 = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] ->
734 CMachOpStmt t1 MO_Nat_Shl
735 [CBytesPerWord, CLit (mkMachInt 3)] Nothing,
736 CMachOpStmt t2 MO_Nat_Sub
737 [t1, CLit (mkMachInt 1)] Nothing
742 -- IA64 mangler doesn't place tables next to code
743 tablesNextToCode :: Bool
744 #ifdef ia64_TARGET_ARCH
745 tablesNextToCode = False
747 tablesNextToCode = not opt_Unregisterised
750 ------------------------------------------------------------------------------
752 -- This is the main top-level desugarer PrimOps into MachOps. First we
753 -- handle various awkward cases specially. The remaining easy cases are
754 -- then handled by translateOp, defined below.
757 dscCOpStmt :: [CAddrMode] -- Results
759 -> [CAddrMode] -- Arguments
760 -> [MagicId] -- Potentially volatile/live registers
761 -- (to save/restore around the op)
765 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
767 With some bit-twiddling, we can define int{Add,Sub}Czh portably in
768 C, and without needing any comparisons. This may not be the
769 fastest way to do it - if you have better code, please send it! --SDM
771 Return : r = a + b, c = 0 if no overflow, 1 on overflow.
773 We currently don't make use of the r value if c is != 0 (i.e.
774 overflow), we just convert to big integers and try again. This
775 could be improved by making r and c the correct values for
776 plugging into a new J#.
778 { r = ((I_)(a)) + ((I_)(b)); \
779 c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
780 >> (BITS_IN (I_) - 1); \
782 Wading through the mass of bracketry, it seems to reduce to:
783 c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
790 c = t4 >>unsigned BITS_IN(I_)-1
792 = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
793 getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
794 (returnFlt . CSequential) [
795 CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
796 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
797 CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
798 CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
799 CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
801 CMachOpStmt res_c MO_Nat_Shr [t4, bpw1_t] Nothing
805 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
807 #define subIntCzh(r,c,a,b) \
808 { r = ((I_)(a)) - ((I_)(b)); \
809 c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
810 >> (BITS_IN (I_) - 1); \
813 c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
818 c = t3 >>unsigned BITS_IN(I_)-1
820 = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
821 getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
822 (returnFlt . CSequential) [
823 CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
824 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
825 CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
826 CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
828 CMachOpStmt res_c MO_Nat_Shr [t3, bpw1_t] Nothing
832 -- #define parzh(r,node) r = 1
833 dscCOpStmt [res] ParOp [arg] vols
835 (CAssign res (CLit (mkMachInt 1)))
837 -- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
838 dscCOpStmt [res] ReadMutVarOp [mutv] vols
840 (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
842 -- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
843 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
845 (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
848 -- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
849 -- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
850 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
852 (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
854 -- #define writeForeignObjzh(res,datum) \
855 -- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
856 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
858 (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
861 -- #define sizzeofByteArrayzh(r,a) \
862 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
863 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
864 = mkTemp WordRep `thenFlt` \ w ->
865 (returnFlt . CSequential) [
866 CAssign w (mkDerefOff WordRep arg fixedHdrSize),
867 CMachOpStmt w MO_NatU_Mul [w, CBytesPerWord] (Just vols),
871 -- #define sizzeofMutableByteArrayzh(r,a) \
872 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
873 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
874 = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
877 -- #define touchzh(o) /* nothing */
878 dscCOpStmt [] TouchOp [arg] vols
881 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
882 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
883 = mkTemp PtrRep `thenFlt` \ ptr ->
884 (returnFlt . CSequential) [
885 CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
886 CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
890 -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
891 dscCOpStmt [res] StableNameToIntOp [arg] vols
893 (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
895 -- #define eqStableNamezh(r,sn1,sn2) \
896 -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
897 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
898 = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] ->
899 (returnFlt . CSequential) [
900 CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
901 CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
902 CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
905 dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
906 = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] ->
907 (returnFlt . CSequential) [
908 CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
909 CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
910 CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
913 -- #define addrToHValuezh(r,a) r=(P_)a
914 dscCOpStmt [res] AddrToHValueOp [arg] vols
918 -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
920 -- In the unregisterised case, we don't attempt to compute the location
921 -- of the tag halfword, just a macro. For this build, fixing on layout
922 -- info has only got drawbacks.
924 -- Should this arrangement deeply offend you for some reason, code which
925 -- computes the offset can be found below also.
928 dscCOpStmt [res] DataToTagOp [arg] vols
929 | not tablesNextToCode
930 = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
932 = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
933 mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
934 (returnFlt . CSequential) [
935 CAssign t_infoptr (mkDerefOff PtrRep arg 0),
937 Get at the tag within the info table; two cases to consider:
939 - reversed info tables next to the entry point code;
940 one word above the end of the info table (which is
941 what t_infoptr is really pointing to).
942 - info tables with their entry points stored somewhere else,
943 which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
946 The t_infoptr points to the start of the info table, so add
947 the length of the info table & subtract one word.
949 CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
950 {- UNUSED - see above comment.
951 (if opt_Unregisterised then
959 {- Freezing arrays-of-ptrs requires changing an info table, for the
960 benefit of the generational collector. It needs to scavenge mutable
961 objects, even if they are in old space. When they become immutable,
962 they can be removed from this scavenge list. -}
964 -- #define unsafeFreezzeArrayzh(r,a) \
966 -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
969 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
970 = (returnFlt . CSequential) [
971 CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
975 -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
976 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
980 -- This ought to be trivial, but it's difficult to insert the casts
981 -- required to keep the C compiler happy.
982 dscCOpStmt [r] AddrRemOp [a1,a2] vols
983 = mkTemp WordRep `thenFlt` \ a1casted ->
984 (returnFlt . CSequential) [
985 CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
986 CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
989 -- not handled by translateOp because they need casts
990 dscCOpStmt [r] SllOp [a1,a2] vols
991 = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
992 dscCOpStmt [r] SrlOp [a1,a2] vols
993 = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
995 dscCOpStmt [r] ISllOp [a1,a2] vols
996 = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
997 dscCOpStmt [r] ISrlOp [a1,a2] vols
998 = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
999 dscCOpStmt [r] ISraOp [a1,a2] vols
1000 = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
1002 -- Reading/writing pointer arrays
1004 dscCOpStmt [r] ReadArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
1005 dscCOpStmt [r] IndexArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
1006 dscCOpStmt [] WriteArrayOp [obj,ix,v] vols = doWritePtrArrayOp obj ix v
1008 -- IndexXXXoffForeignObj
1010 dscCOpStmt [r] IndexOffForeignObjOp_Char [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
1011 dscCOpStmt [r] IndexOffForeignObjOp_WideChar [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1012 dscCOpStmt [r] IndexOffForeignObjOp_Int [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
1013 dscCOpStmt [r] IndexOffForeignObjOp_Word [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
1014 dscCOpStmt [r] IndexOffForeignObjOp_Addr [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
1015 dscCOpStmt [r] IndexOffForeignObjOp_Float [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
1016 dscCOpStmt [r] IndexOffForeignObjOp_Double [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
1017 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
1019 dscCOpStmt [r] IndexOffForeignObjOp_Int8 [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep r a i
1020 dscCOpStmt [r] IndexOffForeignObjOp_Int16 [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
1021 dscCOpStmt [r] IndexOffForeignObjOp_Int32 [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
1022 dscCOpStmt [r] IndexOffForeignObjOp_Int64 [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
1024 dscCOpStmt [r] IndexOffForeignObjOp_Word8 [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep r a i
1025 dscCOpStmt [r] IndexOffForeignObjOp_Word16 [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
1026 dscCOpStmt [r] IndexOffForeignObjOp_Word32 [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1027 dscCOpStmt [r] IndexOffForeignObjOp_Word64 [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
1031 dscCOpStmt [r] IndexOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1032 dscCOpStmt [r] IndexOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1033 dscCOpStmt [r] IndexOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1034 dscCOpStmt [r] IndexOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1035 dscCOpStmt [r] IndexOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1036 dscCOpStmt [r] IndexOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1037 dscCOpStmt [r] IndexOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1038 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1040 dscCOpStmt [r] IndexOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1041 dscCOpStmt [r] IndexOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1042 dscCOpStmt [r] IndexOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1043 dscCOpStmt [r] IndexOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1045 dscCOpStmt [r] IndexOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1046 dscCOpStmt [r] IndexOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1047 dscCOpStmt [r] IndexOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1048 dscCOpStmt [r] IndexOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1050 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1052 dscCOpStmt [r] ReadOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1053 dscCOpStmt [r] ReadOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1054 dscCOpStmt [r] ReadOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1055 dscCOpStmt [r] ReadOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1056 dscCOpStmt [r] ReadOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1057 dscCOpStmt [r] ReadOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1058 dscCOpStmt [r] ReadOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1059 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1061 dscCOpStmt [r] ReadOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1062 dscCOpStmt [r] ReadOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1063 dscCOpStmt [r] ReadOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1064 dscCOpStmt [r] ReadOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1066 dscCOpStmt [r] ReadOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1067 dscCOpStmt [r] ReadOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1068 dscCOpStmt [r] ReadOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1069 dscCOpStmt [r] ReadOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1073 dscCOpStmt [r] IndexByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1074 dscCOpStmt [r] IndexByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1075 dscCOpStmt [r] IndexByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1076 dscCOpStmt [r] IndexByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1077 dscCOpStmt [r] IndexByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1078 dscCOpStmt [r] IndexByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1079 dscCOpStmt [r] IndexByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1080 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1082 dscCOpStmt [r] IndexByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1083 dscCOpStmt [r] IndexByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1084 dscCOpStmt [r] IndexByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1085 dscCOpStmt [r] IndexByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1087 dscCOpStmt [r] IndexByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1088 dscCOpStmt [r] IndexByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1089 dscCOpStmt [r] IndexByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1090 dscCOpStmt [r] IndexByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1092 -- ReadXXXArray, identical to IndexXXXArray.
1094 dscCOpStmt [r] ReadByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1095 dscCOpStmt [r] ReadByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1096 dscCOpStmt [r] ReadByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1097 dscCOpStmt [r] ReadByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1098 dscCOpStmt [r] ReadByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1099 dscCOpStmt [r] ReadByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1100 dscCOpStmt [r] ReadByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1101 dscCOpStmt [r] ReadByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1103 dscCOpStmt [r] ReadByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1104 dscCOpStmt [r] ReadByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1105 dscCOpStmt [r] ReadByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1106 dscCOpStmt [r] ReadByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1108 dscCOpStmt [r] ReadByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1109 dscCOpStmt [r] ReadByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1110 dscCOpStmt [r] ReadByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1111 dscCOpStmt [r] ReadByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1115 dscCOpStmt [] WriteOffAddrOp_Char [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1116 dscCOpStmt [] WriteOffAddrOp_WideChar [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1117 dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1118 dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1119 dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1120 dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1121 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x
1122 dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1123 dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1125 dscCOpStmt [] WriteOffAddrOp_Int8 [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep a i x
1126 dscCOpStmt [] WriteOffAddrOp_Int16 [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1127 dscCOpStmt [] WriteOffAddrOp_Int32 [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1128 dscCOpStmt [] WriteOffAddrOp_Int64 [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1130 dscCOpStmt [] WriteOffAddrOp_Word8 [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep a i x
1131 dscCOpStmt [] WriteOffAddrOp_Word16 [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1132 dscCOpStmt [] WriteOffAddrOp_Word32 [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1133 dscCOpStmt [] WriteOffAddrOp_Word64 [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1137 dscCOpStmt [] WriteByteArrayOp_Char [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1138 dscCOpStmt [] WriteByteArrayOp_WideChar [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1139 dscCOpStmt [] WriteByteArrayOp_Int [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1140 dscCOpStmt [] WriteByteArrayOp_Word [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1141 dscCOpStmt [] WriteByteArrayOp_Addr [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1142 dscCOpStmt [] WriteByteArrayOp_Float [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1143 dscCOpStmt [] WriteByteArrayOp_Double [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1144 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1146 dscCOpStmt [] WriteByteArrayOp_Int8 [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep a i x
1147 dscCOpStmt [] WriteByteArrayOp_Int16 [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep a i x
1148 dscCOpStmt [] WriteByteArrayOp_Int32 [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep a i x
1149 dscCOpStmt [] WriteByteArrayOp_Int64 [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep a i x
1151 dscCOpStmt [] WriteByteArrayOp_Word8 [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep a i x
1152 dscCOpStmt [] WriteByteArrayOp_Word16 [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep a i x
1153 dscCOpStmt [] WriteByteArrayOp_Word32 [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1154 dscCOpStmt [] WriteByteArrayOp_Word64 [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep a i x
1157 -- Handle all others as simply as possible.
1158 dscCOpStmt ress op args vols
1159 = case translateOp ress op args of
1161 -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1162 Just (maybe_res, mop, args)
1164 CMachOpStmt maybe_res mop args
1165 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1168 -- Native word signless ops
1170 translateOp [r] IntAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1171 translateOp [r] IntSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1172 translateOp [r] WordAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1173 translateOp [r] WordSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1174 translateOp [r] AddrAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1175 translateOp [r] AddrSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1177 translateOp [r] IntEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1178 translateOp [r] IntNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1179 translateOp [r] WordEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1180 translateOp [r] WordNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1181 translateOp [r] AddrEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1182 translateOp [r] AddrNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1184 translateOp [r] AndOp [a1,a2] = Just (r, MO_Nat_And, [a1,a2])
1185 translateOp [r] OrOp [a1,a2] = Just (r, MO_Nat_Or, [a1,a2])
1186 translateOp [r] XorOp [a1,a2] = Just (r, MO_Nat_Xor, [a1,a2])
1187 translateOp [r] NotOp [a1] = Just (r, MO_Nat_Not, [a1])
1189 -- Native word signed ops
1191 translateOp [r] IntMulOp [a1,a2] = Just (r, MO_NatS_Mul, [a1,a2])
1192 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1193 translateOp [r] IntQuotOp [a1,a2] = Just (r, MO_NatS_Quot, [a1,a2])
1194 translateOp [r] IntRemOp [a1,a2] = Just (r, MO_NatS_Rem, [a1,a2])
1195 translateOp [r] IntNegOp [a1] = Just (r, MO_NatS_Neg, [a1])
1197 translateOp [r] IntGeOp [a1,a2] = Just (r, MO_NatS_Ge, [a1,a2])
1198 translateOp [r] IntLeOp [a1,a2] = Just (r, MO_NatS_Le, [a1,a2])
1199 translateOp [r] IntGtOp [a1,a2] = Just (r, MO_NatS_Gt, [a1,a2])
1200 translateOp [r] IntLtOp [a1,a2] = Just (r, MO_NatS_Lt, [a1,a2])
1203 -- Native word unsigned ops
1205 translateOp [r] WordGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1206 translateOp [r] WordLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1207 translateOp [r] WordGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1208 translateOp [r] WordLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1210 translateOp [r] WordMulOp [a1,a2] = Just (r, MO_NatU_Mul, [a1,a2])
1211 translateOp [r] WordQuotOp [a1,a2] = Just (r, MO_NatU_Quot, [a1,a2])
1212 translateOp [r] WordRemOp [a1,a2] = Just (r, MO_NatU_Rem, [a1,a2])
1214 translateOp [r] AddrGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1215 translateOp [r] AddrLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1216 translateOp [r] AddrGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1217 translateOp [r] AddrLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1219 -- 32-bit unsigned ops
1221 translateOp [r] CharEqOp [a1,a2] = Just (r, MO_32U_Eq, [a1,a2])
1222 translateOp [r] CharNeOp [a1,a2] = Just (r, MO_32U_Ne, [a1,a2])
1223 translateOp [r] CharGeOp [a1,a2] = Just (r, MO_32U_Ge, [a1,a2])
1224 translateOp [r] CharLeOp [a1,a2] = Just (r, MO_32U_Le, [a1,a2])
1225 translateOp [r] CharGtOp [a1,a2] = Just (r, MO_32U_Gt, [a1,a2])
1226 translateOp [r] CharLtOp [a1,a2] = Just (r, MO_32U_Lt, [a1,a2])
1230 translateOp [r] DoubleEqOp [a1,a2] = Just (r, MO_Dbl_Eq, [a1,a2])
1231 translateOp [r] DoubleNeOp [a1,a2] = Just (r, MO_Dbl_Ne, [a1,a2])
1232 translateOp [r] DoubleGeOp [a1,a2] = Just (r, MO_Dbl_Ge, [a1,a2])
1233 translateOp [r] DoubleLeOp [a1,a2] = Just (r, MO_Dbl_Le, [a1,a2])
1234 translateOp [r] DoubleGtOp [a1,a2] = Just (r, MO_Dbl_Gt, [a1,a2])
1235 translateOp [r] DoubleLtOp [a1,a2] = Just (r, MO_Dbl_Lt, [a1,a2])
1237 translateOp [r] DoubleAddOp [a1,a2] = Just (r, MO_Dbl_Add, [a1,a2])
1238 translateOp [r] DoubleSubOp [a1,a2] = Just (r, MO_Dbl_Sub, [a1,a2])
1239 translateOp [r] DoubleMulOp [a1,a2] = Just (r, MO_Dbl_Mul, [a1,a2])
1240 translateOp [r] DoubleDivOp [a1,a2] = Just (r, MO_Dbl_Div, [a1,a2])
1241 translateOp [r] DoublePowerOp [a1,a2] = Just (r, MO_Dbl_Pwr, [a1,a2])
1243 translateOp [r] DoubleSinOp [a1] = Just (r, MO_Dbl_Sin, [a1])
1244 translateOp [r] DoubleCosOp [a1] = Just (r, MO_Dbl_Cos, [a1])
1245 translateOp [r] DoubleTanOp [a1] = Just (r, MO_Dbl_Tan, [a1])
1246 translateOp [r] DoubleSinhOp [a1] = Just (r, MO_Dbl_Sinh, [a1])
1247 translateOp [r] DoubleCoshOp [a1] = Just (r, MO_Dbl_Cosh, [a1])
1248 translateOp [r] DoubleTanhOp [a1] = Just (r, MO_Dbl_Tanh, [a1])
1249 translateOp [r] DoubleAsinOp [a1] = Just (r, MO_Dbl_Asin, [a1])
1250 translateOp [r] DoubleAcosOp [a1] = Just (r, MO_Dbl_Acos, [a1])
1251 translateOp [r] DoubleAtanOp [a1] = Just (r, MO_Dbl_Atan, [a1])
1252 translateOp [r] DoubleLogOp [a1] = Just (r, MO_Dbl_Log, [a1])
1253 translateOp [r] DoubleExpOp [a1] = Just (r, MO_Dbl_Exp, [a1])
1254 translateOp [r] DoubleSqrtOp [a1] = Just (r, MO_Dbl_Sqrt, [a1])
1255 translateOp [r] DoubleNegOp [a1] = Just (r, MO_Dbl_Neg, [a1])
1259 translateOp [r] FloatEqOp [a1,a2] = Just (r, MO_Flt_Eq, [a1,a2])
1260 translateOp [r] FloatNeOp [a1,a2] = Just (r, MO_Flt_Ne, [a1,a2])
1261 translateOp [r] FloatGeOp [a1,a2] = Just (r, MO_Flt_Ge, [a1,a2])
1262 translateOp [r] FloatLeOp [a1,a2] = Just (r, MO_Flt_Le, [a1,a2])
1263 translateOp [r] FloatGtOp [a1,a2] = Just (r, MO_Flt_Gt, [a1,a2])
1264 translateOp [r] FloatLtOp [a1,a2] = Just (r, MO_Flt_Lt, [a1,a2])
1266 translateOp [r] FloatAddOp [a1,a2] = Just (r, MO_Flt_Add, [a1,a2])
1267 translateOp [r] FloatSubOp [a1,a2] = Just (r, MO_Flt_Sub, [a1,a2])
1268 translateOp [r] FloatMulOp [a1,a2] = Just (r, MO_Flt_Mul, [a1,a2])
1269 translateOp [r] FloatDivOp [a1,a2] = Just (r, MO_Flt_Div, [a1,a2])
1270 translateOp [r] FloatPowerOp [a1,a2] = Just (r, MO_Flt_Pwr, [a1,a2])
1272 translateOp [r] FloatSinOp [a1] = Just (r, MO_Flt_Sin, [a1])
1273 translateOp [r] FloatCosOp [a1] = Just (r, MO_Flt_Cos, [a1])
1274 translateOp [r] FloatTanOp [a1] = Just (r, MO_Flt_Tan, [a1])
1275 translateOp [r] FloatSinhOp [a1] = Just (r, MO_Flt_Sinh, [a1])
1276 translateOp [r] FloatCoshOp [a1] = Just (r, MO_Flt_Cosh, [a1])
1277 translateOp [r] FloatTanhOp [a1] = Just (r, MO_Flt_Tanh, [a1])
1278 translateOp [r] FloatAsinOp [a1] = Just (r, MO_Flt_Asin, [a1])
1279 translateOp [r] FloatAcosOp [a1] = Just (r, MO_Flt_Acos, [a1])
1280 translateOp [r] FloatAtanOp [a1] = Just (r, MO_Flt_Atan, [a1])
1281 translateOp [r] FloatLogOp [a1] = Just (r, MO_Flt_Log, [a1])
1282 translateOp [r] FloatExpOp [a1] = Just (r, MO_Flt_Exp, [a1])
1283 translateOp [r] FloatSqrtOp [a1] = Just (r, MO_Flt_Sqrt, [a1])
1284 translateOp [r] FloatNegOp [a1] = Just (r, MO_Flt_Neg, [a1])
1288 translateOp [r] Int2DoubleOp [a1] = Just (r, MO_NatS_to_Dbl, [a1])
1289 translateOp [r] Double2IntOp [a1] = Just (r, MO_Dbl_to_NatS, [a1])
1291 translateOp [r] Int2FloatOp [a1] = Just (r, MO_NatS_to_Flt, [a1])
1292 translateOp [r] Float2IntOp [a1] = Just (r, MO_Flt_to_NatS, [a1])
1294 translateOp [r] Float2DoubleOp [a1] = Just (r, MO_Flt_to_Dbl, [a1])
1295 translateOp [r] Double2FloatOp [a1] = Just (r, MO_Dbl_to_Flt, [a1])
1297 translateOp [r] Int2WordOp [a1] = Just (r, MO_NatS_to_NatU, [a1])
1298 translateOp [r] Word2IntOp [a1] = Just (r, MO_NatU_to_NatS, [a1])
1300 translateOp [r] Int2AddrOp [a1] = Just (r, MO_NatS_to_NatP, [a1])
1301 translateOp [r] Addr2IntOp [a1] = Just (r, MO_NatP_to_NatS, [a1])
1303 translateOp [r] OrdOp [a1] = Just (r, MO_32U_to_NatS, [a1])
1304 translateOp [r] ChrOp [a1] = Just (r, MO_NatS_to_32U, [a1])
1306 translateOp [r] Narrow8IntOp [a1] = Just (r, MO_8S_to_NatS, [a1])
1307 translateOp [r] Narrow16IntOp [a1] = Just (r, MO_16S_to_NatS, [a1])
1308 translateOp [r] Narrow32IntOp [a1] = Just (r, MO_32S_to_NatS, [a1])
1310 translateOp [r] Narrow8WordOp [a1] = Just (r, MO_8U_to_NatU, [a1])
1311 translateOp [r] Narrow16WordOp [a1] = Just (r, MO_16U_to_NatU, [a1])
1312 translateOp [r] Narrow32WordOp [a1] = Just (r, MO_32U_to_NatU, [a1])
1314 -- Word comparisons masquerading as more exotic things.
1316 translateOp [r] SameMutVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1317 translateOp [r] SameMVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1318 translateOp [r] SameMutableArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1319 translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1320 translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1321 translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1323 translateOp _ _ _ = Nothing