2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
7 #include "HsVersions.h"
11 mkAbstractCs, mkAbsCStmts,
14 getAmodeRep, amodeCanSurviveGC,
15 mixedTypeLocn, mixedPtrLocn,
19 -- printing/forcing stuff comes from PprAbsC
21 -- and for interface self-sufficiency...
26 import PrelInfo ( PrimOp(..)
27 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
28 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
30 import Literal ( literalPrimRep )
31 import CLabel ( CLabel, mkReturnPtLabel, mkVecTblLabel )
32 import Digraph ( stronglyConnComp )
33 import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id )
34 import Maybes ( Maybe(..) )
35 import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..) )
37 import StgSyn ( GenStgArg )
42 Check if there is any real code in some Abstract~C. If so, return it
43 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
45 It returns the "reduced" code in the Just part so that the work of
46 discarding AbsCNops isn't lost, and so that if the caller uses
47 the reduced version there's less danger of a big tree of AbsCNops getting
48 materialised and causing a space leak.
51 nonemptyAbsC :: AbstractC -> Maybe AbstractC
52 nonemptyAbsC AbsCNop = Nothing
53 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
54 Nothing -> nonemptyAbsC s2
55 Just x -> Just (AbsCStmts x s2)
56 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
59 nonemptyAbsC other = Just other
63 mkAbstractCs :: [AbstractC] -> AbstractC
64 mkAbstractCs [] = AbsCNop
65 mkAbstractCs cs = foldr1 mkAbsCStmts cs
67 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
68 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
69 mkAbsCStmts = AbsCStmts
71 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
72 = BIND (case (nonemptyAbsC abc2) of
74 Just d2 -> d2) _TO_ abc2b ->
76 case (nonemptyAbsC abc1) of {
78 Just d1 -> AbsCStmts d1 abc2b
82 = case (nonemptyAbsC abc1) of
84 Just d1 -> AbsCStmts d1 abc2
87 = case (nonemptyAbsC abc1) of
88 Nothing -> case (nonemptyAbsC abc2) of
91 Just d1 -> AbsCStmts d1 abc2
98 else if {- abc1 not empty but -} abc2_empty then
100 else {- neither empty -}
103 abc1_empty = noAbsCcode abc1
104 abc2_empty = noAbsCcode abc2
108 Get the sho' 'nuff statements out of an @AbstractC@.
110 mkAbsCStmtList :: AbstractC -> [AbstractC]
112 mkAbsCStmtList absC = mkAbsCStmtList' absC []
114 -- Optimised a la foldr/build!
116 mkAbsCStmtList' AbsCNop r = r
118 mkAbsCStmtList' (AbsCStmts s1 s2) r
119 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
121 mkAbsCStmtList' s@(CSimultaneous c) r
122 = if null (mkAbsCStmtList c) then r else s : r
124 mkAbsCStmtList' other r = other : r
128 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
130 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
131 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
133 -- Adjust the tags in the switch to start at zero.
134 -- This is the convention used by primitive ops which return algebraic
135 -- data types. Why? Because for two-constructor types, zero is faster
136 -- to create and distinguish from 1 than are 1 and 2.
138 -- We also need to convert to Literals to keep the CSwitch happy
140 = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
141 | (tag, abs_c) <- tagged_alts ]
144 %************************************************************************
146 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
148 %************************************************************************
151 kindFromMagicId BaseReg = PtrRep
152 kindFromMagicId StkOReg = PtrRep
153 kindFromMagicId (VanillaReg kind _) = kind
154 kindFromMagicId (FloatReg _) = FloatRep
155 kindFromMagicId (DoubleReg _) = DoubleRep
156 kindFromMagicId TagReg = IntRep
157 kindFromMagicId RetReg = RetRep
158 kindFromMagicId SpA = PtrRep
159 kindFromMagicId SuA = PtrRep
160 kindFromMagicId SpB = PtrRep
161 kindFromMagicId SuB = PtrRep
162 kindFromMagicId Hp = PtrRep
163 kindFromMagicId HpLim = PtrRep
164 kindFromMagicId LivenessReg = IntRep
165 kindFromMagicId StdUpdRetVecReg = PtrRep
166 kindFromMagicId StkStubReg = PtrRep
167 kindFromMagicId CurCostCentre = CostCentreRep
168 kindFromMagicId VoidReg = VoidRep
171 %************************************************************************
173 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
175 %************************************************************************
177 See also the return conventions for unboxed things; currently living
178 in @CgCon@ (next to the constructor return conventions).
180 ToDo: tiny tweaking may be in order
182 getAmodeRep :: CAddrMode -> PrimRep
184 getAmodeRep (CVal _ kind) = kind
185 getAmodeRep (CAddr _) = PtrRep
186 getAmodeRep (CReg magic_id) = kindFromMagicId magic_id
187 getAmodeRep (CTemp uniq kind) = kind
188 getAmodeRep (CLbl label kind) = kind
189 getAmodeRep (CUnVecLbl _ _) = PtrRep
190 getAmodeRep (CCharLike _) = PtrRep
191 getAmodeRep (CIntLike _) = PtrRep
192 getAmodeRep (CString _) = PtrRep
193 getAmodeRep (CLit lit) = literalPrimRep lit
194 getAmodeRep (CLitLit _ kind) = kind
195 getAmodeRep (COffset _) = IntRep
196 getAmodeRep (CCode abs_C) = CodePtrRep
197 getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
198 getAmodeRep (CTableEntry _ _ kind) = kind
199 getAmodeRep (CMacroExpr kind _ _) = kind
201 getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
202 getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
206 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
207 across a garbage collection. Used only for PrimOp arguments (not that
211 amodeCanSurviveGC :: CAddrMode -> Bool
213 amodeCanSurviveGC (CTableEntry base offset _)
214 = amodeCanSurviveGC base && amodeCanSurviveGC offset
215 -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
217 amodeCanSurviveGC (CLbl _ _) = True
218 amodeCanSurviveGC (CUnVecLbl _ _) = True
219 amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
220 amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
221 amodeCanSurviveGC (CString _) = True
222 amodeCanSurviveGC (CLit _) = True
223 amodeCanSurviveGC (CLitLit _ _) = True
224 amodeCanSurviveGC (COffset _) = True
225 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
227 amodeCanSurviveGC _ = False
228 -- there are some amodes that "cannot occur" as args
229 -- to a PrimOp, but it is safe to return False (rather than panic)
232 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
233 location; that is, one which can contain values of various types.
236 mixedTypeLocn :: CAddrMode -> Bool
238 mixedTypeLocn (CVal (NodeRel _) _) = True
239 mixedTypeLocn (CVal (SpBRel _ _) _) = True
240 mixedTypeLocn (CVal (HpRel _ _) _) = True
241 mixedTypeLocn other = False -- All the rest
244 @mixedPtrLocn@ tells whether an amode identifies a
245 location which can contain values of various pointer types.
248 mixedPtrLocn :: CAddrMode -> Bool
250 mixedPtrLocn (CVal (SpARel _ _) _) = True
251 mixedPtrLocn other = False -- All the rest
254 %************************************************************************
256 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
258 %************************************************************************
260 The following bits take ``raw'' Abstract~C, which may have all sorts of
261 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
262 @CClosureInfos@ and code for switches are pulled out to the top level.
264 The various functions herein tend to produce
267 A {\em flattened} \tr{<something>} of interest for ``here'', and
269 Some {\em unflattened} Abstract~C statements to be carried up to the
270 top-level. The only real reason (now) that it is unflattened is
271 because it means the recursive flattening can be done in just one
272 place rather than having to remember lots of places.
275 Care is taken to reduce the occurrence of forward references, while still
276 keeping laziness a much as possible. Essentially, this means that:
279 {\em All} the top-level C statements resulting from flattening a
280 particular AbsC statement (whether the latter is nested or not) appear
281 before {\em any} of the code for a subsequent AbsC statement;
283 but stuff nested within any AbsC statement comes
284 out before the code for the statement itself.
287 The ``stuff to be carried up'' always includes a label: a
288 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
289 @CCodeBlock@. The latter turns into a C function, and is never
290 actually produced by the code generator. Rather it always starts life
291 as a @CLabelledCode@ addressing mode; when such an addr mode is
292 flattened, the ``tops'' stuff is a @CCodeBlock@.
295 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
298 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
299 here `mkAbsCStmts` tops }
302 %************************************************************************
304 \subsubsection{Flattening monadery}
306 %************************************************************************
308 The flattener is monadised. It's just a @UniqueSupply@, along with a
309 ``come-back-to-here'' label to pin on heap and stack checks.
317 initFlt :: UniqSupply -> FlatM a -> a
319 initFlt init_us m = m (panic "initFlt:CLabel") init_us
321 {-# INLINE thenFlt #-}
322 {-# INLINE returnFlt #-}
324 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
326 thenFlt expr cont label us
327 = case (splitUniqSupply us) of { (s1, s2) ->
328 case (expr label s1) of { result ->
329 cont result label s2 }}
331 returnFlt :: a -> FlatM a
332 returnFlt result label us = result
334 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
336 mapFlt f [] = returnFlt []
338 = f x `thenFlt` \ r ->
339 mapFlt f xs `thenFlt` \ rs ->
342 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
344 mapAndUnzipFlt f [] = returnFlt ([],[])
345 mapAndUnzipFlt f (x:xs)
346 = f x `thenFlt` \ (r1, r2) ->
347 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
348 returnFlt (r1:rs1, r2:rs2)
350 getUniqFlt :: FlatM Unique
351 getUniqFlt label us = getUnique us
353 getUniqsFlt :: Int -> FlatM [Unique]
354 getUniqsFlt i label us = getUniques i us
356 setLabelFlt :: CLabel -> FlatM a -> FlatM a
357 setLabelFlt new_label cont label us = cont new_label us
359 getLabelFlt :: FlatM CLabel
360 getLabelFlt label us = label
363 %************************************************************************
365 \subsubsection{Flattening the top level}
367 %************************************************************************
370 flatAbsC :: AbstractC
371 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
372 AbstractC) -- Stuff to put at top level flattened]
374 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
376 flatAbsC (AbsCStmts s1 s2)
377 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
378 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
379 returnFlt (mkAbsCStmts inline_s1 inline_s2,
380 mkAbsCStmts top_s1 top_s2)
382 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
383 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
384 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
385 flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
386 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
387 CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
390 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
391 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
392 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
393 returnFlt (Just heres, tops)
395 flatAbsC (CCodeBlock label abs_C)
396 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
397 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
399 flatAbsC (CClosureUpdInfo info) = flatAbsC info
401 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
402 = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
403 returnFlt (AbsCNop, tops `mkAbsCStmts`
404 CStaticClosure closure_lbl closure_info new_cc new_amodes)
406 flatAbsC (CRetVector tbl_label stuff deflt)
407 = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
408 mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
409 returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
410 mkAbstractCs alt_tops,
411 CFlatRetVector tbl_label alt_amodes])
414 do_deflt deflt = case nonemptyAbsC deflt of
415 Nothing -> returnFlt (bogus_default_label, AbsCNop)
416 Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
417 -- CJump (CLabelledCode ...) case
419 do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
420 do_alt deflt_amode (Just alt) = flatAmode alt
422 bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
425 flatAbsC (CRetUnVector label amode)
426 = flatAmode amode `thenFlt` \ (new_amode, tops) ->
427 returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
429 flatAbsC (CFlatRetVector label amodes)
430 = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
431 returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
433 flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
434 = returnFlt (AbsCNop, cc)
436 -- now the real stmts:
438 flatAbsC (CAssign dest source)
439 = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
440 flatAmode source `thenFlt` \ (src_amode, src_tops) ->
441 returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
443 -- special case: jump to some anonymous code
444 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
446 flatAbsC (CJump target)
447 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
448 returnFlt ( CJump targ_amode, targ_tops )
450 flatAbsC (CFallThrough target)
451 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
452 returnFlt ( CFallThrough targ_amode, targ_tops )
454 flatAbsC (CReturn target return_info)
455 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
456 returnFlt ( CReturn targ_amode return_info, targ_tops )
458 flatAbsC (CSwitch discrim alts deflt)
459 = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
460 mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
461 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
463 CSwitch discrim_amode flat_alts flat_def_alt,
464 mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
468 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
469 returnFlt ( (tag, alt_heres), alt_tops )
471 flatAbsC stmt@(CInitHdr a b cc u)
472 = flatAmode cc `thenFlt` \ (new_cc, tops) ->
473 returnFlt (CInitHdr a b new_cc u, tops)
475 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
476 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
477 flatAmodes args `thenFlt` \ (args_here, tops2) ->
478 returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
479 mkAbsCStmts tops1 tops2)
481 flatAbsC stmt@(CSimultaneous abs_c)
482 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
483 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
484 returnFlt (new_stmts_here, tops)
486 flatAbsC stmt@(CMacroStmt macro amodes)
487 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
488 returnFlt (CMacroStmt macro amodes_here, tops)
490 flatAbsC stmt@(CCallProfCtrMacro str amodes)
491 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
492 returnFlt (CCallProfCtrMacro str amodes_here, tops)
494 flatAbsC stmt@(CCallProfCCMacro str amodes)
495 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
496 returnFlt (CCallProfCCMacro str amodes_here, tops)
498 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
501 %************************************************************************
503 \subsection[flat-amodes]{Flattening addressing modes}
505 %************************************************************************
508 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
511 flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
513 flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
514 flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
515 flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
516 flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
517 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
518 flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
519 flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
520 flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
521 flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
523 -- CIntLike must be a literal -- no flattening
524 flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
526 -- CCharLike may be arbitrary value -- have to flatten
527 flatAmode amode@(CCharLike char)
528 = flatAmode char `thenFlt` \ (flat_char, tops) ->
529 returnFlt(CCharLike flat_char, tops)
531 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
533 flatAmode (CLabelledCode label abs_C)
534 -- Push the code (with this label) to the top level
535 = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
536 returnFlt (CLbl label CodePtrRep,
537 tops `mkAbsCStmts` CCodeBlock label body_code)
539 flatAmode (CCode abs_C)
540 = case mkAbsCStmtList abs_C of
541 [CJump amode] -> flatAmode amode -- Elide redundant labels
543 -- de-anonymous-ise the code and push it (labelled) to the top level
544 getUniqFlt `thenFlt` \ new_uniq ->
545 BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label ->
546 flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
548 CLbl return_pt_label CodePtrRep,
549 tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
550 -- DO NOT TOUCH the stuff sent to the top...
554 flatAmode (CTableEntry base index kind)
555 = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
556 flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
557 returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
559 flatAmode (CMacroExpr pk macro amodes)
560 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
561 returnFlt ( CMacroExpr pk macro amodes_here, tops )
563 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
566 And a convenient way to do a whole bunch of 'em.
568 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
570 flatAmodes [] = returnFlt ([], AbsCNop)
573 = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
574 returnFlt (amodes_here, mkAbstractCs tops)
577 %************************************************************************
579 \subsection[flat-simultaneous]{Doing things simultaneously}
581 %************************************************************************
584 doSimultaneously :: AbstractC -> FlatM AbstractC
587 Generate code to perform the @CAssign@s and @COpStmt@s in the
588 input simultaneously, using temporary variables when necessary.
590 We use the strongly-connected component algorithm, in which
591 * the vertices are the statements
592 * an edge goes from s1 to s2 iff
593 s1 assigns to something s2 uses
594 that is, if s1 should *follow* s2 in the final order
598 Wow - fancy stuff. But are we ever going to do anything other than
599 assignments in parallel? If not, wouldn't it be simpler to generate
602 x1, x2, x3 = e1, e2, e3
615 and leave it to the C compiler to figure out whether it needs al
618 (Likewise, why not let the C compiler delete silly code like
627 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
628 -- for fast comparison
630 type CEdge = (CVertex, CVertex)
632 doSimultaneously abs_c
634 enlisted = en_list abs_c
636 case enlisted of -- it's often just one stmt
637 [] -> returnFlt AbsCNop
639 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
641 -- en_list puts all the assignments in a list, filtering out Nops and
642 -- assignments which do nothing
644 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
645 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
646 en_list other = [other]
648 sameAmode :: CAddrMode -> CAddrMode -> Bool
649 -- ToDo: Move this function, or make CAddrMode an instance of Eq
650 -- At the moment we put in just enough to catch the cases we want:
651 -- the second (destination) argument is always a CVal.
652 sameAmode (CReg r1) (CReg r2) = r1 == r2
653 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
654 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
655 sameAmode other1 other2 = False
657 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
658 doSimultaneously1 vertices
661 edges = concat (map edges_from vertices)
663 edges_from :: CVertex -> [CEdge]
664 edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
666 should_follow :: CVertex -> CVertex -> Bool
667 (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
668 = dest1 `conflictsWith` src2
669 (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
670 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
671 (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
672 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
673 (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
674 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
676 -- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
677 -- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
679 eq_vertex :: CVertex -> CVertex -> Bool
680 (n1, _) `eq_vertex` (n2, _) = n1 == n2
682 components = stronglyConnComp eq_vertex edges vertices
684 -- do_components deal with one strongly-connected component
685 do_component :: [CVertex] -> FlatM AbstractC
687 -- A singleton? Then just do it.
688 do_component [(n,abs_c)] = returnFlt abs_c
690 -- Two or more? Then go via temporaries.
691 do_component ((n,first_stmt):rest)
692 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
693 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
694 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
696 go_via_temps (CAssign dest src)
697 = getUniqFlt `thenFlt` \ uniq ->
699 the_temp = CTemp uniq (getAmodeRep dest)
701 returnFlt (CAssign the_temp src, CAssign dest the_temp)
703 go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
704 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
706 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
708 returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
709 mkAbstractCs (zipWith CAssign dests the_temps))
711 mapFlt do_component components `thenFlt` \ abs_cs ->
712 returnFlt (mkAbstractCs abs_cs)
716 @conflictsWith@ tells whether an assignment to its first argument will
717 screw up an access to its second.
720 conflictsWith :: CAddrMode -> CAddrMode -> Bool
721 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
722 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
723 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
724 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
725 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
726 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
728 other1 `conflictsWith` other2 = False
729 -- CAddr and literals are impossible on the LHS of an assignment
731 regConflictsWithRR :: MagicId -> RegRelative -> Bool
733 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
735 regConflictsWithRR SpA (SpARel _ _) = True
736 regConflictsWithRR SpB (SpBRel _ _) = True
737 regConflictsWithRR Hp (HpRel _ _) = True
738 regConflictsWithRR _ _ = False
740 rrConflictsWithRR :: Int -> Int -- Sizes of two things
741 -> RegRelative -> RegRelative -- The two amodes
744 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
746 rr (SpARel p1 o1) (SpARel p2 o2)
747 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
748 | s1 == 1 && s2 == 1 = b1 == b2
749 | otherwise = (b1+s1) >= b2 &&
755 rr (SpBRel p1 o1) (SpBRel p2 o2)
756 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
757 | s1 == 1 && s2 == 1 = b1 == b2
758 | otherwise = (b1+s1) >= b2 &&
764 rr (NodeRel o1) (NodeRel o2)
765 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
766 | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
767 | otherwise = True -- Give up
769 rr (HpRel _ _) (HpRel _ _) = True -- Give up
771 rr other1 other2 = False