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 Su = PtrRep
148 magicIdPrimRep SpLim = PtrRep
149 magicIdPrimRep Hp = PtrRep
150 magicIdPrimRep HpLim = PtrRep
151 magicIdPrimRep CurCostCentre = CostCentreRep
152 magicIdPrimRep VoidReg = VoidRep
153 magicIdPrimRep CurrentTSO = ThreadIdRep
154 magicIdPrimRep CurrentNursery = PtrRep
155 magicIdPrimRep HpAlloc = WordRep
158 %************************************************************************
160 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
162 %************************************************************************
164 See also the return conventions for unboxed things; currently living
165 in @CgCon@ (next to the constructor return conventions).
167 ToDo: tiny tweaking may be in order
169 getAmodeRep :: CAddrMode -> PrimRep
171 getAmodeRep (CVal _ kind) = kind
172 getAmodeRep (CAddr _) = PtrRep
173 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
174 getAmodeRep (CTemp uniq kind) = kind
175 getAmodeRep (CLbl _ kind) = kind
176 getAmodeRep (CCharLike _) = PtrRep
177 getAmodeRep (CIntLike _) = PtrRep
178 getAmodeRep (CLit lit) = literalPrimRep lit
179 getAmodeRep (CMacroExpr kind _ _) = kind
180 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
183 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
184 location; that is, one which can contain values of various types.
187 mixedTypeLocn :: CAddrMode -> Bool
189 mixedTypeLocn (CVal (NodeRel _) _) = True
190 mixedTypeLocn (CVal (SpRel _) _) = True
191 mixedTypeLocn (CVal (HpRel _) _) = True
192 mixedTypeLocn other = False -- All the rest
195 @mixedPtrLocn@ tells whether an amode identifies a
196 location which can contain values of various pointer types.
199 mixedPtrLocn :: CAddrMode -> Bool
201 mixedPtrLocn (CVal (SpRel _) _) = True
202 mixedPtrLocn other = False -- All the rest
205 %************************************************************************
207 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
209 %************************************************************************
211 The following bits take ``raw'' Abstract~C, which may have all sorts of
212 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
213 @CClosureInfos@ and code for switches are pulled out to the top level.
215 The various functions herein tend to produce
218 A {\em flattened} \tr{<something>} of interest for ``here'', and
220 Some {\em unflattened} Abstract~C statements to be carried up to the
221 top-level. The only real reason (now) that it is unflattened is
222 because it means the recursive flattening can be done in just one
223 place rather than having to remember lots of places.
226 Care is taken to reduce the occurrence of forward references, while still
227 keeping laziness a much as possible. Essentially, this means that:
230 {\em All} the top-level C statements resulting from flattening a
231 particular AbsC statement (whether the latter is nested or not) appear
232 before {\em any} of the code for a subsequent AbsC statement;
234 but stuff nested within any AbsC statement comes
235 out before the code for the statement itself.
238 The ``stuff to be carried up'' always includes a label: a
239 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
240 @CCodeBlock@. The latter turns into a C function, and is never
241 actually produced by the code generator. Rather it always starts life
242 as a @CCodeBlock@ addressing mode; when such an addr mode is
243 flattened, the ``tops'' stuff is a @CCodeBlock@.
246 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
249 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
250 here `mkAbsCStmts` tops }
253 %************************************************************************
255 \subsubsection{Flattening monadery}
257 %************************************************************************
259 The flattener is monadised. It's just a @UniqueSupply@.
262 type FlatM result = UniqSupply -> result
264 initFlt :: UniqSupply -> FlatM a -> a
266 initFlt init_us m = m init_us
268 {-# INLINE thenFlt #-}
269 {-# INLINE returnFlt #-}
271 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
274 = case (splitUniqSupply us) of { (s1, s2) ->
275 case (expr s1) of { result ->
278 returnFlt :: a -> FlatM a
279 returnFlt result us = result
281 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
283 mapFlt f [] = returnFlt []
285 = f x `thenFlt` \ r ->
286 mapFlt f xs `thenFlt` \ rs ->
289 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
291 mapAndUnzipFlt f [] = returnFlt ([],[])
292 mapAndUnzipFlt f (x:xs)
293 = f x `thenFlt` \ (r1, r2) ->
294 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
295 returnFlt (r1:rs1, r2:rs2)
297 getUniqFlt :: FlatM Unique
298 getUniqFlt us = uniqFromSupply us
300 getUniqsFlt :: FlatM [Unique]
301 getUniqsFlt us = uniqsFromSupply us
304 %************************************************************************
306 \subsubsection{Flattening the top level}
308 %************************************************************************
311 flatAbsC :: AbstractC
312 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
313 AbstractC) -- Stuff to put at top level flattened]
315 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
317 flatAbsC (AbsCStmts s1 s2)
318 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
319 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
320 returnFlt (mkAbsCStmts inline_s1 inline_s2,
321 mkAbsCStmts top_s1 top_s2)
323 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
324 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
325 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
326 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
327 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
330 flatAbsC (CCodeBlock lbl abs_C)
331 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
332 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
334 flatAbsC (CRetDirect uniq slow_code srt liveness)
335 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
337 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
339 flatAbsC (CSwitch discrim alts deflt)
340 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
341 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
343 CSwitch discrim flat_alts flat_def_alt,
344 mkAbstractCs (def_tops : flat_alts_tops)
348 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
349 returnFlt ( (tag, alt_heres), alt_tops )
351 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
352 | is_dynamic -- Emit a typedef if its a dynamic call
353 || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
354 = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
356 is_dynamic = isDynamicTarget target
358 flatAbsC stmt@(CSimultaneous abs_c)
359 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
360 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
361 returnFlt (new_stmts_here, tops)
363 flatAbsC stmt@(CCheck macro amodes code)
364 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
365 returnFlt (CCheck macro amodes code_here, code_tops)
367 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
369 flatAbsC stmt@(CCallProfCtrMacro str amodes)
370 | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
371 | otherwise = returnFlt (stmt, AbsCNop)
373 -- Some statements need no flattening at all:
374 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
375 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
376 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
377 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
378 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
379 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
380 flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop)
381 flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop)
382 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
383 = returnFlt (stmt, AbsCNop)
384 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
385 = dscCOpStmt (filter non_void_amode results) op
386 (filter non_void_amode args) vol_regs
389 COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop!
390 other -> flatAbsC other
392 A gruesome hack for printing the names of inline primops when they
397 = getUniqFlt `thenFlt` \ uu ->
398 flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
404 (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
405 defaultCCallConv (PlaySafe False)))
411 = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
414 flatAbsC (CSequential abcs)
415 = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
416 returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
419 -- Some statements only make sense at the top level, so we always float
420 -- them. This probably isn't necessary.
421 flatAbsC stmt@(CStaticClosure _ _ _) = returnFlt (AbsCNop, stmt)
422 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
423 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
424 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
425 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
426 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
427 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
428 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
429 flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt)
433 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
434 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
435 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
436 returnFlt (Just heres, tops)
439 %************************************************************************
441 \subsection[flat-simultaneous]{Doing things simultaneously}
443 %************************************************************************
446 doSimultaneously :: AbstractC -> FlatM AbstractC
449 Generate code to perform the @CAssign@s and @COpStmt@s in the
450 input simultaneously, using temporary variables when necessary.
452 We use the strongly-connected component algorithm, in which
453 * the vertices are the statements
454 * an edge goes from s1 to s2 iff
455 s1 assigns to something s2 uses
456 that is, if s1 should *follow* s2 in the final order
459 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
460 -- for fast comparison
462 doSimultaneously abs_c
464 enlisted = en_list abs_c
466 case enlisted of -- it's often just one stmt
467 [] -> returnFlt AbsCNop
469 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
471 -- en_list puts all the assignments in a list, filtering out Nops and
472 -- assignments which do nothing
474 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
475 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
476 en_list other = [other]
478 sameAmode :: CAddrMode -> CAddrMode -> Bool
479 -- ToDo: Move this function, or make CAddrMode an instance of Eq
480 -- At the moment we put in just enough to catch the cases we want:
481 -- the second (destination) argument is always a CVal.
482 sameAmode (CReg r1) (CReg r2) = r1 == r2
483 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
484 sameAmode other1 other2 = False
486 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
487 doSimultaneously1 vertices
489 edges = [ (vertex, key1, edges_from stmt1)
490 | vertex@(key1, stmt1) <- vertices
492 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
493 stmt1 `should_follow` stmt2
495 components = stronglyConnComp edges
497 -- do_components deal with one strongly-connected component
498 -- Not cyclic, or singleton? Just do it
499 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
500 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
502 -- Cyclic? Then go via temporaries. Pick one to
503 -- break the loop and try again with the rest.
504 do_component (CyclicSCC ((n,first_stmt) : rest))
505 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
506 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
507 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
509 go_via_temps (CAssign dest src)
510 = getUniqFlt `thenFlt` \ uniq ->
512 the_temp = CTemp uniq (getAmodeRep dest)
514 returnFlt (CAssign the_temp src, CAssign dest the_temp)
516 go_via_temps (COpStmt dests op srcs vol_regs)
517 = getUniqsFlt `thenFlt` \ uniqs ->
519 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
521 returnFlt (COpStmt the_temps op srcs vol_regs,
522 mkAbstractCs (zipWith CAssign dests the_temps))
524 mapFlt do_component components `thenFlt` \ abs_cs ->
525 returnFlt (mkAbstractCs abs_cs)
528 should_follow :: AbstractC -> AbstractC -> Bool
529 (CAssign dest1 _) `should_follow` (CAssign _ src2)
530 = dest1 `conflictsWith` src2
531 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
532 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
533 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
534 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
535 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
536 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
539 @conflictsWith@ tells whether an assignment to its first argument will
540 screw up an access to its second.
543 conflictsWith :: CAddrMode -> CAddrMode -> Bool
544 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
545 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
546 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
547 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
548 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
549 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
551 other1 `conflictsWith` other2 = False
552 -- CAddr and literals are impossible on the LHS of an assignment
554 regConflictsWithRR :: MagicId -> RegRelative -> Bool
556 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True
557 regConflictsWithRR Sp (SpRel _) = True
558 regConflictsWithRR Hp (HpRel _) = True
559 regConflictsWithRR _ _ = False
561 rrConflictsWithRR :: Int -> Int -- Sizes of two things
562 -> RegRelative -> RegRelative -- The two amodes
565 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
570 rr (SpRel o1) (SpRel o2)
571 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
572 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
573 | otherwise = (o1 +# s1) >=# o2 &&
576 rr (NodeRel o1) (NodeRel o2)
577 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
578 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
579 | otherwise = True -- Give up
581 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
583 rr other1 other2 = False
586 %************************************************************************
588 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
590 %************************************************************************
594 -- We begin with some helper functions. The main Dude here is
595 -- dscCOpStmt, defined a little further down.
597 ------------------------------------------------------------------------------
599 -- Assumes no volatiles
601 -- res = arg >> (bits-per-word / 2) when little-endian
603 -- res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
605 -- In other words, if arg had been stored in memory, makes res the
606 -- halfword of arg which would have had the higher address. This is
607 -- why it needs to take into account endianness.
609 mkHalfWord_HIADDR res arg
610 = mkTemp IntRep `thenFlt` \ t_hw_shift ->
611 mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
612 mkTemp WordRep `thenFlt` \ t_hw_mask2 ->
614 = CMachOpStmt t_hw_shift
615 MO_Nat_Shl [CBytesPerWord, CLit (mkMachInt 2)] Nothing
617 = CMachOpStmt t_hw_mask1
618 MO_Nat_Shl [CLit (mkMachWord 1), t_hw_shift] Nothing
620 = CMachOpStmt t_hw_mask2
621 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
624 = CSequential [ a_hw_shift, a_hw_mask1, a_hw_mask2,
625 CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
628 = CSequential [ a_hw_shift,
629 CMachOpStmt res MO_Nat_Shr [arg, t_hw_shift] Nothing
636 mkTemp :: PrimRep -> FlatM CAddrMode
638 = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
640 mkTemps = mapFlt mkTemp
642 -- Sigh. This is done in 3 seperate places. Should be
643 -- commoned up (here, in pprAbsC of COpStmt, and presumably
644 -- somewhere in the NCG).
646 = case getAmodeRep amode of
650 -- Helpers for translating various minor variants of array indexing.
652 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
653 mkDerefOff rep base off
654 = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
656 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
657 mkNoDerefOff rep base off
658 = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
661 -- Generates an address as follows
662 -- base + sizeof(machine_word)*offw + sizeof(rep)*idx
663 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
664 mk_OSBI_addr offw rep base idx
665 = CIndex (CAddr (CIndex base idx rep))
666 (CLit (mkMachWord (fromIntegral offw)))
669 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
670 mk_OSBI_ref offw rep base idx
671 = CVal (mk_OSBI_addr offw rep base idx) rep
674 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
675 = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
677 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
678 = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
680 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
681 = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
683 doReadPtrArrayOp res addr idx
684 = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
687 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
688 = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
690 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
691 = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
693 doWritePtrArrayOp addr idx val
694 = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
698 mkBasicIndexedRead offw Nothing read_rep res base idx
700 CAssign res (mk_OSBI_ref offw read_rep base idx)
702 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
703 = mkTemp read_rep `thenFlt` \ tmp ->
704 (returnFlt . CSequential) [
705 CAssign tmp (mk_OSBI_ref offw read_rep base idx),
706 CMachOpStmt res cast_to_mop [tmp] Nothing
709 mkBasicIndexedWrite offw Nothing write_rep base idx val
711 CAssign (mk_OSBI_ref offw write_rep base idx) val
713 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
714 = mkTemp write_rep `thenFlt` \ tmp ->
715 (returnFlt . CSequential) [
716 CMachOpStmt tmp cast_to_mop [val] Nothing,
717 CAssign (mk_OSBI_ref offw write_rep base idx) tmp
721 -- Simple dyadic op but one for which we need to cast first arg to
722 -- be sure of correctness
723 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
724 = mkTemp cast_arg1_to `thenFlt` \ arg1casted ->
725 (returnFlt . CSequential) [
726 CAssign arg1casted arg1,
727 CMachOpStmt res mop [arg1casted,arg2]
728 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
731 getBitsPerWordMinus1 :: FlatM (AbstractC, CAddrMode)
733 = mkTemps [IntRep, IntRep] `thenFlt` \ [t1,t2] ->
736 CMachOpStmt t1 MO_Nat_Shl
737 [CBytesPerWord, CLit (mkMachInt 3)] Nothing,
738 CMachOpStmt t2 MO_Nat_Sub
739 [t1, CLit (mkMachInt 1)] Nothing
744 -- IA64 mangler doesn't place tables next to code
745 tablesNextToCode :: Bool
746 #ifdef ia64_TARGET_ARCH
747 tablesNextToCode = False
749 tablesNextToCode = not opt_Unregisterised
752 ------------------------------------------------------------------------------
754 -- This is the main top-level desugarer PrimOps into MachOps. First we
755 -- handle various awkward cases specially. The remaining easy cases are
756 -- then handled by translateOp, defined below.
759 dscCOpStmt :: [CAddrMode] -- Results
761 -> [CAddrMode] -- Arguments
762 -> [MagicId] -- Potentially volatile/live registers
763 -- (to save/restore around the op)
767 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
769 With some bit-twiddling, we can define int{Add,Sub}Czh portably in
770 C, and without needing any comparisons. This may not be the
771 fastest way to do it - if you have better code, please send it! --SDM
773 Return : r = a + b, c = 0 if no overflow, 1 on overflow.
775 We currently don't make use of the r value if c is != 0 (i.e.
776 overflow), we just convert to big integers and try again. This
777 could be improved by making r and c the correct values for
778 plugging into a new J#.
780 { r = ((I_)(a)) + ((I_)(b)); \
781 c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
782 >> (BITS_IN (I_) - 1); \
784 Wading through the mass of bracketry, it seems to reduce to:
785 c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
792 c = t4 >>unsigned BITS_IN(I_)-1
794 = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
795 getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
796 (returnFlt . CSequential) [
797 CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
798 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
799 CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
800 CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
801 CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
803 CMachOpStmt res_c MO_Nat_Shr [t4, bpw1_t] Nothing
807 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
809 #define subIntCzh(r,c,a,b) \
810 { r = ((I_)(a)) - ((I_)(b)); \
811 c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
812 >> (BITS_IN (I_) - 1); \
815 c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
820 c = t3 >>unsigned BITS_IN(I_)-1
822 = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
823 getBitsPerWordMinus1 `thenFlt` \ (bpw1_code,bpw1_t) ->
824 (returnFlt . CSequential) [
825 CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
826 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
827 CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
828 CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
830 CMachOpStmt res_c MO_Nat_Shr [t3, bpw1_t] Nothing
834 -- #define parzh(r,node) r = 1
835 dscCOpStmt [res] ParOp [arg] vols
837 (CAssign res (CLit (mkMachInt 1)))
839 -- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
840 dscCOpStmt [res] ReadMutVarOp [mutv] vols
842 (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
844 -- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
845 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
847 (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
850 -- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
851 -- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
852 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
854 (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
856 -- #define writeForeignObjzh(res,datum) \
857 -- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
858 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
860 (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
863 -- #define sizzeofByteArrayzh(r,a) \
864 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
865 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
866 = mkTemp WordRep `thenFlt` \ w ->
867 (returnFlt . CSequential) [
868 CAssign w (mkDerefOff WordRep arg fixedHdrSize),
869 CMachOpStmt w MO_NatU_Mul [w, CBytesPerWord] (Just vols),
873 -- #define sizzeofMutableByteArrayzh(r,a) \
874 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
875 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
876 = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
879 -- #define touchzh(o) /* nothing */
880 dscCOpStmt [] TouchOp [arg] vols
883 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
884 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
885 = mkTemp PtrRep `thenFlt` \ ptr ->
886 (returnFlt . CSequential) [
887 CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
888 CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
892 -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
893 dscCOpStmt [res] StableNameToIntOp [arg] vols
895 (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
897 -- #define eqStableNamezh(r,sn1,sn2) \
898 -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
899 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
900 = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] ->
901 (returnFlt . CSequential) [
902 CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
903 CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
904 CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
907 dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
908 = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] ->
909 (returnFlt . CSequential) [
910 CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
911 CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
912 CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
915 -- #define addrToHValuezh(r,a) r=(P_)a
916 dscCOpStmt [res] AddrToHValueOp [arg] vols
920 -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
922 -- In the unregisterised case, we don't attempt to compute the location
923 -- of the tag halfword, just a macro. For this build, fixing on layout
924 -- info has only got drawbacks.
926 -- Should this arrangement deeply offend you for some reason, code which
927 -- computes the offset can be found below also.
930 dscCOpStmt [res] DataToTagOp [arg] vols
931 | not tablesNextToCode
932 = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
934 = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
935 mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
936 (returnFlt . CSequential) [
937 CAssign t_infoptr (mkDerefOff PtrRep arg 0),
939 Get at the tag within the info table; two cases to consider:
941 - reversed info tables next to the entry point code;
942 one word above the end of the info table (which is
943 what t_infoptr is really pointing to).
944 - info tables with their entry points stored somewhere else,
945 which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
948 The t_infoptr points to the start of the info table, so add
949 the length of the info table & subtract one word.
951 CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
952 {- UNUSED - see above comment.
953 (if opt_Unregisterised then
961 {- Freezing arrays-of-ptrs requires changing an info table, for the
962 benefit of the generational collector. It needs to scavenge mutable
963 objects, even if they are in old space. When they become immutable,
964 they can be removed from this scavenge list. -}
966 -- #define unsafeFreezzeArrayzh(r,a) \
968 -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
971 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
972 = (returnFlt . CSequential) [
973 CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
977 -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
978 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
982 -- This ought to be trivial, but it's difficult to insert the casts
983 -- required to keep the C compiler happy.
984 dscCOpStmt [r] AddrRemOp [a1,a2] vols
985 = mkTemp WordRep `thenFlt` \ a1casted ->
986 (returnFlt . CSequential) [
987 CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
988 CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
991 -- not handled by translateOp because they need casts
992 dscCOpStmt [r] SllOp [a1,a2] vols
993 = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
994 dscCOpStmt [r] SrlOp [a1,a2] vols
995 = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
997 dscCOpStmt [r] ISllOp [a1,a2] vols
998 = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
999 dscCOpStmt [r] ISrlOp [a1,a2] vols
1000 = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
1001 dscCOpStmt [r] ISraOp [a1,a2] vols
1002 = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
1004 -- Reading/writing pointer arrays
1006 dscCOpStmt [r] ReadArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
1007 dscCOpStmt [r] IndexArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
1008 dscCOpStmt [] WriteArrayOp [obj,ix,v] vols = doWritePtrArrayOp obj ix v
1010 -- IndexXXXoffForeignObj
1012 dscCOpStmt [r] IndexOffForeignObjOp_Char [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
1013 dscCOpStmt [r] IndexOffForeignObjOp_WideChar [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1014 dscCOpStmt [r] IndexOffForeignObjOp_Int [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
1015 dscCOpStmt [r] IndexOffForeignObjOp_Word [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
1016 dscCOpStmt [r] IndexOffForeignObjOp_Addr [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
1017 dscCOpStmt [r] IndexOffForeignObjOp_Float [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
1018 dscCOpStmt [r] IndexOffForeignObjOp_Double [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
1019 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
1021 dscCOpStmt [r] IndexOffForeignObjOp_Int8 [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep r a i
1022 dscCOpStmt [r] IndexOffForeignObjOp_Int16 [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
1023 dscCOpStmt [r] IndexOffForeignObjOp_Int32 [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
1024 dscCOpStmt [r] IndexOffForeignObjOp_Int64 [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
1026 dscCOpStmt [r] IndexOffForeignObjOp_Word8 [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep r a i
1027 dscCOpStmt [r] IndexOffForeignObjOp_Word16 [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
1028 dscCOpStmt [r] IndexOffForeignObjOp_Word32 [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1029 dscCOpStmt [r] IndexOffForeignObjOp_Word64 [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
1033 dscCOpStmt [r] IndexOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1034 dscCOpStmt [r] IndexOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1035 dscCOpStmt [r] IndexOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1036 dscCOpStmt [r] IndexOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1037 dscCOpStmt [r] IndexOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1038 dscCOpStmt [r] IndexOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1039 dscCOpStmt [r] IndexOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1040 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1042 dscCOpStmt [r] IndexOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1043 dscCOpStmt [r] IndexOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1044 dscCOpStmt [r] IndexOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1045 dscCOpStmt [r] IndexOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1047 dscCOpStmt [r] IndexOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1048 dscCOpStmt [r] IndexOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1049 dscCOpStmt [r] IndexOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1050 dscCOpStmt [r] IndexOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1052 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1054 dscCOpStmt [r] ReadOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1055 dscCOpStmt [r] ReadOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1056 dscCOpStmt [r] ReadOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1057 dscCOpStmt [r] ReadOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1058 dscCOpStmt [r] ReadOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1059 dscCOpStmt [r] ReadOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1060 dscCOpStmt [r] ReadOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1061 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1063 dscCOpStmt [r] ReadOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1064 dscCOpStmt [r] ReadOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1065 dscCOpStmt [r] ReadOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1066 dscCOpStmt [r] ReadOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1068 dscCOpStmt [r] ReadOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1069 dscCOpStmt [r] ReadOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1070 dscCOpStmt [r] ReadOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1071 dscCOpStmt [r] ReadOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1075 dscCOpStmt [r] IndexByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1076 dscCOpStmt [r] IndexByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1077 dscCOpStmt [r] IndexByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1078 dscCOpStmt [r] IndexByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1079 dscCOpStmt [r] IndexByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1080 dscCOpStmt [r] IndexByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1081 dscCOpStmt [r] IndexByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1082 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1084 dscCOpStmt [r] IndexByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1085 dscCOpStmt [r] IndexByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1086 dscCOpStmt [r] IndexByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1087 dscCOpStmt [r] IndexByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1089 dscCOpStmt [r] IndexByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1090 dscCOpStmt [r] IndexByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1091 dscCOpStmt [r] IndexByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1092 dscCOpStmt [r] IndexByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1094 -- ReadXXXArray, identical to IndexXXXArray.
1096 dscCOpStmt [r] ReadByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1097 dscCOpStmt [r] ReadByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1098 dscCOpStmt [r] ReadByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1099 dscCOpStmt [r] ReadByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1100 dscCOpStmt [r] ReadByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1101 dscCOpStmt [r] ReadByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1102 dscCOpStmt [r] ReadByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1103 dscCOpStmt [r] ReadByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1105 dscCOpStmt [r] ReadByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1106 dscCOpStmt [r] ReadByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1107 dscCOpStmt [r] ReadByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1108 dscCOpStmt [r] ReadByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1110 dscCOpStmt [r] ReadByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1111 dscCOpStmt [r] ReadByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1112 dscCOpStmt [r] ReadByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1113 dscCOpStmt [r] ReadByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1117 dscCOpStmt [] WriteOffAddrOp_Char [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1118 dscCOpStmt [] WriteOffAddrOp_WideChar [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1119 dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1120 dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1121 dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1122 dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1123 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing ForeignObjRep a i x
1124 dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1125 dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1127 dscCOpStmt [] WriteOffAddrOp_Int8 [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep a i x
1128 dscCOpStmt [] WriteOffAddrOp_Int16 [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1129 dscCOpStmt [] WriteOffAddrOp_Int32 [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1130 dscCOpStmt [] WriteOffAddrOp_Int64 [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1132 dscCOpStmt [] WriteOffAddrOp_Word8 [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep a i x
1133 dscCOpStmt [] WriteOffAddrOp_Word16 [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1134 dscCOpStmt [] WriteOffAddrOp_Word32 [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1135 dscCOpStmt [] WriteOffAddrOp_Word64 [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1139 dscCOpStmt [] WriteByteArrayOp_Char [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1140 dscCOpStmt [] WriteByteArrayOp_WideChar [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1141 dscCOpStmt [] WriteByteArrayOp_Int [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1142 dscCOpStmt [] WriteByteArrayOp_Word [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1143 dscCOpStmt [] WriteByteArrayOp_Addr [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1144 dscCOpStmt [] WriteByteArrayOp_Float [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1145 dscCOpStmt [] WriteByteArrayOp_Double [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1146 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1148 dscCOpStmt [] WriteByteArrayOp_Int8 [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep a i x
1149 dscCOpStmt [] WriteByteArrayOp_Int16 [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep a i x
1150 dscCOpStmt [] WriteByteArrayOp_Int32 [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep a i x
1151 dscCOpStmt [] WriteByteArrayOp_Int64 [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep a i x
1153 dscCOpStmt [] WriteByteArrayOp_Word8 [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep a i x
1154 dscCOpStmt [] WriteByteArrayOp_Word16 [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep a i x
1155 dscCOpStmt [] WriteByteArrayOp_Word32 [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1156 dscCOpStmt [] WriteByteArrayOp_Word64 [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep a i x
1159 -- Handle all others as simply as possible.
1160 dscCOpStmt ress op args vols
1161 = case translateOp ress op args of
1163 -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1164 Just (maybe_res, mop, args)
1166 CMachOpStmt maybe_res mop args
1167 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1170 -- Native word signless ops
1172 translateOp [r] IntAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1173 translateOp [r] IntSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1174 translateOp [r] WordAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1175 translateOp [r] WordSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1176 translateOp [r] AddrAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1177 translateOp [r] AddrSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1179 translateOp [r] IntEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1180 translateOp [r] IntNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1181 translateOp [r] WordEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1182 translateOp [r] WordNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1183 translateOp [r] AddrEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1184 translateOp [r] AddrNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1186 translateOp [r] AndOp [a1,a2] = Just (r, MO_Nat_And, [a1,a2])
1187 translateOp [r] OrOp [a1,a2] = Just (r, MO_Nat_Or, [a1,a2])
1188 translateOp [r] XorOp [a1,a2] = Just (r, MO_Nat_Xor, [a1,a2])
1189 translateOp [r] NotOp [a1] = Just (r, MO_Nat_Not, [a1])
1191 -- Native word signed ops
1193 translateOp [r] IntMulOp [a1,a2] = Just (r, MO_NatS_Mul, [a1,a2])
1194 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1195 translateOp [r] IntQuotOp [a1,a2] = Just (r, MO_NatS_Quot, [a1,a2])
1196 translateOp [r] IntRemOp [a1,a2] = Just (r, MO_NatS_Rem, [a1,a2])
1197 translateOp [r] IntNegOp [a1] = Just (r, MO_NatS_Neg, [a1])
1199 translateOp [r] IntGeOp [a1,a2] = Just (r, MO_NatS_Ge, [a1,a2])
1200 translateOp [r] IntLeOp [a1,a2] = Just (r, MO_NatS_Le, [a1,a2])
1201 translateOp [r] IntGtOp [a1,a2] = Just (r, MO_NatS_Gt, [a1,a2])
1202 translateOp [r] IntLtOp [a1,a2] = Just (r, MO_NatS_Lt, [a1,a2])
1205 -- Native word unsigned ops
1207 translateOp [r] WordGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1208 translateOp [r] WordLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1209 translateOp [r] WordGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1210 translateOp [r] WordLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1212 translateOp [r] WordMulOp [a1,a2] = Just (r, MO_NatU_Mul, [a1,a2])
1213 translateOp [r] WordQuotOp [a1,a2] = Just (r, MO_NatU_Quot, [a1,a2])
1214 translateOp [r] WordRemOp [a1,a2] = Just (r, MO_NatU_Rem, [a1,a2])
1216 translateOp [r] AddrGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1217 translateOp [r] AddrLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1218 translateOp [r] AddrGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1219 translateOp [r] AddrLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1221 -- 32-bit unsigned ops
1223 translateOp [r] CharEqOp [a1,a2] = Just (r, MO_32U_Eq, [a1,a2])
1224 translateOp [r] CharNeOp [a1,a2] = Just (r, MO_32U_Ne, [a1,a2])
1225 translateOp [r] CharGeOp [a1,a2] = Just (r, MO_32U_Ge, [a1,a2])
1226 translateOp [r] CharLeOp [a1,a2] = Just (r, MO_32U_Le, [a1,a2])
1227 translateOp [r] CharGtOp [a1,a2] = Just (r, MO_32U_Gt, [a1,a2])
1228 translateOp [r] CharLtOp [a1,a2] = Just (r, MO_32U_Lt, [a1,a2])
1232 translateOp [r] DoubleEqOp [a1,a2] = Just (r, MO_Dbl_Eq, [a1,a2])
1233 translateOp [r] DoubleNeOp [a1,a2] = Just (r, MO_Dbl_Ne, [a1,a2])
1234 translateOp [r] DoubleGeOp [a1,a2] = Just (r, MO_Dbl_Ge, [a1,a2])
1235 translateOp [r] DoubleLeOp [a1,a2] = Just (r, MO_Dbl_Le, [a1,a2])
1236 translateOp [r] DoubleGtOp [a1,a2] = Just (r, MO_Dbl_Gt, [a1,a2])
1237 translateOp [r] DoubleLtOp [a1,a2] = Just (r, MO_Dbl_Lt, [a1,a2])
1239 translateOp [r] DoubleAddOp [a1,a2] = Just (r, MO_Dbl_Add, [a1,a2])
1240 translateOp [r] DoubleSubOp [a1,a2] = Just (r, MO_Dbl_Sub, [a1,a2])
1241 translateOp [r] DoubleMulOp [a1,a2] = Just (r, MO_Dbl_Mul, [a1,a2])
1242 translateOp [r] DoubleDivOp [a1,a2] = Just (r, MO_Dbl_Div, [a1,a2])
1243 translateOp [r] DoublePowerOp [a1,a2] = Just (r, MO_Dbl_Pwr, [a1,a2])
1245 translateOp [r] DoubleSinOp [a1] = Just (r, MO_Dbl_Sin, [a1])
1246 translateOp [r] DoubleCosOp [a1] = Just (r, MO_Dbl_Cos, [a1])
1247 translateOp [r] DoubleTanOp [a1] = Just (r, MO_Dbl_Tan, [a1])
1248 translateOp [r] DoubleSinhOp [a1] = Just (r, MO_Dbl_Sinh, [a1])
1249 translateOp [r] DoubleCoshOp [a1] = Just (r, MO_Dbl_Cosh, [a1])
1250 translateOp [r] DoubleTanhOp [a1] = Just (r, MO_Dbl_Tanh, [a1])
1251 translateOp [r] DoubleAsinOp [a1] = Just (r, MO_Dbl_Asin, [a1])
1252 translateOp [r] DoubleAcosOp [a1] = Just (r, MO_Dbl_Acos, [a1])
1253 translateOp [r] DoubleAtanOp [a1] = Just (r, MO_Dbl_Atan, [a1])
1254 translateOp [r] DoubleLogOp [a1] = Just (r, MO_Dbl_Log, [a1])
1255 translateOp [r] DoubleExpOp [a1] = Just (r, MO_Dbl_Exp, [a1])
1256 translateOp [r] DoubleSqrtOp [a1] = Just (r, MO_Dbl_Sqrt, [a1])
1257 translateOp [r] DoubleNegOp [a1] = Just (r, MO_Dbl_Neg, [a1])
1261 translateOp [r] FloatEqOp [a1,a2] = Just (r, MO_Flt_Eq, [a1,a2])
1262 translateOp [r] FloatNeOp [a1,a2] = Just (r, MO_Flt_Ne, [a1,a2])
1263 translateOp [r] FloatGeOp [a1,a2] = Just (r, MO_Flt_Ge, [a1,a2])
1264 translateOp [r] FloatLeOp [a1,a2] = Just (r, MO_Flt_Le, [a1,a2])
1265 translateOp [r] FloatGtOp [a1,a2] = Just (r, MO_Flt_Gt, [a1,a2])
1266 translateOp [r] FloatLtOp [a1,a2] = Just (r, MO_Flt_Lt, [a1,a2])
1268 translateOp [r] FloatAddOp [a1,a2] = Just (r, MO_Flt_Add, [a1,a2])
1269 translateOp [r] FloatSubOp [a1,a2] = Just (r, MO_Flt_Sub, [a1,a2])
1270 translateOp [r] FloatMulOp [a1,a2] = Just (r, MO_Flt_Mul, [a1,a2])
1271 translateOp [r] FloatDivOp [a1,a2] = Just (r, MO_Flt_Div, [a1,a2])
1272 translateOp [r] FloatPowerOp [a1,a2] = Just (r, MO_Flt_Pwr, [a1,a2])
1274 translateOp [r] FloatSinOp [a1] = Just (r, MO_Flt_Sin, [a1])
1275 translateOp [r] FloatCosOp [a1] = Just (r, MO_Flt_Cos, [a1])
1276 translateOp [r] FloatTanOp [a1] = Just (r, MO_Flt_Tan, [a1])
1277 translateOp [r] FloatSinhOp [a1] = Just (r, MO_Flt_Sinh, [a1])
1278 translateOp [r] FloatCoshOp [a1] = Just (r, MO_Flt_Cosh, [a1])
1279 translateOp [r] FloatTanhOp [a1] = Just (r, MO_Flt_Tanh, [a1])
1280 translateOp [r] FloatAsinOp [a1] = Just (r, MO_Flt_Asin, [a1])
1281 translateOp [r] FloatAcosOp [a1] = Just (r, MO_Flt_Acos, [a1])
1282 translateOp [r] FloatAtanOp [a1] = Just (r, MO_Flt_Atan, [a1])
1283 translateOp [r] FloatLogOp [a1] = Just (r, MO_Flt_Log, [a1])
1284 translateOp [r] FloatExpOp [a1] = Just (r, MO_Flt_Exp, [a1])
1285 translateOp [r] FloatSqrtOp [a1] = Just (r, MO_Flt_Sqrt, [a1])
1286 translateOp [r] FloatNegOp [a1] = Just (r, MO_Flt_Neg, [a1])
1290 translateOp [r] Int2DoubleOp [a1] = Just (r, MO_NatS_to_Dbl, [a1])
1291 translateOp [r] Double2IntOp [a1] = Just (r, MO_Dbl_to_NatS, [a1])
1293 translateOp [r] Int2FloatOp [a1] = Just (r, MO_NatS_to_Flt, [a1])
1294 translateOp [r] Float2IntOp [a1] = Just (r, MO_Flt_to_NatS, [a1])
1296 translateOp [r] Float2DoubleOp [a1] = Just (r, MO_Flt_to_Dbl, [a1])
1297 translateOp [r] Double2FloatOp [a1] = Just (r, MO_Dbl_to_Flt, [a1])
1299 translateOp [r] Int2WordOp [a1] = Just (r, MO_NatS_to_NatU, [a1])
1300 translateOp [r] Word2IntOp [a1] = Just (r, MO_NatU_to_NatS, [a1])
1302 translateOp [r] Int2AddrOp [a1] = Just (r, MO_NatS_to_NatP, [a1])
1303 translateOp [r] Addr2IntOp [a1] = Just (r, MO_NatP_to_NatS, [a1])
1305 translateOp [r] OrdOp [a1] = Just (r, MO_32U_to_NatS, [a1])
1306 translateOp [r] ChrOp [a1] = Just (r, MO_NatS_to_32U, [a1])
1308 translateOp [r] Narrow8IntOp [a1] = Just (r, MO_8S_to_NatS, [a1])
1309 translateOp [r] Narrow16IntOp [a1] = Just (r, MO_16S_to_NatS, [a1])
1310 translateOp [r] Narrow32IntOp [a1] = Just (r, MO_32S_to_NatS, [a1])
1312 translateOp [r] Narrow8WordOp [a1] = Just (r, MO_8U_to_NatU, [a1])
1313 translateOp [r] Narrow16WordOp [a1] = Just (r, MO_16U_to_NatU, [a1])
1314 translateOp [r] Narrow32WordOp [a1] = Just (r, MO_32U_to_NatU, [a1])
1316 -- Word comparisons masquerading as more exotic things.
1318 translateOp [r] SameMutVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1319 translateOp [r] SameMVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1320 translateOp [r] SameMutableArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1321 translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1322 translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1323 translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1325 translateOp _ _ _ = Nothing