2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
9 mkAbstractCs, mkAbsCStmts,
13 mixedTypeLocn, mixedPtrLocn,
16 -- printing/forcing stuff comes from PprAbsC
19 #include "HsVersions.h"
20 #include "../includes/config.h"
23 import CLabel ( mkMAP_FROZEN_infoLabel )
24 import Digraph ( stronglyConnComp, SCC(..) )
25 import DataCon ( fIRST_TAG, dataConTag )
26 import Literal ( literalPrimRep, mkMachWord, mkMachInt )
27 import PrimRep ( getPrimRepSize, PrimRep(..) )
28 import PrimOp ( PrimOp(..) )
29 import MachOp ( MachOp(..), isDefinitelyInlineMachOp )
30 import Unique ( Unique{-instance Eq-} )
31 import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
33 import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
34 import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
35 import StgSyn ( StgOp(..) )
36 import CoreSyn ( AltCon(..) )
37 import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
39 import Panic ( panic )
41 import Constants ( wORD_SIZE, wORD_SIZE_IN_BITS )
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 -> [(AltCon, AbstractC)] -> AbstractC
111 mkAlgAltsCSwitch scrutinee ((_,first_alt) : rest_alts)
112 = CSwitch scrutinee (adjust rest_alts) first_alt
114 -- We use the first alt as the default. Either it *is* the DEFAULT,
115 -- (which is always first if present), or the case is exhaustive,
116 -- in which case we can use the first as the default anyway
118 -- Adjust the tags in the switch to start at zero.
119 -- This is the convention used by primitive ops which return algebraic
120 -- data types. Why? Because for two-constructor types, zero is faster
121 -- to create and distinguish from 1 than are 1 and 2.
123 -- We also need to convert to Literals to keep the CSwitch happy
125 = [ (mkMachWord (toInteger (dataConTag dc - fIRST_TAG)), abs_c)
126 | (DataAlt dc, abs_c) <- tagged_alts ]
129 %************************************************************************
131 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
133 %************************************************************************
136 magicIdPrimRep BaseReg = PtrRep
137 magicIdPrimRep (VanillaReg kind _) = kind
138 magicIdPrimRep (FloatReg _) = FloatRep
139 magicIdPrimRep (DoubleReg _) = DoubleRep
140 magicIdPrimRep (LongReg kind _) = kind
141 magicIdPrimRep Sp = PtrRep
142 magicIdPrimRep SpLim = PtrRep
143 magicIdPrimRep Hp = PtrRep
144 magicIdPrimRep HpLim = PtrRep
145 magicIdPrimRep CurCostCentre = CostCentreRep
146 magicIdPrimRep VoidReg = VoidRep
147 magicIdPrimRep CurrentTSO = PtrRep
148 magicIdPrimRep CurrentNursery = PtrRep
149 magicIdPrimRep HpAlloc = WordRep
152 %************************************************************************
154 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
156 %************************************************************************
158 See also the return conventions for unboxed things; currently living
159 in @CgCon@ (next to the constructor return conventions).
161 ToDo: tiny tweaking may be in order
163 getAmodeRep :: CAddrMode -> PrimRep
165 getAmodeRep (CVal _ kind) = kind
166 getAmodeRep (CAddr _) = PtrRep
167 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
168 getAmodeRep (CTemp uniq kind) = kind
169 getAmodeRep (CLbl _ kind) = kind
170 getAmodeRep (CCharLike _) = PtrRep
171 getAmodeRep (CIntLike _) = PtrRep
172 getAmodeRep (CLit lit) = literalPrimRep lit
173 getAmodeRep (CMacroExpr kind _ _) = kind
174 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
177 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
178 location; that is, one which can contain values of various types.
181 mixedTypeLocn :: CAddrMode -> Bool
183 mixedTypeLocn (CVal (NodeRel _) _) = True
184 mixedTypeLocn (CVal (SpRel _) _) = True
185 mixedTypeLocn (CVal (HpRel _) _) = True
186 mixedTypeLocn other = False -- All the rest
189 @mixedPtrLocn@ tells whether an amode identifies a
190 location which can contain values of various pointer types.
193 mixedPtrLocn :: CAddrMode -> Bool
195 mixedPtrLocn (CVal (SpRel _) _) = True
196 mixedPtrLocn other = False -- All the rest
199 %************************************************************************
201 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
203 %************************************************************************
205 The following bits take ``raw'' Abstract~C, which may have all sorts of
206 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
207 @CClosureInfos@ and code for switches are pulled out to the top level.
209 The various functions herein tend to produce
212 A {\em flattened} \tr{<something>} of interest for ``here'', and
214 Some {\em unflattened} Abstract~C statements to be carried up to the
215 top-level. The only real reason (now) that it is unflattened is
216 because it means the recursive flattening can be done in just one
217 place rather than having to remember lots of places.
220 Care is taken to reduce the occurrence of forward references, while still
221 keeping laziness a much as possible. Essentially, this means that:
224 {\em All} the top-level C statements resulting from flattening a
225 particular AbsC statement (whether the latter is nested or not) appear
226 before {\em any} of the code for a subsequent AbsC statement;
228 but stuff nested within any AbsC statement comes
229 out before the code for the statement itself.
232 The ``stuff to be carried up'' always includes a label: a
233 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
234 @CCodeBlock@. The latter turns into a C function, and is never
235 actually produced by the code generator. Rather it always starts life
236 as a @CCodeBlock@ addressing mode; when such an addr mode is
237 flattened, the ``tops'' stuff is a @CCodeBlock@.
240 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
243 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
244 here `mkAbsCStmts` tops }
247 %************************************************************************
249 \subsubsection{Flattening monadery}
251 %************************************************************************
253 The flattener is monadised. It's just a @UniqueSupply@.
256 type FlatM result = UniqSupply -> result
258 initFlt :: UniqSupply -> FlatM a -> a
260 initFlt init_us m = m init_us
262 {-# INLINE thenFlt #-}
263 {-# INLINE returnFlt #-}
265 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
268 = case (splitUniqSupply us) of { (s1, s2) ->
269 case (expr s1) of { result ->
272 returnFlt :: a -> FlatM a
273 returnFlt result us = result
275 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
277 mapFlt f [] = returnFlt []
279 = f x `thenFlt` \ r ->
280 mapFlt f xs `thenFlt` \ rs ->
283 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
285 mapAndUnzipFlt f [] = returnFlt ([],[])
286 mapAndUnzipFlt f (x:xs)
287 = f x `thenFlt` \ (r1, r2) ->
288 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
289 returnFlt (r1:rs1, r2:rs2)
291 getUniqFlt :: FlatM Unique
292 getUniqFlt us = uniqFromSupply us
294 getUniqsFlt :: FlatM [Unique]
295 getUniqsFlt us = uniqsFromSupply us
298 %************************************************************************
300 \subsubsection{Flattening the top level}
302 %************************************************************************
305 flatAbsC :: AbstractC
306 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
307 AbstractC) -- Stuff to put at top level flattened]
309 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
311 flatAbsC (AbsCStmts s1 s2)
312 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
313 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
314 returnFlt (mkAbsCStmts inline_s1 inline_s2,
315 mkAbsCStmts top_s1 top_s2)
317 flatAbsC (CClosureInfoAndCode cl_info entry)
318 = flatAbsC entry `thenFlt` \ (entry_heres, entry_tops) ->
319 returnFlt (AbsCNop, mkAbstractCs [entry_tops,
320 CClosureInfoAndCode cl_info entry_heres]
323 flatAbsC (CCodeBlock lbl abs_C)
324 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
325 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
327 flatAbsC (CRetDirect uniq slow_code srt liveness)
328 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
330 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
332 flatAbsC (CSwitch discrim alts deflt)
333 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
334 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
336 CSwitch discrim flat_alts flat_def_alt,
337 mkAbstractCs (def_tops : flat_alts_tops)
341 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
342 returnFlt ( (tag, alt_heres), alt_tops )
344 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
345 | is_dynamic -- Emit a typedef if its a dynamic call
346 || (opt_EmitCExternDecls) -- or we want extern decls
347 = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
349 is_dynamic = isDynamicTarget target
351 flatAbsC stmt@(CSimultaneous abs_c)
352 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
353 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
354 returnFlt (new_stmts_here, tops)
356 flatAbsC stmt@(CCheck macro amodes code)
357 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
358 returnFlt (CCheck macro amodes code_here, code_tops)
360 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
362 flatAbsC stmt@(CCallProfCtrMacro str amodes)
363 | str == FSLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
364 | otherwise = returnFlt (stmt, AbsCNop)
366 -- Some statements need no flattening at all:
367 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
368 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
369 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
370 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
371 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
372 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
373 flatAbsC stmt@(CInitHdr a b cc sz) = returnFlt (stmt, AbsCNop)
374 flatAbsC stmt@(CMachOpStmt res mop args m_vols) = returnFlt (stmt, AbsCNop)
375 flatAbsC stmt@(COpStmt results (StgFCallOp _ _) args vol_regs)
376 = returnFlt (stmt, AbsCNop)
377 flatAbsC stmt@(COpStmt results (StgPrimOp op) args vol_regs)
378 = dscCOpStmt (filter non_void_amode results) op
379 (filter non_void_amode args) vol_regs
382 COpStmt _ _ _ _ -> panic "flatAbsC - dscCOpStmt" -- make sure we don't loop!
383 other -> flatAbsC other
385 A gruesome hack for printing the names of inline primops when they
390 = getUniqFlt `thenFlt` \ uu ->
391 flatAbsC (CSequential [moo uu (showSDoc (ppr op)), xxx])
397 (CCall (CCallSpec (CasmTarget (mkFastString (mktxt op_str)))
398 defaultCCallConv (PlaySafe False)))
404 = " asm(\"pushal;\"); printf(\"%%s\\n\",\"" ++ op_str ++ "\"); asm(\"popal\"); "
407 flatAbsC (CSequential abcs)
408 = mapAndUnzipFlt flatAbsC abcs `thenFlt` \ (inlines, tops) ->
409 returnFlt (CSequential inlines, foldr AbsCStmts AbsCNop tops)
412 -- Some statements only make sense at the top level, so we always float
413 -- them. This probably isn't necessary.
414 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
415 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
416 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
417 flatAbsC stmt@(CSRTDesc _ _ _ _ _) = returnFlt (AbsCNop, stmt)
418 flatAbsC stmt@(CBitmap _) = returnFlt (AbsCNop, stmt)
419 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
420 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
421 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
422 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
423 flatAbsC stmt@(CModuleInitBlock _ _ _) = returnFlt (AbsCNop, stmt)
427 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
428 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
429 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
430 returnFlt (Just heres, tops)
433 %************************************************************************
435 \subsection[flat-simultaneous]{Doing things simultaneously}
437 %************************************************************************
440 doSimultaneously :: AbstractC -> FlatM AbstractC
443 Generate code to perform the @CAssign@s and @COpStmt@s in the
444 input simultaneously, using temporary variables when necessary.
446 We use the strongly-connected component algorithm, in which
447 * the vertices are the statements
448 * an edge goes from s1 to s2 iff
449 s1 assigns to something s2 uses
450 that is, if s1 should *follow* s2 in the final order
453 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
454 -- for fast comparison
456 doSimultaneously abs_c
458 enlisted = en_list abs_c
460 case enlisted of -- it's often just one stmt
461 [] -> returnFlt AbsCNop
463 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
465 -- en_list puts all the assignments in a list, filtering out Nops and
466 -- assignments which do nothing
468 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
469 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
470 en_list other = [other]
472 sameAmode :: CAddrMode -> CAddrMode -> Bool
473 -- ToDo: Move this function, or make CAddrMode an instance of Eq
474 -- At the moment we put in just enough to catch the cases we want:
475 -- the second (destination) argument is always a CVal.
476 sameAmode (CReg r1) (CReg r2) = r1 == r2
477 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
478 sameAmode other1 other2 = False
480 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
481 doSimultaneously1 vertices
483 edges = [ (vertex, key1, edges_from stmt1)
484 | vertex@(key1, stmt1) <- vertices
486 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
487 stmt1 `should_follow` stmt2
489 components = stronglyConnComp edges
491 -- do_components deal with one strongly-connected component
492 -- Not cyclic, or singleton? Just do it
493 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
494 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
496 -- Cyclic? Then go via temporaries. Pick one to
497 -- break the loop and try again with the rest.
498 do_component (CyclicSCC ((n,first_stmt) : rest))
499 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
500 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
501 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
503 go_via_temps (CAssign dest src)
504 = getUniqFlt `thenFlt` \ uniq ->
506 the_temp = CTemp uniq (getAmodeRep dest)
508 returnFlt (CAssign the_temp src, CAssign dest the_temp)
510 go_via_temps (COpStmt dests op srcs vol_regs)
511 = getUniqsFlt `thenFlt` \ uniqs ->
513 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
515 returnFlt (COpStmt the_temps op srcs vol_regs,
516 mkAbstractCs (zipWith CAssign dests the_temps))
518 mapFlt do_component components `thenFlt` \ abs_cs ->
519 returnFlt (mkAbstractCs abs_cs)
522 should_follow :: AbstractC -> AbstractC -> Bool
523 (CAssign dest1 _) `should_follow` (CAssign _ src2)
524 = dest1 `conflictsWith` src2
525 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
526 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
527 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
528 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
529 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
530 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
533 @conflictsWith@ tells whether an assignment to its first argument will
534 screw up an access to its second.
537 conflictsWith :: CAddrMode -> CAddrMode -> Bool
538 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
539 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
540 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
541 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
542 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
543 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
545 other1 `conflictsWith` other2 = False
546 -- CAddr and literals are impossible on the LHS of an assignment
548 regConflictsWithRR :: MagicId -> RegRelative -> Bool
550 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True
551 regConflictsWithRR Sp (SpRel _) = True
552 regConflictsWithRR Hp (HpRel _) = True
553 regConflictsWithRR _ _ = False
555 rrConflictsWithRR :: Int -> Int -- Sizes of two things
556 -> RegRelative -> RegRelative -- The two amodes
559 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
564 rr (SpRel o1) (SpRel o2)
565 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
566 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
567 | otherwise = (o1 +# s1) >=# o2 &&
570 rr (NodeRel o1) (NodeRel 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 = True -- Give up
575 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
577 rr other1 other2 = False
580 %************************************************************************
582 \subsection[flat-primops]{Translating COpStmts to CMachOpStmts}
584 %************************************************************************
588 -- We begin with some helper functions. The main Dude here is
589 -- dscCOpStmt, defined a little further down.
591 ------------------------------------------------------------------------------
593 -- Assumes no volatiles
595 -- res = arg >> (bits-per-word / 2) when little-endian
597 -- res = arg & ((1 << (bits-per-word / 2)) - 1) when big-endian
599 -- In other words, if arg had been stored in memory, makes res the
600 -- halfword of arg which would have had the higher address. This is
601 -- why it needs to take into account endianness.
603 mkHalfWord_HIADDR res arg
604 = mkTemp WordRep `thenFlt` \ t_hw_mask1 ->
605 mkTemp WordRep `thenFlt` \ t_hw_mask2 ->
607 hw_shift = mkIntCLit (wORD_SIZE_IN_BITS `quot` 2)
610 = CMachOpStmt t_hw_mask1
611 MO_Nat_Shl [CLit (mkMachWord 1), hw_shift] Nothing
613 = CMachOpStmt t_hw_mask2
614 MO_Nat_Sub [t_hw_mask1, CLit (mkMachWord 1)] Nothing
617 = CSequential [ a_hw_mask1, a_hw_mask2,
618 CMachOpStmt res MO_Nat_And [arg, t_hw_mask2] Nothing
621 = CMachOpStmt res MO_Nat_Shr [arg, hw_shift] Nothing
627 mkTemp :: PrimRep -> FlatM CAddrMode
629 = getUniqFlt `thenFlt` \ uniq -> returnFlt (CTemp uniq rep)
631 mkTemps = mapFlt mkTemp
633 -- Sigh. This is done in 3 seperate places. Should be
634 -- commoned up (here, in pprAbsC of COpStmt, and presumably
635 -- somewhere in the NCG).
637 = case getAmodeRep amode of
641 -- Helpers for translating various minor variants of array indexing.
643 mkDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
644 mkDerefOff rep base off
645 = CVal (CIndex base (CLit (mkMachInt (toInteger off))) rep) rep
647 mkNoDerefOff :: PrimRep -> CAddrMode -> Int -> CAddrMode
648 mkNoDerefOff rep base off
649 = CAddr (CIndex base (CLit (mkMachInt (toInteger off))) rep)
652 -- Generates an address as follows
653 -- base + sizeof(machine_word)*offw + sizeof(rep)*idx
654 mk_OSBI_addr :: Int -> PrimRep -> CAddrMode -> CAddrMode -> RegRelative
655 mk_OSBI_addr offw rep base idx
656 = CIndex (CAddr (CIndex base idx rep))
657 (CLit (mkMachWord (fromIntegral offw)))
660 mk_OSBI_ref :: Int -> PrimRep -> CAddrMode -> CAddrMode -> CAddrMode
661 mk_OSBI_ref offw rep base idx
662 = CVal (mk_OSBI_addr offw rep base idx) rep
665 doIndexOffForeignObjOp maybe_post_read_cast rep res addr idx
666 = mkBasicIndexedRead fixedHdrSize maybe_post_read_cast rep res addr idx
668 doIndexOffAddrOp maybe_post_read_cast rep res addr idx
669 = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
671 doIndexByteArrayOp maybe_post_read_cast rep res addr idx
672 = mkBasicIndexedRead arrWordsHdrSize maybe_post_read_cast rep res addr idx
674 doReadPtrArrayOp res addr idx
675 = mkBasicIndexedRead arrPtrsHdrSize Nothing PtrRep res addr idx
678 doWriteOffAddrOp maybe_pre_write_cast rep addr idx val
679 = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
681 doWriteByteArrayOp maybe_pre_write_cast rep addr idx val
682 = mkBasicIndexedWrite arrWordsHdrSize maybe_pre_write_cast rep addr idx val
684 doWritePtrArrayOp addr idx val
685 = mkBasicIndexedWrite arrPtrsHdrSize Nothing PtrRep addr idx val
689 mkBasicIndexedRead offw Nothing read_rep res base idx
691 CAssign res (mk_OSBI_ref offw read_rep base idx)
693 mkBasicIndexedRead offw (Just cast_to_mop) read_rep res base idx
694 = mkTemp read_rep `thenFlt` \ tmp ->
695 (returnFlt . CSequential) [
696 CAssign tmp (mk_OSBI_ref offw read_rep base idx),
697 CMachOpStmt res cast_to_mop [tmp] Nothing
700 mkBasicIndexedWrite offw Nothing write_rep base idx val
702 CAssign (mk_OSBI_ref offw write_rep base idx) val
704 mkBasicIndexedWrite offw (Just cast_to_mop) write_rep base idx val
705 = mkTemp write_rep `thenFlt` \ tmp ->
706 (returnFlt . CSequential) [
707 CMachOpStmt tmp cast_to_mop [val] Nothing,
708 CAssign (mk_OSBI_ref offw write_rep base idx) tmp
712 -- Simple dyadic op but one for which we need to cast first arg to
713 -- be sure of correctness
714 translateOp_dyadic_cast1 mop res cast_arg1_to arg1 arg2 vols
715 = mkTemp cast_arg1_to `thenFlt` \ arg1casted ->
716 (returnFlt . CSequential) [
717 CAssign arg1casted arg1,
718 CMachOpStmt res mop [arg1casted,arg2]
719 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
722 -- IA64 mangler doesn't place tables next to code
723 tablesNextToCode :: Bool
724 #ifdef ia64_TARGET_ARCH
725 tablesNextToCode = False
727 tablesNextToCode = not opt_Unregisterised
730 ------------------------------------------------------------------------------
732 -- This is the main top-level desugarer PrimOps into MachOps. First we
733 -- handle various awkward cases specially. The remaining easy cases are
734 -- then handled by translateOp, defined below.
737 dscCOpStmt :: [CAddrMode] -- Results
739 -> [CAddrMode] -- Arguments
740 -> [MagicId] -- Potentially volatile/live registers
741 -- (to save/restore around the op)
745 dscCOpStmt [res_r,res_c] IntAddCOp [aa,bb] vols
747 With some bit-twiddling, we can define int{Add,Sub}Czh portably in
748 C, and without needing any comparisons. This may not be the
749 fastest way to do it - if you have better code, please send it! --SDM
751 Return : r = a + b, c = 0 if no overflow, 1 on overflow.
753 We currently don't make use of the r value if c is != 0 (i.e.
754 overflow), we just convert to big integers and try again. This
755 could be improved by making r and c the correct values for
756 plugging into a new J#.
758 { r = ((I_)(a)) + ((I_)(b)); \
759 c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
760 >> (BITS_IN (I_) - 1); \
762 Wading through the mass of bracketry, it seems to reduce to:
763 c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
770 c = t4 >>unsigned BITS_IN(I_)-1
772 = mkTemps [IntRep,IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3,t4] ->
773 let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
774 (returnFlt . CSequential) [
775 CMachOpStmt res_r MO_Nat_Add [aa,bb] Nothing,
776 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
777 CMachOpStmt t2 MO_Nat_Not [t1] Nothing,
778 CMachOpStmt t3 MO_Nat_Xor [aa,res_r] Nothing,
779 CMachOpStmt t4 MO_Nat_And [t2,t3] Nothing,
780 CMachOpStmt res_c MO_Nat_Shr [t4, bpw1] Nothing
784 dscCOpStmt [res_r,res_c] IntSubCOp [aa,bb] vols
786 #define subIntCzh(r,c,a,b) \
787 { r = ((I_)(a)) - ((I_)(b)); \
788 c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r))) \
789 >> (BITS_IN (I_) - 1); \
792 c = ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
797 c = t3 >>unsigned BITS_IN(I_)-1
799 = mkTemps [IntRep,IntRep,IntRep] `thenFlt` \ [t1,t2,t3] ->
800 let bpw1 = mkIntCLit (wORD_SIZE_IN_BITS - 1) in
801 (returnFlt . CSequential) [
802 CMachOpStmt res_r MO_Nat_Sub [aa,bb] Nothing,
803 CMachOpStmt t1 MO_Nat_Xor [aa,bb] Nothing,
804 CMachOpStmt t2 MO_Nat_Xor [aa,res_r] Nothing,
805 CMachOpStmt t3 MO_Nat_And [t1,t2] Nothing,
806 CMachOpStmt res_c MO_Nat_Shr [t3, bpw1] Nothing
810 -- #define parzh(r,node) r = 1
811 dscCOpStmt [res] ParOp [arg] vols
813 (CAssign res (CLit (mkMachInt 1)))
815 -- #define readMutVarzh(r,a) r=(P_)(((StgMutVar *)(a))->var)
816 dscCOpStmt [res] ReadMutVarOp [mutv] vols
818 (CAssign res (mkDerefOff PtrRep mutv fixedHdrSize))
820 -- #define writeMutVarzh(a,v) (P_)(((StgMutVar *)(a))->var)=(v)
821 dscCOpStmt [] WriteMutVarOp [mutv,var] vols
823 (CAssign (mkDerefOff PtrRep mutv fixedHdrSize) var)
826 -- #define ForeignObj_CLOSURE_DATA(c) (((StgForeignObj *)c)->data)
827 -- #define foreignObjToAddrzh(r,fo) r=ForeignObj_CLOSURE_DATA(fo)
828 dscCOpStmt [res] ForeignObjToAddrOp [fo] vols
830 (CAssign res (mkDerefOff PtrRep fo fixedHdrSize))
832 -- #define writeForeignObjzh(res,datum) \
833 -- (ForeignObj_CLOSURE_DATA(res) = (P_)(datum))
834 dscCOpStmt [] WriteForeignObjOp [fo,addr] vols
836 (CAssign (mkDerefOff PtrRep fo fixedHdrSize) addr)
839 -- #define sizzeofByteArrayzh(r,a) \
840 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
841 dscCOpStmt [res] SizeofByteArrayOp [arg] vols
842 = mkTemp WordRep `thenFlt` \ w ->
843 (returnFlt . CSequential) [
844 CAssign w (mkDerefOff WordRep arg fixedHdrSize),
845 CMachOpStmt w MO_NatU_Mul [w, mkIntCLit wORD_SIZE] (Just vols),
849 -- #define sizzeofMutableByteArrayzh(r,a) \
850 -- r = (((StgArrWords *)(a))->words * sizeof(W_))
851 dscCOpStmt [res] SizeofMutableByteArrayOp [arg] vols
852 = dscCOpStmt [res] SizeofByteArrayOp [arg] vols
855 -- #define touchzh(o) /* nothing */
856 dscCOpStmt [] TouchOp [arg] vols
859 -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
860 dscCOpStmt [res] ByteArrayContents_Char [arg] vols
861 = mkTemp PtrRep `thenFlt` \ ptr ->
862 (returnFlt . CSequential) [
863 CMachOpStmt ptr MO_NatU_to_NatP [arg] Nothing,
864 CAssign ptr (mkNoDerefOff WordRep ptr arrWordsHdrSize),
868 -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn)
869 dscCOpStmt [res] StableNameToIntOp [arg] vols
871 (CAssign res (mkDerefOff WordRep arg fixedHdrSize))
873 -- #define eqStableNamezh(r,sn1,sn2) \
874 -- (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
875 dscCOpStmt [res] EqStableNameOp [arg1,arg2] vols
876 = mkTemps [WordRep, WordRep] `thenFlt` \ [sn1,sn2] ->
877 (returnFlt . CSequential) [
878 CAssign sn1 (mkDerefOff WordRep arg1 fixedHdrSize),
879 CAssign sn2 (mkDerefOff WordRep arg2 fixedHdrSize),
880 CMachOpStmt res MO_Nat_Eq [sn1,sn2] Nothing
883 dscCOpStmt [res] ReallyUnsafePtrEqualityOp [arg1,arg2] vols
884 = mkTemps [WordRep, WordRep] `thenFlt` \ [w1,w2] ->
885 (returnFlt . CSequential) [
886 CMachOpStmt w1 MO_NatP_to_NatU [arg1] Nothing,
887 CMachOpStmt w2 MO_NatP_to_NatU [arg2] Nothing,
888 CMachOpStmt res MO_Nat_Eq [w1,w2] Nothing{- because it's inline? -}
891 -- #define addrToHValuezh(r,a) r=(P_)a
892 dscCOpStmt [res] AddrToHValueOp [arg] vols
896 -- #define dataToTagzh(r,a) r=(GET_TAG(((StgClosure *)a)->header.info))
898 -- In the unregisterised case, we don't attempt to compute the location
899 -- of the tag halfword, just a macro. For this build, fixing on layout
900 -- info has only got drawbacks.
902 -- Should this arrangement deeply offend you for some reason, code which
903 -- computes the offset can be found below also.
906 dscCOpStmt [res] DataToTagOp [arg] vols
907 | not tablesNextToCode
908 = returnFlt (CMacroStmt DATA_TO_TAGZH [res,arg])
910 = mkTemps [PtrRep, WordRep] `thenFlt` \ [t_infoptr, t_theword] ->
911 mkHalfWord_HIADDR res t_theword `thenFlt` \ select_ops ->
912 (returnFlt . CSequential) [
913 CAssign t_infoptr (mkDerefOff PtrRep arg 0),
915 Get at the tag within the info table; two cases to consider:
917 - reversed info tables next to the entry point code;
918 one word above the end of the info table (which is
919 what t_infoptr is really pointing to).
920 - info tables with their entry points stored somewhere else,
921 which is how the unregisterised (nee TABLES_NEXT_TO_CODE)
924 The t_infoptr points to the start of the info table, so add
925 the length of the info table & subtract one word.
927 CAssign t_theword (mkDerefOff WordRep t_infoptr (-1)),
928 {- UNUSED - see above comment.
929 (if opt_Unregisterised then
937 {- Freezing arrays-of-ptrs requires changing an info table, for the
938 benefit of the generational collector. It needs to scavenge mutable
939 objects, even if they are in old space. When they become immutable,
940 they can be removed from this scavenge list. -}
942 -- #define unsafeFreezzeArrayzh(r,a) \
944 -- SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_info); \
947 dscCOpStmt [res] UnsafeFreezeArrayOp [arg] vols
948 = (returnFlt . CSequential) [
949 CAssign (mkDerefOff PtrRep arg 0) (CLbl mkMAP_FROZEN_infoLabel PtrRep),
953 -- #define unsafeFreezzeByteArrayzh(r,a) r=(a)
954 dscCOpStmt [res] UnsafeFreezeByteArrayOp [arg] vols
958 -- This ought to be trivial, but it's difficult to insert the casts
959 -- required to keep the C compiler happy.
960 dscCOpStmt [r] AddrRemOp [a1,a2] vols
961 = mkTemp WordRep `thenFlt` \ a1casted ->
962 (returnFlt . CSequential) [
963 CMachOpStmt a1casted MO_NatP_to_NatU [a1] Nothing,
964 CMachOpStmt r MO_NatU_Rem [a1casted,a2] Nothing
967 -- not handled by translateOp because they need casts
968 dscCOpStmt [r] SllOp [a1,a2] vols
969 = translateOp_dyadic_cast1 MO_Nat_Shl r WordRep a1 a2 vols
970 dscCOpStmt [r] SrlOp [a1,a2] vols
971 = translateOp_dyadic_cast1 MO_Nat_Shr r WordRep a1 a2 vols
973 dscCOpStmt [r] ISllOp [a1,a2] vols
974 = translateOp_dyadic_cast1 MO_Nat_Shl r IntRep a1 a2 vols
975 dscCOpStmt [r] ISrlOp [a1,a2] vols
976 = translateOp_dyadic_cast1 MO_Nat_Shr r IntRep a1 a2 vols
977 dscCOpStmt [r] ISraOp [a1,a2] vols
978 = translateOp_dyadic_cast1 MO_Nat_Sar r IntRep a1 a2 vols
980 -- Reading/writing pointer arrays
982 dscCOpStmt [r] ReadArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
983 dscCOpStmt [r] IndexArrayOp [obj,ix] vols = doReadPtrArrayOp r obj ix
984 dscCOpStmt [] WriteArrayOp [obj,ix,v] vols = doWritePtrArrayOp obj ix v
986 -- IndexXXXoffForeignObj
988 dscCOpStmt [r] IndexOffForeignObjOp_Char [a,i] vols = doIndexOffForeignObjOp (Just MO_8U_to_32U) Word8Rep r a i
989 dscCOpStmt [r] IndexOffForeignObjOp_WideChar [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
990 dscCOpStmt [r] IndexOffForeignObjOp_Int [a,i] vols = doIndexOffForeignObjOp Nothing IntRep r a i
991 dscCOpStmt [r] IndexOffForeignObjOp_Word [a,i] vols = doIndexOffForeignObjOp Nothing WordRep r a i
992 dscCOpStmt [r] IndexOffForeignObjOp_Addr [a,i] vols = doIndexOffForeignObjOp Nothing AddrRep r a i
993 dscCOpStmt [r] IndexOffForeignObjOp_Float [a,i] vols = doIndexOffForeignObjOp Nothing FloatRep r a i
994 dscCOpStmt [r] IndexOffForeignObjOp_Double [a,i] vols = doIndexOffForeignObjOp Nothing DoubleRep r a i
995 dscCOpStmt [r] IndexOffForeignObjOp_StablePtr [a,i] vols = doIndexOffForeignObjOp Nothing StablePtrRep r a i
997 dscCOpStmt [r] IndexOffForeignObjOp_Int8 [a,i] vols = doIndexOffForeignObjOp Nothing Int8Rep r a i
998 dscCOpStmt [r] IndexOffForeignObjOp_Int16 [a,i] vols = doIndexOffForeignObjOp Nothing Int16Rep r a i
999 dscCOpStmt [r] IndexOffForeignObjOp_Int32 [a,i] vols = doIndexOffForeignObjOp Nothing Int32Rep r a i
1000 dscCOpStmt [r] IndexOffForeignObjOp_Int64 [a,i] vols = doIndexOffForeignObjOp Nothing Int64Rep r a i
1002 dscCOpStmt [r] IndexOffForeignObjOp_Word8 [a,i] vols = doIndexOffForeignObjOp Nothing Word8Rep r a i
1003 dscCOpStmt [r] IndexOffForeignObjOp_Word16 [a,i] vols = doIndexOffForeignObjOp Nothing Word16Rep r a i
1004 dscCOpStmt [r] IndexOffForeignObjOp_Word32 [a,i] vols = doIndexOffForeignObjOp Nothing Word32Rep r a i
1005 dscCOpStmt [r] IndexOffForeignObjOp_Word64 [a,i] vols = doIndexOffForeignObjOp Nothing Word64Rep r a i
1009 dscCOpStmt [r] IndexOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1010 dscCOpStmt [r] IndexOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1011 dscCOpStmt [r] IndexOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1012 dscCOpStmt [r] IndexOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1013 dscCOpStmt [r] IndexOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1014 dscCOpStmt [r] IndexOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1015 dscCOpStmt [r] IndexOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1016 dscCOpStmt [r] IndexOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1018 dscCOpStmt [r] IndexOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1019 dscCOpStmt [r] IndexOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1020 dscCOpStmt [r] IndexOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1021 dscCOpStmt [r] IndexOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1023 dscCOpStmt [r] IndexOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1024 dscCOpStmt [r] IndexOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1025 dscCOpStmt [r] IndexOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1026 dscCOpStmt [r] IndexOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1028 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
1030 dscCOpStmt [r] ReadOffAddrOp_Char [a,i] vols = doIndexOffAddrOp (Just MO_8U_to_32U) Word8Rep r a i
1031 dscCOpStmt [r] ReadOffAddrOp_WideChar [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1032 dscCOpStmt [r] ReadOffAddrOp_Int [a,i] vols = doIndexOffAddrOp Nothing IntRep r a i
1033 dscCOpStmt [r] ReadOffAddrOp_Word [a,i] vols = doIndexOffAddrOp Nothing WordRep r a i
1034 dscCOpStmt [r] ReadOffAddrOp_Addr [a,i] vols = doIndexOffAddrOp Nothing AddrRep r a i
1035 dscCOpStmt [r] ReadOffAddrOp_Float [a,i] vols = doIndexOffAddrOp Nothing FloatRep r a i
1036 dscCOpStmt [r] ReadOffAddrOp_Double [a,i] vols = doIndexOffAddrOp Nothing DoubleRep r a i
1037 dscCOpStmt [r] ReadOffAddrOp_StablePtr [a,i] vols = doIndexOffAddrOp Nothing StablePtrRep r a i
1039 dscCOpStmt [r] ReadOffAddrOp_Int8 [a,i] vols = doIndexOffAddrOp Nothing Int8Rep r a i
1040 dscCOpStmt [r] ReadOffAddrOp_Int16 [a,i] vols = doIndexOffAddrOp Nothing Int16Rep r a i
1041 dscCOpStmt [r] ReadOffAddrOp_Int32 [a,i] vols = doIndexOffAddrOp Nothing Int32Rep r a i
1042 dscCOpStmt [r] ReadOffAddrOp_Int64 [a,i] vols = doIndexOffAddrOp Nothing Int64Rep r a i
1044 dscCOpStmt [r] ReadOffAddrOp_Word8 [a,i] vols = doIndexOffAddrOp Nothing Word8Rep r a i
1045 dscCOpStmt [r] ReadOffAddrOp_Word16 [a,i] vols = doIndexOffAddrOp Nothing Word16Rep r a i
1046 dscCOpStmt [r] ReadOffAddrOp_Word32 [a,i] vols = doIndexOffAddrOp Nothing Word32Rep r a i
1047 dscCOpStmt [r] ReadOffAddrOp_Word64 [a,i] vols = doIndexOffAddrOp Nothing Word64Rep r a i
1051 dscCOpStmt [r] IndexByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1052 dscCOpStmt [r] IndexByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1053 dscCOpStmt [r] IndexByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1054 dscCOpStmt [r] IndexByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1055 dscCOpStmt [r] IndexByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1056 dscCOpStmt [r] IndexByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1057 dscCOpStmt [r] IndexByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1058 dscCOpStmt [r] IndexByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1060 dscCOpStmt [r] IndexByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1061 dscCOpStmt [r] IndexByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1062 dscCOpStmt [r] IndexByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1063 dscCOpStmt [r] IndexByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1065 dscCOpStmt [r] IndexByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1066 dscCOpStmt [r] IndexByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1067 dscCOpStmt [r] IndexByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1068 dscCOpStmt [r] IndexByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1070 -- ReadXXXArray, identical to IndexXXXArray.
1072 dscCOpStmt [r] ReadByteArrayOp_Char [a,i] vols = doIndexByteArrayOp (Just MO_8U_to_32U) Word8Rep r a i
1073 dscCOpStmt [r] ReadByteArrayOp_WideChar [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1074 dscCOpStmt [r] ReadByteArrayOp_Int [a,i] vols = doIndexByteArrayOp Nothing IntRep r a i
1075 dscCOpStmt [r] ReadByteArrayOp_Word [a,i] vols = doIndexByteArrayOp Nothing WordRep r a i
1076 dscCOpStmt [r] ReadByteArrayOp_Addr [a,i] vols = doIndexByteArrayOp Nothing AddrRep r a i
1077 dscCOpStmt [r] ReadByteArrayOp_Float [a,i] vols = doIndexByteArrayOp Nothing FloatRep r a i
1078 dscCOpStmt [r] ReadByteArrayOp_Double [a,i] vols = doIndexByteArrayOp Nothing DoubleRep r a i
1079 dscCOpStmt [r] ReadByteArrayOp_StablePtr [a,i] vols = doIndexByteArrayOp Nothing StablePtrRep r a i
1081 dscCOpStmt [r] ReadByteArrayOp_Int8 [a,i] vols = doIndexByteArrayOp Nothing Int8Rep r a i
1082 dscCOpStmt [r] ReadByteArrayOp_Int16 [a,i] vols = doIndexByteArrayOp Nothing Int16Rep r a i
1083 dscCOpStmt [r] ReadByteArrayOp_Int32 [a,i] vols = doIndexByteArrayOp Nothing Int32Rep r a i
1084 dscCOpStmt [r] ReadByteArrayOp_Int64 [a,i] vols = doIndexByteArrayOp Nothing Int64Rep r a i
1086 dscCOpStmt [r] ReadByteArrayOp_Word8 [a,i] vols = doIndexByteArrayOp Nothing Word8Rep r a i
1087 dscCOpStmt [r] ReadByteArrayOp_Word16 [a,i] vols = doIndexByteArrayOp Nothing Word16Rep r a i
1088 dscCOpStmt [r] ReadByteArrayOp_Word32 [a,i] vols = doIndexByteArrayOp Nothing Word32Rep r a i
1089 dscCOpStmt [r] ReadByteArrayOp_Word64 [a,i] vols = doIndexByteArrayOp Nothing Word64Rep r a i
1093 dscCOpStmt [] WriteOffAddrOp_Char [a,i,x] vols = doWriteOffAddrOp (Just MO_32U_to_8U) Word8Rep a i x
1094 dscCOpStmt [] WriteOffAddrOp_WideChar [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1095 dscCOpStmt [] WriteOffAddrOp_Int [a,i,x] vols = doWriteOffAddrOp Nothing IntRep a i x
1096 dscCOpStmt [] WriteOffAddrOp_Word [a,i,x] vols = doWriteOffAddrOp Nothing WordRep a i x
1097 dscCOpStmt [] WriteOffAddrOp_Addr [a,i,x] vols = doWriteOffAddrOp Nothing AddrRep a i x
1098 dscCOpStmt [] WriteOffAddrOp_Float [a,i,x] vols = doWriteOffAddrOp Nothing FloatRep a i x
1099 dscCOpStmt [] WriteOffAddrOp_ForeignObj [a,i,x] vols = doWriteOffAddrOp Nothing PtrRep a i x
1100 dscCOpStmt [] WriteOffAddrOp_Double [a,i,x] vols = doWriteOffAddrOp Nothing DoubleRep a i x
1101 dscCOpStmt [] WriteOffAddrOp_StablePtr [a,i,x] vols = doWriteOffAddrOp Nothing StablePtrRep a i x
1103 dscCOpStmt [] WriteOffAddrOp_Int8 [a,i,x] vols = doWriteOffAddrOp Nothing Int8Rep a i x
1104 dscCOpStmt [] WriteOffAddrOp_Int16 [a,i,x] vols = doWriteOffAddrOp Nothing Int16Rep a i x
1105 dscCOpStmt [] WriteOffAddrOp_Int32 [a,i,x] vols = doWriteOffAddrOp Nothing Int32Rep a i x
1106 dscCOpStmt [] WriteOffAddrOp_Int64 [a,i,x] vols = doWriteOffAddrOp Nothing Int64Rep a i x
1108 dscCOpStmt [] WriteOffAddrOp_Word8 [a,i,x] vols = doWriteOffAddrOp Nothing Word8Rep a i x
1109 dscCOpStmt [] WriteOffAddrOp_Word16 [a,i,x] vols = doWriteOffAddrOp Nothing Word16Rep a i x
1110 dscCOpStmt [] WriteOffAddrOp_Word32 [a,i,x] vols = doWriteOffAddrOp Nothing Word32Rep a i x
1111 dscCOpStmt [] WriteOffAddrOp_Word64 [a,i,x] vols = doWriteOffAddrOp Nothing Word64Rep a i x
1115 dscCOpStmt [] WriteByteArrayOp_Char [a,i,x] vols = doWriteByteArrayOp (Just MO_32U_to_8U) Word8Rep a i x
1116 dscCOpStmt [] WriteByteArrayOp_WideChar [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1117 dscCOpStmt [] WriteByteArrayOp_Int [a,i,x] vols = doWriteByteArrayOp Nothing IntRep a i x
1118 dscCOpStmt [] WriteByteArrayOp_Word [a,i,x] vols = doWriteByteArrayOp Nothing WordRep a i x
1119 dscCOpStmt [] WriteByteArrayOp_Addr [a,i,x] vols = doWriteByteArrayOp Nothing AddrRep a i x
1120 dscCOpStmt [] WriteByteArrayOp_Float [a,i,x] vols = doWriteByteArrayOp Nothing FloatRep a i x
1121 dscCOpStmt [] WriteByteArrayOp_Double [a,i,x] vols = doWriteByteArrayOp Nothing DoubleRep a i x
1122 dscCOpStmt [] WriteByteArrayOp_StablePtr [a,i,x] vols = doWriteByteArrayOp Nothing StablePtrRep a i x
1124 dscCOpStmt [] WriteByteArrayOp_Int8 [a,i,x] vols = doWriteByteArrayOp Nothing Int8Rep a i x
1125 dscCOpStmt [] WriteByteArrayOp_Int16 [a,i,x] vols = doWriteByteArrayOp Nothing Int16Rep a i x
1126 dscCOpStmt [] WriteByteArrayOp_Int32 [a,i,x] vols = doWriteByteArrayOp Nothing Int32Rep a i x
1127 dscCOpStmt [] WriteByteArrayOp_Int64 [a,i,x] vols = doWriteByteArrayOp Nothing Int64Rep a i x
1129 dscCOpStmt [] WriteByteArrayOp_Word8 [a,i,x] vols = doWriteByteArrayOp Nothing Word8Rep a i x
1130 dscCOpStmt [] WriteByteArrayOp_Word16 [a,i,x] vols = doWriteByteArrayOp Nothing Word16Rep a i x
1131 dscCOpStmt [] WriteByteArrayOp_Word32 [a,i,x] vols = doWriteByteArrayOp Nothing Word32Rep a i x
1132 dscCOpStmt [] WriteByteArrayOp_Word64 [a,i,x] vols = doWriteByteArrayOp Nothing Word64Rep a i x
1135 -- Handle all others as simply as possible.
1136 dscCOpStmt ress op args vols
1137 = case translateOp ress op args of
1139 -> pprPanic "dscCOpStmt: can't translate PrimOp" (ppr op)
1140 Just (maybe_res, mop, args)
1142 CMachOpStmt maybe_res mop args
1143 (if isDefinitelyInlineMachOp mop then Nothing else Just vols)
1146 -- Native word signless ops
1148 translateOp [r] IntAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1149 translateOp [r] IntSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1150 translateOp [r] WordAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1151 translateOp [r] WordSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1152 translateOp [r] AddrAddOp [a1,a2] = Just (r, MO_Nat_Add, [a1,a2])
1153 translateOp [r] AddrSubOp [a1,a2] = Just (r, MO_Nat_Sub, [a1,a2])
1155 translateOp [r] IntEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1156 translateOp [r] IntNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1157 translateOp [r] WordEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1158 translateOp [r] WordNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1159 translateOp [r] AddrEqOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1160 translateOp [r] AddrNeOp [a1,a2] = Just (r, MO_Nat_Ne, [a1,a2])
1162 translateOp [r] AndOp [a1,a2] = Just (r, MO_Nat_And, [a1,a2])
1163 translateOp [r] OrOp [a1,a2] = Just (r, MO_Nat_Or, [a1,a2])
1164 translateOp [r] XorOp [a1,a2] = Just (r, MO_Nat_Xor, [a1,a2])
1165 translateOp [r] NotOp [a1] = Just (r, MO_Nat_Not, [a1])
1167 -- Native word signed ops
1169 translateOp [r] IntMulOp [a1,a2] = Just (r, MO_NatS_Mul, [a1,a2])
1170 translateOp [r] IntMulMayOfloOp [a1,a2] = Just (r, MO_NatS_MulMayOflo, [a1,a2])
1171 translateOp [r] IntQuotOp [a1,a2] = Just (r, MO_NatS_Quot, [a1,a2])
1172 translateOp [r] IntRemOp [a1,a2] = Just (r, MO_NatS_Rem, [a1,a2])
1173 translateOp [r] IntNegOp [a1] = Just (r, MO_NatS_Neg, [a1])
1175 translateOp [r] IntGeOp [a1,a2] = Just (r, MO_NatS_Ge, [a1,a2])
1176 translateOp [r] IntLeOp [a1,a2] = Just (r, MO_NatS_Le, [a1,a2])
1177 translateOp [r] IntGtOp [a1,a2] = Just (r, MO_NatS_Gt, [a1,a2])
1178 translateOp [r] IntLtOp [a1,a2] = Just (r, MO_NatS_Lt, [a1,a2])
1181 -- Native word unsigned ops
1183 translateOp [r] WordGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1184 translateOp [r] WordLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1185 translateOp [r] WordGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1186 translateOp [r] WordLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1188 translateOp [r] WordMulOp [a1,a2] = Just (r, MO_NatU_Mul, [a1,a2])
1189 translateOp [r] WordQuotOp [a1,a2] = Just (r, MO_NatU_Quot, [a1,a2])
1190 translateOp [r] WordRemOp [a1,a2] = Just (r, MO_NatU_Rem, [a1,a2])
1192 translateOp [r] AddrGeOp [a1,a2] = Just (r, MO_NatU_Ge, [a1,a2])
1193 translateOp [r] AddrLeOp [a1,a2] = Just (r, MO_NatU_Le, [a1,a2])
1194 translateOp [r] AddrGtOp [a1,a2] = Just (r, MO_NatU_Gt, [a1,a2])
1195 translateOp [r] AddrLtOp [a1,a2] = Just (r, MO_NatU_Lt, [a1,a2])
1197 -- 32-bit unsigned ops
1199 translateOp [r] CharEqOp [a1,a2] = Just (r, MO_32U_Eq, [a1,a2])
1200 translateOp [r] CharNeOp [a1,a2] = Just (r, MO_32U_Ne, [a1,a2])
1201 translateOp [r] CharGeOp [a1,a2] = Just (r, MO_32U_Ge, [a1,a2])
1202 translateOp [r] CharLeOp [a1,a2] = Just (r, MO_32U_Le, [a1,a2])
1203 translateOp [r] CharGtOp [a1,a2] = Just (r, MO_32U_Gt, [a1,a2])
1204 translateOp [r] CharLtOp [a1,a2] = Just (r, MO_32U_Lt, [a1,a2])
1208 translateOp [r] DoubleEqOp [a1,a2] = Just (r, MO_Dbl_Eq, [a1,a2])
1209 translateOp [r] DoubleNeOp [a1,a2] = Just (r, MO_Dbl_Ne, [a1,a2])
1210 translateOp [r] DoubleGeOp [a1,a2] = Just (r, MO_Dbl_Ge, [a1,a2])
1211 translateOp [r] DoubleLeOp [a1,a2] = Just (r, MO_Dbl_Le, [a1,a2])
1212 translateOp [r] DoubleGtOp [a1,a2] = Just (r, MO_Dbl_Gt, [a1,a2])
1213 translateOp [r] DoubleLtOp [a1,a2] = Just (r, MO_Dbl_Lt, [a1,a2])
1215 translateOp [r] DoubleAddOp [a1,a2] = Just (r, MO_Dbl_Add, [a1,a2])
1216 translateOp [r] DoubleSubOp [a1,a2] = Just (r, MO_Dbl_Sub, [a1,a2])
1217 translateOp [r] DoubleMulOp [a1,a2] = Just (r, MO_Dbl_Mul, [a1,a2])
1218 translateOp [r] DoubleDivOp [a1,a2] = Just (r, MO_Dbl_Div, [a1,a2])
1219 translateOp [r] DoublePowerOp [a1,a2] = Just (r, MO_Dbl_Pwr, [a1,a2])
1221 translateOp [r] DoubleSinOp [a1] = Just (r, MO_Dbl_Sin, [a1])
1222 translateOp [r] DoubleCosOp [a1] = Just (r, MO_Dbl_Cos, [a1])
1223 translateOp [r] DoubleTanOp [a1] = Just (r, MO_Dbl_Tan, [a1])
1224 translateOp [r] DoubleSinhOp [a1] = Just (r, MO_Dbl_Sinh, [a1])
1225 translateOp [r] DoubleCoshOp [a1] = Just (r, MO_Dbl_Cosh, [a1])
1226 translateOp [r] DoubleTanhOp [a1] = Just (r, MO_Dbl_Tanh, [a1])
1227 translateOp [r] DoubleAsinOp [a1] = Just (r, MO_Dbl_Asin, [a1])
1228 translateOp [r] DoubleAcosOp [a1] = Just (r, MO_Dbl_Acos, [a1])
1229 translateOp [r] DoubleAtanOp [a1] = Just (r, MO_Dbl_Atan, [a1])
1230 translateOp [r] DoubleLogOp [a1] = Just (r, MO_Dbl_Log, [a1])
1231 translateOp [r] DoubleExpOp [a1] = Just (r, MO_Dbl_Exp, [a1])
1232 translateOp [r] DoubleSqrtOp [a1] = Just (r, MO_Dbl_Sqrt, [a1])
1233 translateOp [r] DoubleNegOp [a1] = Just (r, MO_Dbl_Neg, [a1])
1237 translateOp [r] FloatEqOp [a1,a2] = Just (r, MO_Flt_Eq, [a1,a2])
1238 translateOp [r] FloatNeOp [a1,a2] = Just (r, MO_Flt_Ne, [a1,a2])
1239 translateOp [r] FloatGeOp [a1,a2] = Just (r, MO_Flt_Ge, [a1,a2])
1240 translateOp [r] FloatLeOp [a1,a2] = Just (r, MO_Flt_Le, [a1,a2])
1241 translateOp [r] FloatGtOp [a1,a2] = Just (r, MO_Flt_Gt, [a1,a2])
1242 translateOp [r] FloatLtOp [a1,a2] = Just (r, MO_Flt_Lt, [a1,a2])
1244 translateOp [r] FloatAddOp [a1,a2] = Just (r, MO_Flt_Add, [a1,a2])
1245 translateOp [r] FloatSubOp [a1,a2] = Just (r, MO_Flt_Sub, [a1,a2])
1246 translateOp [r] FloatMulOp [a1,a2] = Just (r, MO_Flt_Mul, [a1,a2])
1247 translateOp [r] FloatDivOp [a1,a2] = Just (r, MO_Flt_Div, [a1,a2])
1248 translateOp [r] FloatPowerOp [a1,a2] = Just (r, MO_Flt_Pwr, [a1,a2])
1250 translateOp [r] FloatSinOp [a1] = Just (r, MO_Flt_Sin, [a1])
1251 translateOp [r] FloatCosOp [a1] = Just (r, MO_Flt_Cos, [a1])
1252 translateOp [r] FloatTanOp [a1] = Just (r, MO_Flt_Tan, [a1])
1253 translateOp [r] FloatSinhOp [a1] = Just (r, MO_Flt_Sinh, [a1])
1254 translateOp [r] FloatCoshOp [a1] = Just (r, MO_Flt_Cosh, [a1])
1255 translateOp [r] FloatTanhOp [a1] = Just (r, MO_Flt_Tanh, [a1])
1256 translateOp [r] FloatAsinOp [a1] = Just (r, MO_Flt_Asin, [a1])
1257 translateOp [r] FloatAcosOp [a1] = Just (r, MO_Flt_Acos, [a1])
1258 translateOp [r] FloatAtanOp [a1] = Just (r, MO_Flt_Atan, [a1])
1259 translateOp [r] FloatLogOp [a1] = Just (r, MO_Flt_Log, [a1])
1260 translateOp [r] FloatExpOp [a1] = Just (r, MO_Flt_Exp, [a1])
1261 translateOp [r] FloatSqrtOp [a1] = Just (r, MO_Flt_Sqrt, [a1])
1262 translateOp [r] FloatNegOp [a1] = Just (r, MO_Flt_Neg, [a1])
1266 translateOp [r] Int2DoubleOp [a1] = Just (r, MO_NatS_to_Dbl, [a1])
1267 translateOp [r] Double2IntOp [a1] = Just (r, MO_Dbl_to_NatS, [a1])
1269 translateOp [r] Int2FloatOp [a1] = Just (r, MO_NatS_to_Flt, [a1])
1270 translateOp [r] Float2IntOp [a1] = Just (r, MO_Flt_to_NatS, [a1])
1272 translateOp [r] Float2DoubleOp [a1] = Just (r, MO_Flt_to_Dbl, [a1])
1273 translateOp [r] Double2FloatOp [a1] = Just (r, MO_Dbl_to_Flt, [a1])
1275 translateOp [r] Int2WordOp [a1] = Just (r, MO_NatS_to_NatU, [a1])
1276 translateOp [r] Word2IntOp [a1] = Just (r, MO_NatU_to_NatS, [a1])
1278 translateOp [r] Int2AddrOp [a1] = Just (r, MO_NatS_to_NatP, [a1])
1279 translateOp [r] Addr2IntOp [a1] = Just (r, MO_NatP_to_NatS, [a1])
1281 translateOp [r] OrdOp [a1] = Just (r, MO_32U_to_NatS, [a1])
1282 translateOp [r] ChrOp [a1] = Just (r, MO_NatS_to_32U, [a1])
1284 translateOp [r] Narrow8IntOp [a1] = Just (r, MO_8S_to_NatS, [a1])
1285 translateOp [r] Narrow16IntOp [a1] = Just (r, MO_16S_to_NatS, [a1])
1286 translateOp [r] Narrow32IntOp [a1] = Just (r, MO_32S_to_NatS, [a1])
1288 translateOp [r] Narrow8WordOp [a1] = Just (r, MO_8U_to_NatU, [a1])
1289 translateOp [r] Narrow16WordOp [a1] = Just (r, MO_16U_to_NatU, [a1])
1290 translateOp [r] Narrow32WordOp [a1] = Just (r, MO_32U_to_NatU, [a1])
1292 -- Word comparisons masquerading as more exotic things.
1294 translateOp [r] SameMutVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1295 translateOp [r] SameMVarOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1296 translateOp [r] SameMutableArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1297 translateOp [r] SameMutableByteArrayOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1298 translateOp [r] EqForeignObj [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1299 translateOp [r] EqStablePtrOp [a1,a2] = Just (r, MO_Nat_Eq, [a1,a2])
1301 translateOp _ _ _ = Nothing