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
23 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 200
24 import AbsCLoop (mkReturnPtLabel, CLabel )
26 import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel )
27 -- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel)
32 import Digraph ( stronglyConnComp, SCC(..) )
33 import HeapOffs ( possiblyEqualHeapOffset )
34 import Id ( fIRST_TAG, SYN_IE(ConTag) )
35 import Literal ( literalPrimRep, Literal(..) )
36 import PrimRep ( getPrimRepSize, PrimRep(..) )
37 import Unique ( Unique{-instance Eq-} )
38 import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
39 import Util ( assocDefaultUsing, panic, Ord3(..) )
44 Check if there is any real code in some Abstract~C. If so, return it
45 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
47 It returns the "reduced" code in the Just part so that the work of
48 discarding AbsCNops isn't lost, and so that if the caller uses
49 the reduced version there's less danger of a big tree of AbsCNops getting
50 materialised and causing a space leak.
53 nonemptyAbsC :: AbstractC -> Maybe AbstractC
54 nonemptyAbsC AbsCNop = Nothing
55 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
56 Nothing -> nonemptyAbsC s2
57 Just x -> Just (AbsCStmts x s2)
58 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
61 nonemptyAbsC other = Just other
65 mkAbstractCs :: [AbstractC] -> AbstractC
66 mkAbstractCs [] = AbsCNop
67 mkAbstractCs cs = foldr1 mkAbsCStmts cs
69 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
70 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
71 mkAbsCStmts = AbsCStmts
73 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
74 = case (case (nonemptyAbsC abc2) of
76 Just d2 -> d2) of { abc2b ->
78 case (nonemptyAbsC abc1) of {
80 Just d1 -> AbsCStmts d1 abc2b
85 Get the sho' 'nuff statements out of an @AbstractC@.
87 mkAbsCStmtList :: AbstractC -> [AbstractC]
89 mkAbsCStmtList absC = mkAbsCStmtList' absC []
91 -- Optimised a la foldr/build!
93 mkAbsCStmtList' AbsCNop r = r
95 mkAbsCStmtList' (AbsCStmts s1 s2) r
96 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
98 mkAbsCStmtList' s@(CSimultaneous c) r
99 = if null (mkAbsCStmtList c) then r else s : r
101 mkAbsCStmtList' other r = other : r
105 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
107 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
108 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
110 -- Adjust the tags in the switch to start at zero.
111 -- This is the convention used by primitive ops which return algebraic
112 -- data types. Why? Because for two-constructor types, zero is faster
113 -- to create and distinguish from 1 than are 1 and 2.
115 -- We also need to convert to Literals to keep the CSwitch happy
117 = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
118 | (tag, abs_c) <- tagged_alts ]
121 %************************************************************************
123 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
125 %************************************************************************
128 magicIdPrimRep BaseReg = PtrRep
129 magicIdPrimRep StkOReg = PtrRep
130 magicIdPrimRep (VanillaReg kind _) = kind
131 magicIdPrimRep (FloatReg _) = FloatRep
132 magicIdPrimRep (DoubleReg _) = DoubleRep
133 magicIdPrimRep TagReg = IntRep
134 magicIdPrimRep RetReg = RetRep
135 magicIdPrimRep SpA = PtrRep
136 magicIdPrimRep SuA = PtrRep
137 magicIdPrimRep SpB = PtrRep
138 magicIdPrimRep SuB = PtrRep
139 magicIdPrimRep Hp = PtrRep
140 magicIdPrimRep HpLim = PtrRep
141 magicIdPrimRep LivenessReg = IntRep
142 magicIdPrimRep StdUpdRetVecReg = PtrRep
143 magicIdPrimRep StkStubReg = PtrRep
144 magicIdPrimRep CurCostCentre = CostCentreRep
145 magicIdPrimRep VoidReg = VoidRep
148 %************************************************************************
150 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
152 %************************************************************************
154 See also the return conventions for unboxed things; currently living
155 in @CgCon@ (next to the constructor return conventions).
157 ToDo: tiny tweaking may be in order
159 getAmodeRep :: CAddrMode -> PrimRep
161 getAmodeRep (CVal _ kind) = kind
162 getAmodeRep (CAddr _) = PtrRep
163 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
164 getAmodeRep (CTemp uniq kind) = kind
165 getAmodeRep (CLbl label kind) = kind
166 getAmodeRep (CUnVecLbl _ _) = PtrRep
167 getAmodeRep (CCharLike _) = PtrRep
168 getAmodeRep (CIntLike _) = PtrRep
169 getAmodeRep (CString _) = PtrRep
170 getAmodeRep (CLit lit) = literalPrimRep lit
171 getAmodeRep (CLitLit _ kind) = kind
172 getAmodeRep (COffset _) = IntRep
173 getAmodeRep (CCode abs_C) = CodePtrRep
174 getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
175 getAmodeRep (CTableEntry _ _ kind) = kind
176 getAmodeRep (CMacroExpr kind _ _) = kind
178 getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
179 getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
183 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
184 across a garbage collection. Used only for PrimOp arguments (not that
188 amodeCanSurviveGC :: CAddrMode -> Bool
190 amodeCanSurviveGC (CTableEntry base offset _)
191 = amodeCanSurviveGC base && amodeCanSurviveGC offset
192 -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
194 amodeCanSurviveGC (CLbl _ _) = True
195 amodeCanSurviveGC (CUnVecLbl _ _) = True
196 amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
197 amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
198 amodeCanSurviveGC (CString _) = True
199 amodeCanSurviveGC (CLit _) = True
200 amodeCanSurviveGC (CLitLit _ _) = True
201 amodeCanSurviveGC (COffset _) = True
202 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
204 amodeCanSurviveGC _ = False
205 -- there are some amodes that "cannot occur" as args
206 -- to a PrimOp, but it is safe to return False (rather than panic)
209 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
210 location; that is, one which can contain values of various types.
213 mixedTypeLocn :: CAddrMode -> Bool
215 mixedTypeLocn (CVal (NodeRel _) _) = True
216 mixedTypeLocn (CVal (SpBRel _ _) _) = True
217 mixedTypeLocn (CVal (HpRel _ _) _) = True
218 mixedTypeLocn other = False -- All the rest
221 @mixedPtrLocn@ tells whether an amode identifies a
222 location which can contain values of various pointer types.
225 mixedPtrLocn :: CAddrMode -> Bool
227 mixedPtrLocn (CVal (SpARel _ _) _) = True
228 mixedPtrLocn other = False -- All the rest
231 %************************************************************************
233 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
235 %************************************************************************
237 The following bits take ``raw'' Abstract~C, which may have all sorts of
238 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
239 @CClosureInfos@ and code for switches are pulled out to the top level.
241 The various functions herein tend to produce
244 A {\em flattened} \tr{<something>} of interest for ``here'', and
246 Some {\em unflattened} Abstract~C statements to be carried up to the
247 top-level. The only real reason (now) that it is unflattened is
248 because it means the recursive flattening can be done in just one
249 place rather than having to remember lots of places.
252 Care is taken to reduce the occurrence of forward references, while still
253 keeping laziness a much as possible. Essentially, this means that:
256 {\em All} the top-level C statements resulting from flattening a
257 particular AbsC statement (whether the latter is nested or not) appear
258 before {\em any} of the code for a subsequent AbsC statement;
260 but stuff nested within any AbsC statement comes
261 out before the code for the statement itself.
264 The ``stuff to be carried up'' always includes a label: a
265 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
266 @CCodeBlock@. The latter turns into a C function, and is never
267 actually produced by the code generator. Rather it always starts life
268 as a @CLabelledCode@ addressing mode; when such an addr mode is
269 flattened, the ``tops'' stuff is a @CCodeBlock@.
272 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
275 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
276 here `mkAbsCStmts` tops }
279 %************************************************************************
281 \subsubsection{Flattening monadery}
283 %************************************************************************
285 The flattener is monadised. It's just a @UniqueSupply@, along with a
286 ``come-back-to-here'' label to pin on heap and stack checks.
294 initFlt :: UniqSupply -> FlatM a -> a
296 initFlt init_us m = m (panic "initFlt:CLabel") init_us
298 {-# INLINE thenFlt #-}
299 {-# INLINE returnFlt #-}
301 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
303 thenFlt expr cont label us
304 = case (splitUniqSupply us) of { (s1, s2) ->
305 case (expr label s1) of { result ->
306 cont result label s2 }}
308 returnFlt :: a -> FlatM a
309 returnFlt result label us = result
311 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
313 mapFlt f [] = returnFlt []
315 = f x `thenFlt` \ r ->
316 mapFlt f xs `thenFlt` \ rs ->
319 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
321 mapAndUnzipFlt f [] = returnFlt ([],[])
322 mapAndUnzipFlt f (x:xs)
323 = f x `thenFlt` \ (r1, r2) ->
324 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
325 returnFlt (r1:rs1, r2:rs2)
327 getUniqFlt :: FlatM Unique
328 getUniqFlt label us = getUnique us
330 getUniqsFlt :: Int -> FlatM [Unique]
331 getUniqsFlt i label us = getUniques i us
333 setLabelFlt :: CLabel -> FlatM a -> FlatM a
334 setLabelFlt new_label cont label us = cont new_label us
336 getLabelFlt :: FlatM CLabel
337 getLabelFlt label us = label
340 %************************************************************************
342 \subsubsection{Flattening the top level}
344 %************************************************************************
347 flatAbsC :: AbstractC
348 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
349 AbstractC) -- Stuff to put at top level flattened]
351 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
353 flatAbsC (AbsCStmts s1 s2)
354 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
355 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
356 returnFlt (mkAbsCStmts inline_s1 inline_s2,
357 mkAbsCStmts top_s1 top_s2)
359 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
360 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
361 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
362 flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
363 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
364 CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
367 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
368 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
369 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
370 returnFlt (Just heres, tops)
372 flatAbsC (CCodeBlock label abs_C)
373 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
374 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
376 flatAbsC (CClosureUpdInfo info) = flatAbsC info
378 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
379 = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
380 returnFlt (AbsCNop, tops `mkAbsCStmts`
381 CStaticClosure closure_lbl closure_info new_cc new_amodes)
383 flatAbsC (CRetVector tbl_label stuff deflt)
384 = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
385 mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
386 returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
387 mkAbstractCs alt_tops,
388 CFlatRetVector tbl_label alt_amodes])
391 do_deflt deflt = case nonemptyAbsC deflt of
392 Nothing -> returnFlt (bogus_default_label, AbsCNop)
393 Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
394 -- CJump (CLabelledCode ...) case
396 do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
397 do_alt deflt_amode (Just alt) = flatAmode alt
399 bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
402 flatAbsC (CRetUnVector label amode)
403 = flatAmode amode `thenFlt` \ (new_amode, tops) ->
404 returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
406 flatAbsC (CFlatRetVector label amodes)
407 = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
408 returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
410 flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
411 = returnFlt (AbsCNop, cc)
413 -- now the real stmts:
415 flatAbsC (CAssign dest source)
416 = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
417 flatAmode source `thenFlt` \ (src_amode, src_tops) ->
418 returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
420 -- special case: jump to some anonymous code
421 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
423 flatAbsC (CJump target)
424 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
425 returnFlt ( CJump targ_amode, targ_tops )
427 flatAbsC (CFallThrough target)
428 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
429 returnFlt ( CFallThrough targ_amode, targ_tops )
431 flatAbsC (CReturn target return_info)
432 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
433 returnFlt ( CReturn targ_amode return_info, targ_tops )
435 flatAbsC (CSwitch discrim alts deflt)
436 = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
437 mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
438 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
440 CSwitch discrim_amode flat_alts flat_def_alt,
441 mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
445 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
446 returnFlt ( (tag, alt_heres), alt_tops )
448 flatAbsC stmt@(CInitHdr a b cc u)
449 = flatAmode cc `thenFlt` \ (new_cc, tops) ->
450 returnFlt (CInitHdr a b new_cc u, tops)
452 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
453 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
454 flatAmodes args `thenFlt` \ (args_here, tops2) ->
455 returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
456 mkAbsCStmts tops1 tops2)
458 flatAbsC stmt@(CSimultaneous abs_c)
459 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
460 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
461 returnFlt (new_stmts_here, tops)
463 flatAbsC stmt@(CMacroStmt macro amodes)
464 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
465 returnFlt (CMacroStmt macro amodes_here, tops)
467 flatAbsC stmt@(CCallProfCtrMacro str amodes)
468 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
469 returnFlt (CCallProfCtrMacro str amodes_here, tops)
471 flatAbsC stmt@(CCallProfCCMacro str amodes)
472 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
473 returnFlt (CCallProfCCMacro str amodes_here, tops)
475 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
478 %************************************************************************
480 \subsection[flat-amodes]{Flattening addressing modes}
482 %************************************************************************
485 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
488 flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
490 flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
491 flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
492 flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
493 flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
494 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
495 flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
496 flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
497 flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
498 flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
500 -- CIntLike must be a literal -- no flattening
501 flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
503 -- CCharLike may be arbitrary value -- have to flatten
504 flatAmode amode@(CCharLike char)
505 = flatAmode char `thenFlt` \ (flat_char, tops) ->
506 returnFlt(CCharLike flat_char, tops)
508 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
510 flatAmode (CLabelledCode label abs_C)
511 -- Push the code (with this label) to the top level
512 = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
513 returnFlt (CLbl label CodePtrRep,
514 tops `mkAbsCStmts` CCodeBlock label body_code)
516 flatAmode (CCode abs_C)
517 = case mkAbsCStmtList abs_C of
518 [CJump amode] -> flatAmode amode -- Elide redundant labels
520 -- de-anonymous-ise the code and push it (labelled) to the top level
521 getUniqFlt `thenFlt` \ new_uniq ->
522 case (mkReturnPtLabel new_uniq) of { return_pt_label ->
523 flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
525 CLbl return_pt_label CodePtrRep,
526 tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
527 -- DO NOT TOUCH the stuff sent to the top...
530 flatAmode (CTableEntry base index kind)
531 = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
532 flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
533 returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
535 flatAmode (CMacroExpr pk macro amodes)
536 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
537 returnFlt ( CMacroExpr pk macro amodes_here, tops )
539 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
542 And a convenient way to do a whole bunch of 'em.
544 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
546 flatAmodes [] = returnFlt ([], AbsCNop)
549 = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
550 returnFlt (amodes_here, mkAbstractCs tops)
553 %************************************************************************
555 \subsection[flat-simultaneous]{Doing things simultaneously}
557 %************************************************************************
560 doSimultaneously :: AbstractC -> FlatM AbstractC
563 Generate code to perform the @CAssign@s and @COpStmt@s in the
564 input simultaneously, using temporary variables when necessary.
566 We use the strongly-connected component algorithm, in which
567 * the vertices are the statements
568 * an edge goes from s1 to s2 iff
569 s1 assigns to something s2 uses
570 that is, if s1 should *follow* s2 in the final order
574 Wow - fancy stuff. But are we ever going to do anything other than
575 assignments in parallel? If not, wouldn't it be simpler to generate
578 x1, x2, x3 = e1, e2, e3
591 and leave it to the C compiler to figure out whether it needs al
594 (Likewise, why not let the C compiler delete silly code like
603 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
604 -- for fast comparison
606 type CEdge = (CVertex, CVertex)
608 doSimultaneously abs_c
610 enlisted = en_list abs_c
612 case enlisted of -- it's often just one stmt
613 [] -> returnFlt AbsCNop
615 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
617 -- en_list puts all the assignments in a list, filtering out Nops and
618 -- assignments which do nothing
620 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
621 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
622 en_list other = [other]
624 sameAmode :: CAddrMode -> CAddrMode -> Bool
625 -- ToDo: Move this function, or make CAddrMode an instance of Eq
626 -- At the moment we put in just enough to catch the cases we want:
627 -- the second (destination) argument is always a CVal.
628 sameAmode (CReg r1) (CReg r2) = r1 == r2
629 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
630 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
631 sameAmode other1 other2 = False
633 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
634 doSimultaneously1 vertices
636 edges = [ (vertex, key1, edges_from stmt1)
637 | vertex@(key1, stmt1) <- vertices
639 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
640 stmt1 `should_follow` stmt2
642 components = stronglyConnComp edges
644 -- do_components deal with one strongly-connected component
645 -- Not cyclic, or singleton? Just do it
646 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
647 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
649 -- Cyclic? Then go via temporaries. Pick one to
650 -- break the loop and try again with the rest.
651 do_component (CyclicSCC ((n,first_stmt) : rest))
652 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
653 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
654 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
656 go_via_temps (CAssign dest src)
657 = getUniqFlt `thenFlt` \ uniq ->
659 the_temp = CTemp uniq (getAmodeRep dest)
661 returnFlt (CAssign the_temp src, CAssign dest the_temp)
663 go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
664 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
666 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
668 returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
669 mkAbstractCs (zipWith CAssign dests the_temps))
671 mapFlt do_component components `thenFlt` \ abs_cs ->
672 returnFlt (mkAbstractCs abs_cs)
675 should_follow :: AbstractC -> AbstractC -> Bool
676 (CAssign dest1 _) `should_follow` (CAssign _ src2)
677 = dest1 `conflictsWith` src2
678 (COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2)
679 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
680 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _)
681 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
682 (COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _)
683 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
685 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
686 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
692 @conflictsWith@ tells whether an assignment to its first argument will
693 screw up an access to its second.
696 conflictsWith :: CAddrMode -> CAddrMode -> Bool
697 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
698 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
699 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
700 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
701 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
702 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
704 other1 `conflictsWith` other2 = False
705 -- CAddr and literals are impossible on the LHS of an assignment
707 regConflictsWithRR :: MagicId -> RegRelative -> Bool
709 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
711 regConflictsWithRR SpA (SpARel _ _) = True
712 regConflictsWithRR SpB (SpBRel _ _) = True
713 regConflictsWithRR Hp (HpRel _ _) = True
714 regConflictsWithRR _ _ = False
716 rrConflictsWithRR :: Int -> Int -- Sizes of two things
717 -> RegRelative -> RegRelative -- The two amodes
720 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
722 rr (SpARel p1 o1) (SpARel p2 o2)
723 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
724 | s1 == 1 && s2 == 1 = b1 == b2
725 | otherwise = (b1+s1) >= b2 &&
731 rr (SpBRel p1 o1) (SpBRel p2 o2)
732 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
733 | s1 == 1 && s2 == 1 = b1 == b2
734 | otherwise = (b1+s1) >= b2 &&
740 rr (NodeRel o1) (NodeRel o2)
741 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
742 | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
743 | otherwise = True -- Give up
745 rr (HpRel _ _) (HpRel _ _) = True -- Give up
747 rr other1 other2 = False