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"
22 import CLabel ( mkMAP_FROZEN_infoLabel )
23 import Digraph ( stronglyConnComp, SCC(..) )
24 import DataCon ( fIRST_TAG, ConTag )
25 import Literal ( literalPrimRep, mkMachWord, mkMachInt )
26 import PrimRep ( getPrimRepSize, PrimRep(..) )
27 import PrimOp ( PrimOp(..) )
28 import MachOp ( MachOp(..), isDefinitelyInlineMachOp )
29 import Unique ( Unique{-instance Eq-} )
30 import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
32 import CmdLineOpts ( opt_EmitCExternDecls )
33 import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..), Safety(..),
34 isDynamicTarget, isCasmTarget, defaultCCallConv )
35 import StgSyn ( StgOp(..) )
36 import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
38 import Panic ( panic )
41 import Maybe ( isJust )
46 Check if there is any real code in some Abstract~C. If so, return it
47 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
49 It returns the "reduced" code in the Just part so that the work of
50 discarding AbsCNops isn't lost, and so that if the caller uses
51 the reduced version there's less danger of a big tree of AbsCNops getting
52 materialised and causing a space leak.
55 nonemptyAbsC :: AbstractC -> Maybe AbstractC
56 nonemptyAbsC AbsCNop = Nothing
57 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
58 Nothing -> nonemptyAbsC s2
59 Just x -> Just (AbsCStmts x s2)
60 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
63 nonemptyAbsC other = Just other
67 mkAbstractCs :: [AbstractC] -> AbstractC
68 mkAbstractCs [] = AbsCNop
69 mkAbstractCs cs = foldr1 mkAbsCStmts cs
71 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
72 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
73 mkAbsCStmts AbsCNop c = c
74 mkAbsCStmts c AbsCNop = c
75 mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2
77 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
78 = case (case (nonemptyAbsC abc2) of
80 Just d2 -> d2) of { abc2b ->
82 case (nonemptyAbsC abc1) of {
84 Just d1 -> AbsCStmts d1 abc2b
89 Get the sho' 'nuff statements out of an @AbstractC@.
91 mkAbsCStmtList :: AbstractC -> [AbstractC]
93 mkAbsCStmtList absC = mkAbsCStmtList' absC []
95 -- Optimised a la foldr/build!
97 mkAbsCStmtList' AbsCNop r = r
99 mkAbsCStmtList' (AbsCStmts s1 s2) r
100 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
102 mkAbsCStmtList' s@(CSimultaneous c) r
103 = if null (mkAbsCStmtList c) then r else s : r
105 mkAbsCStmtList' other r = other : r
109 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
111 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
112 | isJust (nonemptyAbsC deflt_absc)
113 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
115 = CSwitch scrutinee (adjust rest) first_alt
117 -- it's ok to convert one of the alts into a default if we don't already have
118 -- one, because this is an algebraic case and we're guaranteed that the tag
119 -- will match one of the branches.
120 ((_,first_alt):rest) = tagged_alts
122 -- Adjust the tags in the switch to start at zero.
123 -- This is the convention used by primitive ops which return algebraic
124 -- data types. Why? Because for two-constructor types, zero is faster
125 -- to create and distinguish from 1 than are 1 and 2.
127 -- We also need to convert to Literals to keep the CSwitch happy
129 = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
130 | (tag, abs_c) <- tagged_alts ]
133 %************************************************************************
135 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
137 %************************************************************************
140 magicIdPrimRep BaseReg = PtrRep
141 magicIdPrimRep (VanillaReg kind _) = kind
142 magicIdPrimRep (FloatReg _) = FloatRep
143 magicIdPrimRep (DoubleReg _) = DoubleRep
144 magicIdPrimRep (LongReg kind _) = kind
145 magicIdPrimRep Sp = PtrRep
146 magicIdPrimRep Su = PtrRep
147 magicIdPrimRep SpLim = PtrRep
148 magicIdPrimRep Hp = PtrRep
149 magicIdPrimRep HpLim = PtrRep
150 magicIdPrimRep CurCostCentre = CostCentreRep
151 magicIdPrimRep VoidReg = VoidRep
152 magicIdPrimRep CurrentTSO = ThreadIdRep
153 magicIdPrimRep CurrentNursery = PtrRep
154 magicIdPrimRep HpAlloc = WordRep
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 slow maybe_fast descr)
323 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
324 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
325 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
326 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
329 flatAbsC (CCodeBlock lbl abs_C)
330 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
331 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
333 flatAbsC (CRetDirect uniq slow_code srt liveness)
334 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
336 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
338 flatAbsC (CSwitch discrim alts deflt)
339 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
340 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
342 CSwitch discrim flat_alts flat_def_alt,
343 mkAbstractCs (def_tops : flat_alts_tops)
347 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
348 returnFlt ( (tag, alt_heres), alt_tops )
350 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
351 | is_dynamic -- Emit a typedef if its a dynamic call
352 || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
353 = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
355 is_dynamic = isDynamicTarget target
357 flatAbsC stmt@(CSimultaneous abs_c)
358 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
359 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
360 returnFlt (new_stmts_here, tops)
362 flatAbsC stmt@(CCheck macro amodes code)
363 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
364 returnFlt (CCheck macro amodes code_here, code_tops)
366 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
368 flatAbsC stmt@(CCallProfCtrMacro str amodes)
369 | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
370 | otherwise = returnFlt (stmt, AbsCNop)
372 -- Some statements need no flattening at all:
373 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
374 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
375 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
376 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
377 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
378 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
379 flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop)
380 flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop)
381 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
382 = returnFlt (stmt, AbsCNop)
383 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
384 = dscCOpStmt (filter non_void_amode results) op
385 (filter non_void_amode args) vol_regs
388 COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop!
389 other -> flatAbsC other
391 A gruesome hack for printing the names of inline primops when they
396 = getUniqFlt `thenFlt` \ uu ->
397 flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
403 (CCall (CCallSpec (CasmTarget (_PK_ (mktxt op_str)))
404 defaultCCallConv PlaySafe))
410 = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
413 flatAbsC (CSequential abcs)
414 = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
415 returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
418 -- Some statements only make sense at the top level, so we always float
419 -- them. This probably isn't necessary.
420 flatAbsC stmt@(CStaticClosure _ _ _) = returnFlt (AbsCNop, stmt)
421 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
422 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
423 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
424 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
425 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
426 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
427 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
428 flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
432 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
433 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
434 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
435 returnFlt (Just heres, tops)
438 %************************************************************************
440 \subsection[flat-simultaneous]{Doing things simultaneously}
442 %************************************************************************
445 doSimultaneously :: AbstractC -> FlatM AbstractC
448 Generate code to perform the @CAssign@s and @COpStmt@s in the
449 input simultaneously, using temporary variables when necessary.
451 We use the strongly-connected component algorithm, in which
452 * the vertices are the statements
453 * an edge goes from s1 to s2 iff
454 s1 assigns to something s2 uses
455 that is, if s1 should *follow* s2 in the final order
458 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
459 -- for fast comparison
461 doSimultaneously abs_c
463 enlisted = en_list abs_c
465 case enlisted of -- it's often just one stmt
466 [] -> returnFlt AbsCNop
468 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
470 -- en_list puts all the assignments in a list, filtering out Nops and
471 -- assignments which do nothing
473 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
474 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
475 en_list other = [other]
477 sameAmode :: CAddrMode -> CAddrMode -> Bool
478 -- ToDo: Move this function, or make CAddrMode an instance of Eq
479 -- At the moment we put in just enough to catch the cases we want:
480 -- the second (destination) argument is always a CVal.
481 sameAmode (CReg r1) (CReg r2) = r1 == r2
482 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
483 sameAmode other1 other2 = False
485 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
486 doSimultaneously1 vertices
488 edges = [ (vertex, key1, edges_from stmt1)
489 | vertex@(key1, stmt1) <- vertices
491 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
492 stmt1 `should_follow` stmt2
494 components = stronglyConnComp edges
496 -- do_components deal with one strongly-connected component
497 -- Not cyclic, or singleton? Just do it
498 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
499 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
501 -- Cyclic? Then go via temporaries. Pick one to
502 -- break the loop and try again with the rest.
503 do_component (CyclicSCC ((n,first_stmt) : rest))
504 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
505 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
506 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
508 go_via_temps (CAssign dest src)
509 = getUniqFlt `thenFlt` \ uniq ->
511 the_temp = CTemp uniq (getAmodeRep dest)
513 returnFlt (CAssign the_temp src, CAssign dest the_temp)
515 go_via_temps (COpStmt dests op srcs vol_regs)
516 = getUniqsFlt `thenFlt` \ uniqs ->
518 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
520 returnFlt (COpStmt the_temps op srcs vol_regs,
521 mkAbstractCs (zipWith CAssign dests the_temps))
523 mapFlt do_component components `thenFlt` \ abs_cs ->
524 returnFlt (mkAbstractCs abs_cs)
527 should_follow :: AbstractC -> AbstractC -> Bool
528 (CAssign dest1 _) `should_follow` (CAssign _ src2)
529 = dest1 `conflictsWith` src2
530 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
531 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
532 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
533 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
534 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
535 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
538 @conflictsWith@ tells whether an assignment to its first argument will
539 screw up an access to its second.
542 conflictsWith :: CAddrMode -> CAddrMode -> Bool
543 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
544 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
545 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
546 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
547 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
548 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
550 other1 `conflictsWith` other2 = False
551 -- CAddr and literals are impossible on the LHS of an assignment
553 regConflictsWithRR :: MagicId -> RegRelative -> Bool
555 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True
556 regConflictsWithRR Sp (SpRel _) = True
557 regConflictsWithRR Hp (HpRel _) = True
558 regConflictsWithRR _ _ = False
560 rrConflictsWithRR :: Int -> Int -- Sizes of two things
561 -> RegRelative -> RegRelative -- The two amodes
564 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
569 rr (SpRel o1) (SpRel o2)
570 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
571 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
572 | otherwise = (o1 +# s1) >=# o2 &&
575 rr (NodeRel o1) (NodeRel o2)
576 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
577 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
578 | otherwise = True -- Give up
580 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
582 rr other1 other2 = False
585 %************************************************************************
587 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
589 %************************************************************************
593 -- We begin with some helper functions. The main Dude here is
594 -- dscCOpStmt, defined a little further down.
596 ------------------------------------------------------------------------------
598 -- Assumes no volatiles
600 -- res = arg >> (bits-per-word / 2) when little-endian
602 -- res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
604 -- In other words, if arg had been stored in memory, makes res the
605 -- halfword of arg which would have had the higher address. This is
606 -- why it needs to take into account endianness.
608 mkHalfWord_HIADDR res arg
609 = mkTemp IntRep `thenFlt` \ t_hw_shift ->
610 mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
611 mkTemp WordRep `thenFlt` \ t_hw_mask2 ->
613 = CMachOpStmt t_hw_shift
614 MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing
616 = CMachOpStmt t_hw_mask1
617 MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing
619 = CMachOpStmt t_hw_mask2
620 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
623 = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2,
624 CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
627 = CSequential [ a_hw_shift,
628 CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing
635 mkTemp :: PrimRep -> FlatM CAddrMode
637 = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
639 mkTemps = mapFlt mkTemp
641 -- Sigh. This is done in 3 seperate places. Should be
642 -- commoned up (here, in pprAbsC of COpStmt, and presumably
643 -- somewhere in the NCG).
645 = case getAmodeRep amode of
649 -- Helpers for translating various minor variants of array indexing.
651 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
652 mkDerefOff rep base off
653 = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
655 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
656 mkNoDerefOff rep base off
657 = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
660 -- Generates an address as follows
661 -- base + sizeof(machine_word)*offw + sizeof(rep)*idx
662 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
663 mk_OSBI_addr offw rep base idx
664 = CIndex (CAddr (CIndex base idx rep))
665 (CLit (mkMachWord (fromIntegral offw)))
668 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
669 mk_OSBI_ref offw rep base idx
670 = CVal (mk_OSBI_addr offw rep base idx) rep
673 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
674 = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
676 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
677 = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
679 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
680 = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
682 doReadPtrArrayOp res addr idx
683 = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
686 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
687 = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
689 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
690 = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
692 doWritePtrArrayOp addr idx val
693 = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
697 mkBasicIndexedRead offw Nothing read_rep res base idx
699 CAssign res (mk_OSBI_ref offw read_rep base idx)
701 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
702 = mkTemp read_rep `thenFlt` \ tmp ->
703 (returnFlt . CSequential) [
704 CAssign tmp (mk_OSBI_ref offw read_rep base idx),
705 CMachOpStmt res cast_to_mop [tmp] Nothing
708 mkBasicIndexedWrite offw Nothing write_rep base idx val
710 CAssign (mk_OSBI_ref offw write_rep base idx) val
712 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
713 = mkTemp write_rep `thenFlt` \ tmp ->
714 (returnFlt . CSequential) [
715 CMachOpStmt tmp cast_to_mop [val] Nothing,
716 CAssign (mk_OSBI_ref offw write_rep base idx) tmp
720 -- Simple dyadic op but one for which we need to cast first arg to
721 -- be sure of correctness
722 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
723 = mkTemp cast_arg1_to `thenFlt` \ arg1casted ->
724 (returnFlt . CSequential) [
725 CAssign arg1casted arg1,
726 CMachOpStmt res mop [arg1casted,arg2]
727 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
730 getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode)
732 = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] ->
735 CMachOpStmt t1 MO_Nat_Shl
736 [CBytesPerWord, CLit (mkMachInt 3)] Nothing,
737 CMachOpStmt t2 MO_Nat_Sub
738 [t1, CLit (mkMachInt 1)] Nothing
743 ------------------------------------------------------------------------------
745 -- This is the main top-level desugarer PrimOps into MachOps. First we
746 -- handle various awkward cases specially. The remaining easy cases are
747 -- then handled by translateOp, defined below.
750 dscCOpStmt :: [CAddrMode] -- Results
752 -> [CAddrMode] -- Arguments
753 -> [MagicId] -- Potentially volatile/live registers
754 -- (to save/restore around the op)
758 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
760 With some bit-twiddling, we can define int{Add,Sub}Czh portably in
761 C, and without needing any comparisons. This may not be the
762 fastest way to do it - if you have better code, please send it! --SDM
764 Return : r = a + b, c = 0 if no overflow, 1 on overflow.
766 We currently don't make use of the r value if c is != 0 (i.e.
767 overflow), we just convert to big integers and try again. This
768 could be improved by making r and c the correct values for
769 plugging into a new J#.
771 { r = ((I_)(a)) + ((I_)(b)); \
772 c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
773 >> (BITS_IN (I_) - 1); \
775 Wading through the mass of bracketry, it seems to reduce to:
776 c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
783 c = t4 >>unsigned BITS_IN(I_)-1
785 = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
786 getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
787 (returnFlt . CSequential) [
788 CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
789 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
790 CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
791 CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
792 CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
794 CMachOpStmt res_c MO_Nat_Shr [t4, bpw1_t] Nothing
798 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
800 #define subIntCzh(r,c,a,b) \
801 { r = ((I_)(a)) - ((I_)(b)); \
802 c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
803 >> (BITS_IN (I_) - 1); \
806 c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
811 c = t3 >>unsigned BITS_IN(I_)-1
813 = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
814 getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
815 (returnFlt . CSequential) [
816 CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
817 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
818 CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
819 CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
821 CMachOpStmt res_c MO_Nat_Shr [t3, bpw1_t] Nothing
825 -- #define parzh(r,node) r = 1
826 dscCOpStmt [res] ParOp [arg] vols
828 (CAssign res (CLit (mkMachInt 1)))
830 -- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
831 dscCOpStmt [res] ReadMutVarOp [mutv] vols
833 (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
835 -- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
836 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
838 (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
841 -- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
842 -- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
843 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
845 (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
847 -- #define writeForeignObjzh(res,datum) \
848 -- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
849 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
851 (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
854 -- #define sizzeofByteArrayzh(r,a) \
855 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
856 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
857 = mkTemp WordRep `thenFlt` \ w ->
858 (returnFlt . CSequential) [
859 CAssign w (mkDerefOff WordRep arg fixedHdrSize),
860 CMachOpStmt w MO_NatU_Mul [w, CBytesPerWord] (Just vols),
864 -- #define sizzeofMutableByteArrayzh(r,a) \
865 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
866 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
867 = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
870 -- #define touchzh(o) /* nothing */
871 dscCOpStmt [] TouchOp [arg] vols
874 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
875 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
876 = mkTemp PtrRep `thenFlt` \ ptr ->
877 (returnFlt . CSequential) [
878 CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
879 CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
883 -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
884 dscCOpStmt [res] StableNameToIntOp [arg] vols
886 (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
888 -- #define eqStableNamezh(r,sn1,sn2) \
889 -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
890 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
891 = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] ->
892 (returnFlt . CSequential) [
893 CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
894 CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
895 CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
898 -- #define addrToHValuezh(r,a) r=(P_)a
899 dscCOpStmt [res] AddrToHValueOp [arg] vols
903 -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
904 dscCOpStmt [res] DataToTagOp [arg] vols
905 = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
906 mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
907 (returnFlt . CSequential) [
908 CAssign t_infoptr (mkDerefOff PtrRep arg 0),
909 CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
914 {- Freezing arrays-of-ptrs requires changing an info table, for the
915 benefit of the generational collector. It needs to scavenge mutable
916 objects, even if they are in old space. When they become immutable,
917 they can be removed from this scavenge list. -}
919 -- #define unsafeFreezzeArrayzh(r,a) \
921 -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
924 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
925 = (returnFlt . CSequential) [
926 CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
930 -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
931 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
935 -- This ought to be trivial, but it's difficult to insert the casts
936 -- required to keep the C compiler happy.
937 dscCOpStmt [r] AddrRemOp [a1,a2] vols
938 = mkTemp WordRep `thenFlt` \ a1casted ->
939 (returnFlt . CSequential) [
940 CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
941 CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
944 -- not handled by translateOp because they need casts
945 dscCOpStmt [r] SllOp [a1,a2] vols
946 = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
947 dscCOpStmt [r] SrlOp [a1,a2] vols
948 = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
950 dscCOpStmt [r] ISllOp [a1,a2] vols
951 = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
952 dscCOpStmt [r] ISrlOp [a1,a2] vols
953 = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
954 dscCOpStmt [r] ISraOp [a1,a2] vols
955 = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
957 -- Reading/writing pointer arrays
959 dscCOpStmt [r] ReadArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
960 dscCOpStmt [r] IndexArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
961 dscCOpStmt [] WriteArrayOp [obj,ix,v] vols = doWritePtrArrayOp obj ix v
963 -- IndexXXXoffForeignObj
965 dscCOpStmt [r] IndexOffForeignObjOp_Char [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
966 dscCOpStmt [r] IndexOffForeignObjOp_WideChar [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
967 dscCOpStmt [r] IndexOffForeignObjOp_Int [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
968 dscCOpStmt [r] IndexOffForeignObjOp_Word [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
969 dscCOpStmt [r] IndexOffForeignObjOp_Addr [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
970 dscCOpStmt [r] IndexOffForeignObjOp_Float [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
971 dscCOpStmt [r] IndexOffForeignObjOp_Double [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
972 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
974 dscCOpStmt [r] IndexOffForeignObjOp_Int8 [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep r a i
975 dscCOpStmt [r] IndexOffForeignObjOp_Int16 [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
976 dscCOpStmt [r] IndexOffForeignObjOp_Int32 [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
977 dscCOpStmt [r] IndexOffForeignObjOp_Int64 [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
979 dscCOpStmt [r] IndexOffForeignObjOp_Word8 [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep r a i
980 dscCOpStmt [r] IndexOffForeignObjOp_Word16 [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
981 dscCOpStmt [r] IndexOffForeignObjOp_Word32 [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
982 dscCOpStmt [r] IndexOffForeignObjOp_Word64 [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
986 dscCOpStmt [r] IndexOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
987 dscCOpStmt [r] IndexOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
988 dscCOpStmt [r] IndexOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
989 dscCOpStmt [r] IndexOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
990 dscCOpStmt [r] IndexOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
991 dscCOpStmt [r] IndexOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
992 dscCOpStmt [r] IndexOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
993 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
995 dscCOpStmt [r] IndexOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
996 dscCOpStmt [r] IndexOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
997 dscCOpStmt [r] IndexOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
998 dscCOpStmt [r] IndexOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1000 dscCOpStmt [r] IndexOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1001 dscCOpStmt [r] IndexOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1002 dscCOpStmt [r] IndexOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1003 dscCOpStmt [r] IndexOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1005 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1007 dscCOpStmt [r] ReadOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1008 dscCOpStmt [r] ReadOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1009 dscCOpStmt [r] ReadOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1010 dscCOpStmt [r] ReadOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1011 dscCOpStmt [r] ReadOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1012 dscCOpStmt [r] ReadOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1013 dscCOpStmt [r] ReadOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1014 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1016 dscCOpStmt [r] ReadOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1017 dscCOpStmt [r] ReadOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1018 dscCOpStmt [r] ReadOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1019 dscCOpStmt [r] ReadOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1021 dscCOpStmt [r] ReadOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1022 dscCOpStmt [r] ReadOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1023 dscCOpStmt [r] ReadOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1024 dscCOpStmt [r] ReadOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1028 dscCOpStmt [r] IndexByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1029 dscCOpStmt [r] IndexByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1030 dscCOpStmt [r] IndexByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1031 dscCOpStmt [r] IndexByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1032 dscCOpStmt [r] IndexByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1033 dscCOpStmt [r] IndexByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1034 dscCOpStmt [r] IndexByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1035 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1037 dscCOpStmt [r] IndexByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1038 dscCOpStmt [r] IndexByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1039 dscCOpStmt [r] IndexByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1040 dscCOpStmt [r] IndexByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1042 dscCOpStmt [r] IndexByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1043 dscCOpStmt [r] IndexByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1044 dscCOpStmt [r] IndexByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1045 dscCOpStmt [r] IndexByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1047 -- ReadXXXArray, identical to IndexXXXArray.
1049 dscCOpStmt [r] ReadByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1050 dscCOpStmt [r] ReadByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1051 dscCOpStmt [r] ReadByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1052 dscCOpStmt [r] ReadByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1053 dscCOpStmt [r] ReadByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1054 dscCOpStmt [r] ReadByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1055 dscCOpStmt [r] ReadByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1056 dscCOpStmt [r] ReadByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1058 dscCOpStmt [r] ReadByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1059 dscCOpStmt [r] ReadByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1060 dscCOpStmt [r] ReadByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1061 dscCOpStmt [r] ReadByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1063 dscCOpStmt [r] ReadByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1064 dscCOpStmt [r] ReadByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1065 dscCOpStmt [r] ReadByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1066 dscCOpStmt [r] ReadByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1070 dscCOpStmt [] WriteOffAddrOp_Char [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1071 dscCOpStmt [] WriteOffAddrOp_WideChar [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1072 dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1073 dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1074 dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1075 dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1076 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing ForeignObjRep a i x
1077 dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1078 dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1080 dscCOpStmt [] WriteOffAddrOp_Int8 [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep a i x
1081 dscCOpStmt [] WriteOffAddrOp_Int16 [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1082 dscCOpStmt [] WriteOffAddrOp_Int32 [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1083 dscCOpStmt [] WriteOffAddrOp_Int64 [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1085 dscCOpStmt [] WriteOffAddrOp_Word8 [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep a i x
1086 dscCOpStmt [] WriteOffAddrOp_Word16 [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1087 dscCOpStmt [] WriteOffAddrOp_Word32 [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1088 dscCOpStmt [] WriteOffAddrOp_Word64 [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1092 dscCOpStmt [] WriteByteArrayOp_Char [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1093 dscCOpStmt [] WriteByteArrayOp_WideChar [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1094 dscCOpStmt [] WriteByteArrayOp_Int [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1095 dscCOpStmt [] WriteByteArrayOp_Word [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1096 dscCOpStmt [] WriteByteArrayOp_Addr [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1097 dscCOpStmt [] WriteByteArrayOp_Float [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1098 dscCOpStmt [] WriteByteArrayOp_Double [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1099 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1101 dscCOpStmt [] WriteByteArrayOp_Int8 [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep a i x
1102 dscCOpStmt [] WriteByteArrayOp_Int16 [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep a i x
1103 dscCOpStmt [] WriteByteArrayOp_Int32 [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep a i x
1104 dscCOpStmt [] WriteByteArrayOp_Int64 [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep a i x
1106 dscCOpStmt [] WriteByteArrayOp_Word8 [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep a i x
1107 dscCOpStmt [] WriteByteArrayOp_Word16 [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep a i x
1108 dscCOpStmt [] WriteByteArrayOp_Word32 [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1109 dscCOpStmt [] WriteByteArrayOp_Word64 [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep a i x
1112 -- Handle all others as simply as possible.
1113 dscCOpStmt ress op args vols
1114 = case translateOp ress op args of
1116 -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1117 Just (maybe_res, mop, args)
1119 CMachOpStmt maybe_res mop args
1120 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1123 -- Native word signless ops
1125 translateOp [r] IntAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1126 translateOp [r] IntSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1127 translateOp [r] WordAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1128 translateOp [r] WordSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1129 translateOp [r] AddrAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1130 translateOp [r] AddrSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1132 translateOp [r] IntEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1133 translateOp [r] IntNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1134 translateOp [r] WordEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1135 translateOp [r] WordNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1136 translateOp [r] AddrEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1137 translateOp [r] AddrNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1139 translateOp [r] AndOp [a1,a2] = Just (r, MO_Nat_And, [a1,a2])
1140 translateOp [r] OrOp [a1,a2] = Just (r, MO_Nat_Or, [a1,a2])
1141 translateOp [r] XorOp [a1,a2] = Just (r, MO_Nat_Xor, [a1,a2])
1142 translateOp [r] NotOp [a1] = Just (r, MO_Nat_Not, [a1])
1144 -- Native word signed ops
1146 translateOp [r] IntMulOp [a1,a2] = Just (r, MO_NatS_Mul, [a1,a2])
1147 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1148 translateOp [r] IntQuotOp [a1,a2] = Just (r, MO_NatS_Quot, [a1,a2])
1149 translateOp [r] IntRemOp [a1,a2] = Just (r, MO_NatS_Rem, [a1,a2])
1150 translateOp [r] IntNegOp [a1] = Just (r, MO_NatS_Neg, [a1])
1152 translateOp [r] IntGeOp [a1,a2] = Just (r, MO_NatS_Ge, [a1,a2])
1153 translateOp [r] IntLeOp [a1,a2] = Just (r, MO_NatS_Le, [a1,a2])
1154 translateOp [r] IntGtOp [a1,a2] = Just (r, MO_NatS_Gt, [a1,a2])
1155 translateOp [r] IntLtOp [a1,a2] = Just (r, MO_NatS_Lt, [a1,a2])
1158 -- Native word unsigned ops
1160 translateOp [r] WordGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1161 translateOp [r] WordLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1162 translateOp [r] WordGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1163 translateOp [r] WordLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1165 translateOp [r] WordMulOp [a1,a2] = Just (r, MO_NatU_Mul, [a1,a2])
1166 translateOp [r] WordQuotOp [a1,a2] = Just (r, MO_NatU_Quot, [a1,a2])
1167 translateOp [r] WordRemOp [a1,a2] = Just (r, MO_NatU_Rem, [a1,a2])
1169 translateOp [r] AddrGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1170 translateOp [r] AddrLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1171 translateOp [r] AddrGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1172 translateOp [r] AddrLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1174 -- 32-bit unsigned ops
1176 translateOp [r] CharEqOp [a1,a2] = Just (r, MO_32U_Eq, [a1,a2])
1177 translateOp [r] CharNeOp [a1,a2] = Just (r, MO_32U_Ne, [a1,a2])
1178 translateOp [r] CharGeOp [a1,a2] = Just (r, MO_32U_Ge, [a1,a2])
1179 translateOp [r] CharLeOp [a1,a2] = Just (r, MO_32U_Le, [a1,a2])
1180 translateOp [r] CharGtOp [a1,a2] = Just (r, MO_32U_Gt, [a1,a2])
1181 translateOp [r] CharLtOp [a1,a2] = Just (r, MO_32U_Lt, [a1,a2])
1185 translateOp [r] DoubleEqOp [a1,a2] = Just (r, MO_Dbl_Eq, [a1,a2])
1186 translateOp [r] DoubleNeOp [a1,a2] = Just (r, MO_Dbl_Ne, [a1,a2])
1187 translateOp [r] DoubleGeOp [a1,a2] = Just (r, MO_Dbl_Ge, [a1,a2])
1188 translateOp [r] DoubleLeOp [a1,a2] = Just (r, MO_Dbl_Le, [a1,a2])
1189 translateOp [r] DoubleGtOp [a1,a2] = Just (r, MO_Dbl_Gt, [a1,a2])
1190 translateOp [r] DoubleLtOp [a1,a2] = Just (r, MO_Dbl_Lt, [a1,a2])
1192 translateOp [r] DoubleAddOp [a1,a2] = Just (r, MO_Dbl_Add, [a1,a2])
1193 translateOp [r] DoubleSubOp [a1,a2] = Just (r, MO_Dbl_Sub, [a1,a2])
1194 translateOp [r] DoubleMulOp [a1,a2] = Just (r, MO_Dbl_Mul, [a1,a2])
1195 translateOp [r] DoubleDivOp [a1,a2] = Just (r, MO_Dbl_Div, [a1,a2])
1196 translateOp [r] DoublePowerOp [a1,a2] = Just (r, MO_Dbl_Pwr, [a1,a2])
1198 translateOp [r] DoubleSinOp [a1] = Just (r, MO_Dbl_Sin, [a1])
1199 translateOp [r] DoubleCosOp [a1] = Just (r, MO_Dbl_Cos, [a1])
1200 translateOp [r] DoubleTanOp [a1] = Just (r, MO_Dbl_Tan, [a1])
1201 translateOp [r] DoubleSinhOp [a1] = Just (r, MO_Dbl_Sinh, [a1])
1202 translateOp [r] DoubleCoshOp [a1] = Just (r, MO_Dbl_Cosh, [a1])
1203 translateOp [r] DoubleTanhOp [a1] = Just (r, MO_Dbl_Tanh, [a1])
1204 translateOp [r] DoubleAsinOp [a1] = Just (r, MO_Dbl_Asin, [a1])
1205 translateOp [r] DoubleAcosOp [a1] = Just (r, MO_Dbl_Acos, [a1])
1206 translateOp [r] DoubleAtanOp [a1] = Just (r, MO_Dbl_Atan, [a1])
1207 translateOp [r] DoubleLogOp [a1] = Just (r, MO_Dbl_Log, [a1])
1208 translateOp [r] DoubleExpOp [a1] = Just (r, MO_Dbl_Exp, [a1])
1209 translateOp [r] DoubleSqrtOp [a1] = Just (r, MO_Dbl_Sqrt, [a1])
1210 translateOp [r] DoubleNegOp [a1] = Just (r, MO_Dbl_Neg, [a1])
1214 translateOp [r] FloatEqOp [a1,a2] = Just (r, MO_Flt_Eq, [a1,a2])
1215 translateOp [r] FloatNeOp [a1,a2] = Just (r, MO_Flt_Ne, [a1,a2])
1216 translateOp [r] FloatGeOp [a1,a2] = Just (r, MO_Flt_Ge, [a1,a2])
1217 translateOp [r] FloatLeOp [a1,a2] = Just (r, MO_Flt_Le, [a1,a2])
1218 translateOp [r] FloatGtOp [a1,a2] = Just (r, MO_Flt_Gt, [a1,a2])
1219 translateOp [r] FloatLtOp [a1,a2] = Just (r, MO_Flt_Lt, [a1,a2])
1221 translateOp [r] FloatAddOp [a1,a2] = Just (r, MO_Flt_Add, [a1,a2])
1222 translateOp [r] FloatSubOp [a1,a2] = Just (r, MO_Flt_Sub, [a1,a2])
1223 translateOp [r] FloatMulOp [a1,a2] = Just (r, MO_Flt_Mul, [a1,a2])
1224 translateOp [r] FloatDivOp [a1,a2] = Just (r, MO_Flt_Div, [a1,a2])
1225 translateOp [r] FloatPowerOp [a1,a2] = Just (r, MO_Flt_Pwr, [a1,a2])
1227 translateOp [r] FloatSinOp [a1] = Just (r, MO_Flt_Sin, [a1])
1228 translateOp [r] FloatCosOp [a1] = Just (r, MO_Flt_Cos, [a1])
1229 translateOp [r] FloatTanOp [a1] = Just (r, MO_Flt_Tan, [a1])
1230 translateOp [r] FloatSinhOp [a1] = Just (r, MO_Flt_Sinh, [a1])
1231 translateOp [r] FloatCoshOp [a1] = Just (r, MO_Flt_Cosh, [a1])
1232 translateOp [r] FloatTanhOp [a1] = Just (r, MO_Flt_Tanh, [a1])
1233 translateOp [r] FloatAsinOp [a1] = Just (r, MO_Flt_Asin, [a1])
1234 translateOp [r] FloatAcosOp [a1] = Just (r, MO_Flt_Acos, [a1])
1235 translateOp [r] FloatAtanOp [a1] = Just (r, MO_Flt_Atan, [a1])
1236 translateOp [r] FloatLogOp [a1] = Just (r, MO_Flt_Log, [a1])
1237 translateOp [r] FloatExpOp [a1] = Just (r, MO_Flt_Exp, [a1])
1238 translateOp [r] FloatSqrtOp [a1] = Just (r, MO_Flt_Sqrt, [a1])
1239 translateOp [r] FloatNegOp [a1] = Just (r, MO_Flt_Neg, [a1])
1243 translateOp [r] Int2DoubleOp [a1] = Just (r, MO_NatS_to_Dbl, [a1])
1244 translateOp [r] Double2IntOp [a1] = Just (r, MO_Dbl_to_NatS, [a1])
1246 translateOp [r] Int2FloatOp [a1] = Just (r, MO_NatS_to_Flt, [a1])
1247 translateOp [r] Float2IntOp [a1] = Just (r, MO_Flt_to_NatS, [a1])
1249 translateOp [r] Float2DoubleOp [a1] = Just (r, MO_Flt_to_Dbl, [a1])
1250 translateOp [r] Double2FloatOp [a1] = Just (r, MO_Dbl_to_Flt, [a1])
1252 translateOp [r] Int2WordOp [a1] = Just (r, MO_NatS_to_NatU, [a1])
1253 translateOp [r] Word2IntOp [a1] = Just (r, MO_NatU_to_NatS, [a1])
1255 translateOp [r] Int2AddrOp [a1] = Just (r, MO_NatS_to_NatP, [a1])
1256 translateOp [r] Addr2IntOp [a1] = Just (r, MO_NatP_to_NatS, [a1])
1258 translateOp [r] OrdOp [a1] = Just (r, MO_32U_to_NatS, [a1])
1259 translateOp [r] ChrOp [a1] = Just (r, MO_NatS_to_32U, [a1])
1261 translateOp [r] Narrow8IntOp [a1] = Just (r, MO_8S_to_NatS, [a1])
1262 translateOp [r] Narrow16IntOp [a1] = Just (r, MO_16S_to_NatS, [a1])
1263 translateOp [r] Narrow32IntOp [a1] = Just (r, MO_32S_to_NatS, [a1])
1265 translateOp [r] Narrow8WordOp [a1] = Just (r, MO_8U_to_NatU, [a1])
1266 translateOp [r] Narrow16WordOp [a1] = Just (r, MO_16U_to_NatU, [a1])
1267 translateOp [r] Narrow32WordOp [a1] = Just (r, MO_32U_to_NatU, [a1])
1269 -- Word comparisons masquerading as more exotic things.
1271 translateOp [r] SameMutVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1272 translateOp [r] SameMVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1273 translateOp [r] SameMutableArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1274 translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1275 translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1276 translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1278 translateOp _ _ _ = Nothing