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
26 import CLabel ( mkReturnPtLabel, CLabel )
27 import Digraph ( stronglyConnComp, SCC(..) )
28 import HeapOffs ( possiblyEqualHeapOffset )
29 import Id ( fIRST_TAG, SYN_IE(ConTag) )
30 import Literal ( literalPrimRep, Literal(..) )
31 import PrimRep ( getPrimRepSize, PrimRep(..) )
32 import Unique ( Unique{-instance Eq-} )
33 import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
34 import Util ( assocDefaultUsing, panic, Ord3(..) )
39 Check if there is any real code in some Abstract~C. If so, return it
40 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
42 It returns the "reduced" code in the Just part so that the work of
43 discarding AbsCNops isn't lost, and so that if the caller uses
44 the reduced version there's less danger of a big tree of AbsCNops getting
45 materialised and causing a space leak.
48 nonemptyAbsC :: AbstractC -> Maybe AbstractC
49 nonemptyAbsC AbsCNop = Nothing
50 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
51 Nothing -> nonemptyAbsC s2
52 Just x -> Just (AbsCStmts x s2)
53 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
56 nonemptyAbsC other = Just other
60 mkAbstractCs :: [AbstractC] -> AbstractC
61 mkAbstractCs [] = AbsCNop
62 mkAbstractCs cs = foldr1 mkAbsCStmts cs
64 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
65 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
66 mkAbsCStmts = AbsCStmts
68 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
69 = case (case (nonemptyAbsC abc2) of
71 Just d2 -> d2) of { abc2b ->
73 case (nonemptyAbsC abc1) of {
75 Just d1 -> AbsCStmts d1 abc2b
80 Get the sho' 'nuff statements out of an @AbstractC@.
82 mkAbsCStmtList :: AbstractC -> [AbstractC]
84 mkAbsCStmtList absC = mkAbsCStmtList' absC []
86 -- Optimised a la foldr/build!
88 mkAbsCStmtList' AbsCNop r = r
90 mkAbsCStmtList' (AbsCStmts s1 s2) r
91 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
93 mkAbsCStmtList' s@(CSimultaneous c) r
94 = if null (mkAbsCStmtList c) then r else s : r
96 mkAbsCStmtList' other r = other : r
100 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
102 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
103 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
105 -- Adjust the tags in the switch to start at zero.
106 -- This is the convention used by primitive ops which return algebraic
107 -- data types. Why? Because for two-constructor types, zero is faster
108 -- to create and distinguish from 1 than are 1 and 2.
110 -- We also need to convert to Literals to keep the CSwitch happy
112 = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
113 | (tag, abs_c) <- tagged_alts ]
116 %************************************************************************
118 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
120 %************************************************************************
123 magicIdPrimRep BaseReg = PtrRep
124 magicIdPrimRep StkOReg = PtrRep
125 magicIdPrimRep (VanillaReg kind _) = kind
126 magicIdPrimRep (FloatReg _) = FloatRep
127 magicIdPrimRep (DoubleReg _) = DoubleRep
128 magicIdPrimRep TagReg = IntRep
129 magicIdPrimRep RetReg = RetRep
130 magicIdPrimRep SpA = PtrRep
131 magicIdPrimRep SuA = PtrRep
132 magicIdPrimRep SpB = PtrRep
133 magicIdPrimRep SuB = PtrRep
134 magicIdPrimRep Hp = PtrRep
135 magicIdPrimRep HpLim = PtrRep
136 magicIdPrimRep LivenessReg = IntRep
137 magicIdPrimRep StdUpdRetVecReg = PtrRep
138 magicIdPrimRep StkStubReg = PtrRep
139 magicIdPrimRep CurCostCentre = CostCentreRep
140 magicIdPrimRep VoidReg = VoidRep
143 %************************************************************************
145 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
147 %************************************************************************
149 See also the return conventions for unboxed things; currently living
150 in @CgCon@ (next to the constructor return conventions).
152 ToDo: tiny tweaking may be in order
154 getAmodeRep :: CAddrMode -> PrimRep
156 getAmodeRep (CVal _ kind) = kind
157 getAmodeRep (CAddr _) = PtrRep
158 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
159 getAmodeRep (CTemp uniq kind) = kind
160 getAmodeRep (CLbl label kind) = kind
161 getAmodeRep (CUnVecLbl _ _) = PtrRep
162 getAmodeRep (CCharLike _) = PtrRep
163 getAmodeRep (CIntLike _) = PtrRep
164 getAmodeRep (CString _) = PtrRep
165 getAmodeRep (CLit lit) = literalPrimRep lit
166 getAmodeRep (CLitLit _ kind) = kind
167 getAmodeRep (COffset _) = IntRep
168 getAmodeRep (CCode abs_C) = CodePtrRep
169 getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
170 getAmodeRep (CTableEntry _ _ kind) = kind
171 getAmodeRep (CMacroExpr kind _ _) = kind
173 getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
174 getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
178 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
179 across a garbage collection. Used only for PrimOp arguments (not that
183 amodeCanSurviveGC :: CAddrMode -> Bool
185 amodeCanSurviveGC (CTableEntry base offset _)
186 = amodeCanSurviveGC base && amodeCanSurviveGC offset
187 -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
189 amodeCanSurviveGC (CLbl _ _) = True
190 amodeCanSurviveGC (CUnVecLbl _ _) = True
191 amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
192 amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
193 amodeCanSurviveGC (CString _) = True
194 amodeCanSurviveGC (CLit _) = True
195 amodeCanSurviveGC (CLitLit _ _) = True
196 amodeCanSurviveGC (COffset _) = True
197 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
199 amodeCanSurviveGC _ = False
200 -- there are some amodes that "cannot occur" as args
201 -- to a PrimOp, but it is safe to return False (rather than panic)
204 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
205 location; that is, one which can contain values of various types.
208 mixedTypeLocn :: CAddrMode -> Bool
210 mixedTypeLocn (CVal (NodeRel _) _) = True
211 mixedTypeLocn (CVal (SpBRel _ _) _) = True
212 mixedTypeLocn (CVal (HpRel _ _) _) = True
213 mixedTypeLocn other = False -- All the rest
216 @mixedPtrLocn@ tells whether an amode identifies a
217 location which can contain values of various pointer types.
220 mixedPtrLocn :: CAddrMode -> Bool
222 mixedPtrLocn (CVal (SpARel _ _) _) = True
223 mixedPtrLocn other = False -- All the rest
226 %************************************************************************
228 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
230 %************************************************************************
232 The following bits take ``raw'' Abstract~C, which may have all sorts of
233 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
234 @CClosureInfos@ and code for switches are pulled out to the top level.
236 The various functions herein tend to produce
239 A {\em flattened} \tr{<something>} of interest for ``here'', and
241 Some {\em unflattened} Abstract~C statements to be carried up to the
242 top-level. The only real reason (now) that it is unflattened is
243 because it means the recursive flattening can be done in just one
244 place rather than having to remember lots of places.
247 Care is taken to reduce the occurrence of forward references, while still
248 keeping laziness a much as possible. Essentially, this means that:
251 {\em All} the top-level C statements resulting from flattening a
252 particular AbsC statement (whether the latter is nested or not) appear
253 before {\em any} of the code for a subsequent AbsC statement;
255 but stuff nested within any AbsC statement comes
256 out before the code for the statement itself.
259 The ``stuff to be carried up'' always includes a label: a
260 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
261 @CCodeBlock@. The latter turns into a C function, and is never
262 actually produced by the code generator. Rather it always starts life
263 as a @CLabelledCode@ addressing mode; when such an addr mode is
264 flattened, the ``tops'' stuff is a @CCodeBlock@.
267 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
270 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
271 here `mkAbsCStmts` tops }
274 %************************************************************************
276 \subsubsection{Flattening monadery}
278 %************************************************************************
280 The flattener is monadised. It's just a @UniqueSupply@, along with a
281 ``come-back-to-here'' label to pin on heap and stack checks.
289 initFlt :: UniqSupply -> FlatM a -> a
291 initFlt init_us m = m (panic "initFlt:CLabel") init_us
293 {-# INLINE thenFlt #-}
294 {-# INLINE returnFlt #-}
296 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
298 thenFlt expr cont label us
299 = case (splitUniqSupply us) of { (s1, s2) ->
300 case (expr label s1) of { result ->
301 cont result label s2 }}
303 returnFlt :: a -> FlatM a
304 returnFlt result label us = result
306 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
308 mapFlt f [] = returnFlt []
310 = f x `thenFlt` \ r ->
311 mapFlt f xs `thenFlt` \ rs ->
314 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
316 mapAndUnzipFlt f [] = returnFlt ([],[])
317 mapAndUnzipFlt f (x:xs)
318 = f x `thenFlt` \ (r1, r2) ->
319 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
320 returnFlt (r1:rs1, r2:rs2)
322 getUniqFlt :: FlatM Unique
323 getUniqFlt label us = getUnique us
325 getUniqsFlt :: Int -> FlatM [Unique]
326 getUniqsFlt i label us = getUniques i us
328 setLabelFlt :: CLabel -> FlatM a -> FlatM a
329 setLabelFlt new_label cont label us = cont new_label us
331 getLabelFlt :: FlatM CLabel
332 getLabelFlt label us = label
335 %************************************************************************
337 \subsubsection{Flattening the top level}
339 %************************************************************************
342 flatAbsC :: AbstractC
343 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
344 AbstractC) -- Stuff to put at top level flattened]
346 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
348 flatAbsC (AbsCStmts s1 s2)
349 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
350 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
351 returnFlt (mkAbsCStmts inline_s1 inline_s2,
352 mkAbsCStmts top_s1 top_s2)
354 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
355 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
356 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
357 flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
358 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
359 CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
362 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
363 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
364 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
365 returnFlt (Just heres, tops)
367 flatAbsC (CCodeBlock label abs_C)
368 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
369 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
371 flatAbsC (CClosureUpdInfo info) = flatAbsC info
373 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
374 = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
375 returnFlt (AbsCNop, tops `mkAbsCStmts`
376 CStaticClosure closure_lbl closure_info new_cc new_amodes)
378 flatAbsC (CRetVector tbl_label stuff deflt)
379 = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
380 mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
381 returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
382 mkAbstractCs alt_tops,
383 CFlatRetVector tbl_label alt_amodes])
386 do_deflt deflt = case nonemptyAbsC deflt of
387 Nothing -> returnFlt (bogus_default_label, AbsCNop)
388 Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
389 -- CJump (CLabelledCode ...) case
391 do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
392 do_alt deflt_amode (Just alt) = flatAmode alt
394 bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
397 flatAbsC (CRetUnVector label amode)
398 = flatAmode amode `thenFlt` \ (new_amode, tops) ->
399 returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
401 flatAbsC (CFlatRetVector label amodes)
402 = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
403 returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
405 flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
406 = returnFlt (AbsCNop, cc)
408 -- now the real stmts:
410 flatAbsC (CAssign dest source)
411 = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
412 flatAmode source `thenFlt` \ (src_amode, src_tops) ->
413 returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
415 -- special case: jump to some anonymous code
416 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
418 flatAbsC (CJump target)
419 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
420 returnFlt ( CJump targ_amode, targ_tops )
422 flatAbsC (CFallThrough target)
423 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
424 returnFlt ( CFallThrough targ_amode, targ_tops )
426 flatAbsC (CReturn target return_info)
427 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
428 returnFlt ( CReturn targ_amode return_info, targ_tops )
430 flatAbsC (CSwitch discrim alts deflt)
431 = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
432 mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
433 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
435 CSwitch discrim_amode flat_alts flat_def_alt,
436 mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
440 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
441 returnFlt ( (tag, alt_heres), alt_tops )
443 flatAbsC stmt@(CInitHdr a b cc u)
444 = flatAmode cc `thenFlt` \ (new_cc, tops) ->
445 returnFlt (CInitHdr a b new_cc u, tops)
447 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
448 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
449 flatAmodes args `thenFlt` \ (args_here, tops2) ->
450 returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
451 mkAbsCStmts tops1 tops2)
453 flatAbsC stmt@(CSimultaneous abs_c)
454 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
455 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
456 returnFlt (new_stmts_here, tops)
458 flatAbsC stmt@(CMacroStmt macro amodes)
459 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
460 returnFlt (CMacroStmt macro amodes_here, tops)
462 flatAbsC stmt@(CCallProfCtrMacro str amodes)
463 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
464 returnFlt (CCallProfCtrMacro str amodes_here, tops)
466 flatAbsC stmt@(CCallProfCCMacro str amodes)
467 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
468 returnFlt (CCallProfCCMacro str amodes_here, tops)
470 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
473 %************************************************************************
475 \subsection[flat-amodes]{Flattening addressing modes}
477 %************************************************************************
480 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
483 flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
485 flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
486 flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
487 flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
488 flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
489 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
490 flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
491 flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
492 flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
493 flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
495 -- CIntLike must be a literal -- no flattening
496 flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
498 -- CCharLike may be arbitrary value -- have to flatten
499 flatAmode amode@(CCharLike char)
500 = flatAmode char `thenFlt` \ (flat_char, tops) ->
501 returnFlt(CCharLike flat_char, tops)
503 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
505 flatAmode (CLabelledCode label abs_C)
506 -- Push the code (with this label) to the top level
507 = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
508 returnFlt (CLbl label CodePtrRep,
509 tops `mkAbsCStmts` CCodeBlock label body_code)
511 flatAmode (CCode abs_C)
512 = case mkAbsCStmtList abs_C of
513 [CJump amode] -> flatAmode amode -- Elide redundant labels
515 -- de-anonymous-ise the code and push it (labelled) to the top level
516 getUniqFlt `thenFlt` \ new_uniq ->
517 case (mkReturnPtLabel new_uniq) of { return_pt_label ->
518 flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
520 CLbl return_pt_label CodePtrRep,
521 tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
522 -- DO NOT TOUCH the stuff sent to the top...
525 flatAmode (CTableEntry base index kind)
526 = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
527 flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
528 returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
530 flatAmode (CMacroExpr pk macro amodes)
531 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
532 returnFlt ( CMacroExpr pk macro amodes_here, tops )
534 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
537 And a convenient way to do a whole bunch of 'em.
539 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
541 flatAmodes [] = returnFlt ([], AbsCNop)
544 = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
545 returnFlt (amodes_here, mkAbstractCs tops)
548 %************************************************************************
550 \subsection[flat-simultaneous]{Doing things simultaneously}
552 %************************************************************************
555 doSimultaneously :: AbstractC -> FlatM AbstractC
558 Generate code to perform the @CAssign@s and @COpStmt@s in the
559 input simultaneously, using temporary variables when necessary.
561 We use the strongly-connected component algorithm, in which
562 * the vertices are the statements
563 * an edge goes from s1 to s2 iff
564 s1 assigns to something s2 uses
565 that is, if s1 should *follow* s2 in the final order
569 Wow - fancy stuff. But are we ever going to do anything other than
570 assignments in parallel? If not, wouldn't it be simpler to generate
573 x1, x2, x3 = e1, e2, e3
586 and leave it to the C compiler to figure out whether it needs al
589 (Likewise, why not let the C compiler delete silly code like
598 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
599 -- for fast comparison
601 type CEdge = (CVertex, CVertex)
603 doSimultaneously abs_c
605 enlisted = en_list abs_c
607 case enlisted of -- it's often just one stmt
608 [] -> returnFlt AbsCNop
610 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
612 -- en_list puts all the assignments in a list, filtering out Nops and
613 -- assignments which do nothing
615 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
616 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
617 en_list other = [other]
619 sameAmode :: CAddrMode -> CAddrMode -> Bool
620 -- ToDo: Move this function, or make CAddrMode an instance of Eq
621 -- At the moment we put in just enough to catch the cases we want:
622 -- the second (destination) argument is always a CVal.
623 sameAmode (CReg r1) (CReg r2) = r1 == r2
624 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
625 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
626 sameAmode other1 other2 = False
628 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
629 doSimultaneously1 vertices
631 edges = [ (vertex, key1, edges_from stmt1)
632 | vertex@(key1, stmt1) <- vertices
634 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
635 stmt1 `should_follow` stmt2
637 components = stronglyConnComp edges
639 -- do_components deal with one strongly-connected component
640 -- Not cyclic, or singleton? Just do it
641 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
642 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
644 -- Cyclic? Then go via temporaries. Pick one to
645 -- break the loop and try again with the rest.
646 do_component (CyclicSCC ((n,first_stmt) : rest))
647 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
648 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
649 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
651 go_via_temps (CAssign dest src)
652 = getUniqFlt `thenFlt` \ uniq ->
654 the_temp = CTemp uniq (getAmodeRep dest)
656 returnFlt (CAssign the_temp src, CAssign dest the_temp)
658 go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
659 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
661 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
663 returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
664 mkAbstractCs (zipWith CAssign dests the_temps))
666 mapFlt do_component components `thenFlt` \ abs_cs ->
667 returnFlt (mkAbstractCs abs_cs)
670 should_follow :: AbstractC -> AbstractC -> Bool
671 (CAssign dest1 _) `should_follow` (CAssign _ src2)
672 = dest1 `conflictsWith` src2
673 (COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2)
674 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
675 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _)
676 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
677 (COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _)
678 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
680 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
681 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
687 @conflictsWith@ tells whether an assignment to its first argument will
688 screw up an access to its second.
691 conflictsWith :: CAddrMode -> CAddrMode -> Bool
692 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
693 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
694 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
695 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
696 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
697 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
699 other1 `conflictsWith` other2 = False
700 -- CAddr and literals are impossible on the LHS of an assignment
702 regConflictsWithRR :: MagicId -> RegRelative -> Bool
704 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
706 regConflictsWithRR SpA (SpARel _ _) = True
707 regConflictsWithRR SpB (SpBRel _ _) = True
708 regConflictsWithRR Hp (HpRel _ _) = True
709 regConflictsWithRR _ _ = False
711 rrConflictsWithRR :: Int -> Int -- Sizes of two things
712 -> RegRelative -> RegRelative -- The two amodes
715 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
717 rr (SpARel p1 o1) (SpARel p2 o2)
718 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
719 | s1 == 1 && s2 == 1 = b1 == b2
720 | otherwise = (b1+s1) >= b2 &&
726 rr (SpBRel p1 o1) (SpBRel p2 o2)
727 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
728 | s1 == 1 && s2 == 1 = b1 == b2
729 | otherwise = (b1+s1) >= b2 &&
735 rr (NodeRel o1) (NodeRel o2)
736 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
737 | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
738 | otherwise = True -- Give up
740 rr (HpRel _ _) (HpRel _ _) = True -- Give up
742 rr other1 other2 = False