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 )
27 import Digraph ( stronglyConnComp )
28 import HeapOffs ( possiblyEqualHeapOffset )
29 import Id ( fIRST_TAG, ConTag(..) )
30 import Literal ( literalPrimRep, Literal(..) )
31 import PrimRep ( getPrimRepSize, PrimRep(..) )
32 import Unique ( Unique{-instance Eq-} )
33 import UniqSupply ( getUnique, getUniques, splitUniqSupply )
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 = BIND (case (nonemptyAbsC abc2) of
71 Just d2 -> d2) _TO_ abc2b ->
73 case (nonemptyAbsC abc1) of {
75 Just d1 -> AbsCStmts d1 abc2b
79 = case (nonemptyAbsC abc1) of
81 Just d1 -> AbsCStmts d1 abc2
84 = case (nonemptyAbsC abc1) of
85 Nothing -> case (nonemptyAbsC abc2) of
88 Just d1 -> AbsCStmts d1 abc2
95 else if {- abc1 not empty but -} abc2_empty then
97 else {- neither empty -}
100 abc1_empty = noAbsCcode abc1
101 abc2_empty = noAbsCcode abc2
105 Get the sho' 'nuff statements out of an @AbstractC@.
107 mkAbsCStmtList :: AbstractC -> [AbstractC]
109 mkAbsCStmtList absC = mkAbsCStmtList' absC []
111 -- Optimised a la foldr/build!
113 mkAbsCStmtList' AbsCNop r = r
115 mkAbsCStmtList' (AbsCStmts s1 s2) r
116 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
118 mkAbsCStmtList' s@(CSimultaneous c) r
119 = if null (mkAbsCStmtList c) then r else s : r
121 mkAbsCStmtList' other r = other : r
125 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
127 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
128 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
130 -- Adjust the tags in the switch to start at zero.
131 -- This is the convention used by primitive ops which return algebraic
132 -- data types. Why? Because for two-constructor types, zero is faster
133 -- to create and distinguish from 1 than are 1 and 2.
135 -- We also need to convert to Literals to keep the CSwitch happy
137 = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
138 | (tag, abs_c) <- tagged_alts ]
141 %************************************************************************
143 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
145 %************************************************************************
148 magicIdPrimRep BaseReg = PtrRep
149 magicIdPrimRep StkOReg = PtrRep
150 magicIdPrimRep (VanillaReg kind _) = kind
151 magicIdPrimRep (FloatReg _) = FloatRep
152 magicIdPrimRep (DoubleReg _) = DoubleRep
153 magicIdPrimRep TagReg = IntRep
154 magicIdPrimRep RetReg = RetRep
155 magicIdPrimRep SpA = PtrRep
156 magicIdPrimRep SuA = PtrRep
157 magicIdPrimRep SpB = PtrRep
158 magicIdPrimRep SuB = PtrRep
159 magicIdPrimRep Hp = PtrRep
160 magicIdPrimRep HpLim = PtrRep
161 magicIdPrimRep LivenessReg = IntRep
162 magicIdPrimRep StdUpdRetVecReg = PtrRep
163 magicIdPrimRep StkStubReg = PtrRep
164 magicIdPrimRep CurCostCentre = CostCentreRep
165 magicIdPrimRep VoidReg = VoidRep
168 %************************************************************************
170 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
172 %************************************************************************
174 See also the return conventions for unboxed things; currently living
175 in @CgCon@ (next to the constructor return conventions).
177 ToDo: tiny tweaking may be in order
179 getAmodeRep :: CAddrMode -> PrimRep
181 getAmodeRep (CVal _ kind) = kind
182 getAmodeRep (CAddr _) = PtrRep
183 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
184 getAmodeRep (CTemp uniq kind) = kind
185 getAmodeRep (CLbl label kind) = kind
186 getAmodeRep (CUnVecLbl _ _) = PtrRep
187 getAmodeRep (CCharLike _) = PtrRep
188 getAmodeRep (CIntLike _) = PtrRep
189 getAmodeRep (CString _) = PtrRep
190 getAmodeRep (CLit lit) = literalPrimRep lit
191 getAmodeRep (CLitLit _ kind) = kind
192 getAmodeRep (COffset _) = IntRep
193 getAmodeRep (CCode abs_C) = CodePtrRep
194 getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
195 getAmodeRep (CTableEntry _ _ kind) = kind
196 getAmodeRep (CMacroExpr kind _ _) = kind
198 getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
199 getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
203 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
204 across a garbage collection. Used only for PrimOp arguments (not that
208 amodeCanSurviveGC :: CAddrMode -> Bool
210 amodeCanSurviveGC (CTableEntry base offset _)
211 = amodeCanSurviveGC base && amodeCanSurviveGC offset
212 -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
214 amodeCanSurviveGC (CLbl _ _) = True
215 amodeCanSurviveGC (CUnVecLbl _ _) = True
216 amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
217 amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
218 amodeCanSurviveGC (CString _) = True
219 amodeCanSurviveGC (CLit _) = True
220 amodeCanSurviveGC (CLitLit _ _) = True
221 amodeCanSurviveGC (COffset _) = True
222 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
224 amodeCanSurviveGC _ = False
225 -- there are some amodes that "cannot occur" as args
226 -- to a PrimOp, but it is safe to return False (rather than panic)
229 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
230 location; that is, one which can contain values of various types.
233 mixedTypeLocn :: CAddrMode -> Bool
235 mixedTypeLocn (CVal (NodeRel _) _) = True
236 mixedTypeLocn (CVal (SpBRel _ _) _) = True
237 mixedTypeLocn (CVal (HpRel _ _) _) = True
238 mixedTypeLocn other = False -- All the rest
241 @mixedPtrLocn@ tells whether an amode identifies a
242 location which can contain values of various pointer types.
245 mixedPtrLocn :: CAddrMode -> Bool
247 mixedPtrLocn (CVal (SpARel _ _) _) = True
248 mixedPtrLocn other = False -- All the rest
251 %************************************************************************
253 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
255 %************************************************************************
257 The following bits take ``raw'' Abstract~C, which may have all sorts of
258 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
259 @CClosureInfos@ and code for switches are pulled out to the top level.
261 The various functions herein tend to produce
264 A {\em flattened} \tr{<something>} of interest for ``here'', and
266 Some {\em unflattened} Abstract~C statements to be carried up to the
267 top-level. The only real reason (now) that it is unflattened is
268 because it means the recursive flattening can be done in just one
269 place rather than having to remember lots of places.
272 Care is taken to reduce the occurrence of forward references, while still
273 keeping laziness a much as possible. Essentially, this means that:
276 {\em All} the top-level C statements resulting from flattening a
277 particular AbsC statement (whether the latter is nested or not) appear
278 before {\em any} of the code for a subsequent AbsC statement;
280 but stuff nested within any AbsC statement comes
281 out before the code for the statement itself.
284 The ``stuff to be carried up'' always includes a label: a
285 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
286 @CCodeBlock@. The latter turns into a C function, and is never
287 actually produced by the code generator. Rather it always starts life
288 as a @CLabelledCode@ addressing mode; when such an addr mode is
289 flattened, the ``tops'' stuff is a @CCodeBlock@.
292 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
295 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
296 here `mkAbsCStmts` tops }
299 %************************************************************************
301 \subsubsection{Flattening monadery}
303 %************************************************************************
305 The flattener is monadised. It's just a @UniqueSupply@, along with a
306 ``come-back-to-here'' label to pin on heap and stack checks.
314 initFlt :: UniqSupply -> FlatM a -> a
316 initFlt init_us m = m (panic "initFlt:CLabel") init_us
318 {-# INLINE thenFlt #-}
319 {-# INLINE returnFlt #-}
321 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
323 thenFlt expr cont label us
324 = case (splitUniqSupply us) of { (s1, s2) ->
325 case (expr label s1) of { result ->
326 cont result label s2 }}
328 returnFlt :: a -> FlatM a
329 returnFlt result label us = result
331 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
333 mapFlt f [] = returnFlt []
335 = f x `thenFlt` \ r ->
336 mapFlt f xs `thenFlt` \ rs ->
339 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
341 mapAndUnzipFlt f [] = returnFlt ([],[])
342 mapAndUnzipFlt f (x:xs)
343 = f x `thenFlt` \ (r1, r2) ->
344 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
345 returnFlt (r1:rs1, r2:rs2)
347 getUniqFlt :: FlatM Unique
348 getUniqFlt label us = getUnique us
350 getUniqsFlt :: Int -> FlatM [Unique]
351 getUniqsFlt i label us = getUniques i us
353 setLabelFlt :: CLabel -> FlatM a -> FlatM a
354 setLabelFlt new_label cont label us = cont new_label us
356 getLabelFlt :: FlatM CLabel
357 getLabelFlt label us = label
360 %************************************************************************
362 \subsubsection{Flattening the top level}
364 %************************************************************************
367 flatAbsC :: AbstractC
368 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
369 AbstractC) -- Stuff to put at top level flattened]
371 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
373 flatAbsC (AbsCStmts s1 s2)
374 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
375 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
376 returnFlt (mkAbsCStmts inline_s1 inline_s2,
377 mkAbsCStmts top_s1 top_s2)
379 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
380 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
381 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
382 flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
383 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
384 CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
387 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
388 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
389 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
390 returnFlt (Just heres, tops)
392 flatAbsC (CCodeBlock label abs_C)
393 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
394 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
396 flatAbsC (CClosureUpdInfo info) = flatAbsC info
398 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
399 = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
400 returnFlt (AbsCNop, tops `mkAbsCStmts`
401 CStaticClosure closure_lbl closure_info new_cc new_amodes)
403 flatAbsC (CRetVector tbl_label stuff deflt)
404 = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
405 mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
406 returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
407 mkAbstractCs alt_tops,
408 CFlatRetVector tbl_label alt_amodes])
411 do_deflt deflt = case nonemptyAbsC deflt of
412 Nothing -> returnFlt (bogus_default_label, AbsCNop)
413 Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
414 -- CJump (CLabelledCode ...) case
416 do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
417 do_alt deflt_amode (Just alt) = flatAmode alt
419 bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
422 flatAbsC (CRetUnVector label amode)
423 = flatAmode amode `thenFlt` \ (new_amode, tops) ->
424 returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
426 flatAbsC (CFlatRetVector label amodes)
427 = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
428 returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
430 flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
431 = returnFlt (AbsCNop, cc)
433 -- now the real stmts:
435 flatAbsC (CAssign dest source)
436 = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
437 flatAmode source `thenFlt` \ (src_amode, src_tops) ->
438 returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
440 -- special case: jump to some anonymous code
441 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
443 flatAbsC (CJump target)
444 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
445 returnFlt ( CJump targ_amode, targ_tops )
447 flatAbsC (CFallThrough target)
448 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
449 returnFlt ( CFallThrough targ_amode, targ_tops )
451 flatAbsC (CReturn target return_info)
452 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
453 returnFlt ( CReturn targ_amode return_info, targ_tops )
455 flatAbsC (CSwitch discrim alts deflt)
456 = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
457 mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
458 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
460 CSwitch discrim_amode flat_alts flat_def_alt,
461 mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
465 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
466 returnFlt ( (tag, alt_heres), alt_tops )
468 flatAbsC stmt@(CInitHdr a b cc u)
469 = flatAmode cc `thenFlt` \ (new_cc, tops) ->
470 returnFlt (CInitHdr a b new_cc u, tops)
472 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
473 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
474 flatAmodes args `thenFlt` \ (args_here, tops2) ->
475 returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
476 mkAbsCStmts tops1 tops2)
478 flatAbsC stmt@(CSimultaneous abs_c)
479 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
480 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
481 returnFlt (new_stmts_here, tops)
483 flatAbsC stmt@(CMacroStmt macro amodes)
484 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
485 returnFlt (CMacroStmt macro amodes_here, tops)
487 flatAbsC stmt@(CCallProfCtrMacro str amodes)
488 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
489 returnFlt (CCallProfCtrMacro str amodes_here, tops)
491 flatAbsC stmt@(CCallProfCCMacro str amodes)
492 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
493 returnFlt (CCallProfCCMacro str amodes_here, tops)
495 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
498 %************************************************************************
500 \subsection[flat-amodes]{Flattening addressing modes}
502 %************************************************************************
505 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
508 flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
510 flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
511 flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
512 flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
513 flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
514 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
515 flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
516 flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
517 flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
518 flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
520 -- CIntLike must be a literal -- no flattening
521 flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
523 -- CCharLike may be arbitrary value -- have to flatten
524 flatAmode amode@(CCharLike char)
525 = flatAmode char `thenFlt` \ (flat_char, tops) ->
526 returnFlt(CCharLike flat_char, tops)
528 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
530 flatAmode (CLabelledCode label abs_C)
531 -- Push the code (with this label) to the top level
532 = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
533 returnFlt (CLbl label CodePtrRep,
534 tops `mkAbsCStmts` CCodeBlock label body_code)
536 flatAmode (CCode abs_C)
537 = case mkAbsCStmtList abs_C of
538 [CJump amode] -> flatAmode amode -- Elide redundant labels
540 -- de-anonymous-ise the code and push it (labelled) to the top level
541 getUniqFlt `thenFlt` \ new_uniq ->
542 BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label ->
543 flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
545 CLbl return_pt_label CodePtrRep,
546 tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
547 -- DO NOT TOUCH the stuff sent to the top...
551 flatAmode (CTableEntry base index kind)
552 = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
553 flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
554 returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
556 flatAmode (CMacroExpr pk macro amodes)
557 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
558 returnFlt ( CMacroExpr pk macro amodes_here, tops )
560 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
563 And a convenient way to do a whole bunch of 'em.
565 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
567 flatAmodes [] = returnFlt ([], AbsCNop)
570 = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
571 returnFlt (amodes_here, mkAbstractCs tops)
574 %************************************************************************
576 \subsection[flat-simultaneous]{Doing things simultaneously}
578 %************************************************************************
581 doSimultaneously :: AbstractC -> FlatM AbstractC
584 Generate code to perform the @CAssign@s and @COpStmt@s in the
585 input simultaneously, using temporary variables when necessary.
587 We use the strongly-connected component algorithm, in which
588 * the vertices are the statements
589 * an edge goes from s1 to s2 iff
590 s1 assigns to something s2 uses
591 that is, if s1 should *follow* s2 in the final order
595 Wow - fancy stuff. But are we ever going to do anything other than
596 assignments in parallel? If not, wouldn't it be simpler to generate
599 x1, x2, x3 = e1, e2, e3
612 and leave it to the C compiler to figure out whether it needs al
615 (Likewise, why not let the C compiler delete silly code like
624 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
625 -- for fast comparison
627 type CEdge = (CVertex, CVertex)
629 doSimultaneously abs_c
631 enlisted = en_list abs_c
633 case enlisted of -- it's often just one stmt
634 [] -> returnFlt AbsCNop
636 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
638 -- en_list puts all the assignments in a list, filtering out Nops and
639 -- assignments which do nothing
641 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
642 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
643 en_list other = [other]
645 sameAmode :: CAddrMode -> CAddrMode -> Bool
646 -- ToDo: Move this function, or make CAddrMode an instance of Eq
647 -- At the moment we put in just enough to catch the cases we want:
648 -- the second (destination) argument is always a CVal.
649 sameAmode (CReg r1) (CReg r2) = r1 == r2
650 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
651 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
652 sameAmode other1 other2 = False
654 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
655 doSimultaneously1 vertices
658 edges = concat (map edges_from vertices)
660 edges_from :: CVertex -> [CEdge]
661 edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
663 should_follow :: CVertex -> CVertex -> Bool
664 (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
665 = dest1 `conflictsWith` src2
666 (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
667 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
668 (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
669 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
670 (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
671 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
673 -- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
674 -- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
676 eq_vertex :: CVertex -> CVertex -> Bool
677 (n1, _) `eq_vertex` (n2, _) = n1 == n2
679 components = stronglyConnComp eq_vertex edges vertices
681 -- do_components deal with one strongly-connected component
682 do_component :: [CVertex] -> FlatM AbstractC
684 -- A singleton? Then just do it.
685 do_component [(n,abs_c)] = returnFlt abs_c
687 -- Two or more? Then go via temporaries.
688 do_component ((n,first_stmt):rest)
689 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
690 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
691 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
693 go_via_temps (CAssign dest src)
694 = getUniqFlt `thenFlt` \ uniq ->
696 the_temp = CTemp uniq (getAmodeRep dest)
698 returnFlt (CAssign the_temp src, CAssign dest the_temp)
700 go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
701 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
703 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
705 returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
706 mkAbstractCs (zipWith CAssign dests the_temps))
708 mapFlt do_component components `thenFlt` \ abs_cs ->
709 returnFlt (mkAbstractCs abs_cs)
713 @conflictsWith@ tells whether an assignment to its first argument will
714 screw up an access to its second.
717 conflictsWith :: CAddrMode -> CAddrMode -> Bool
718 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
719 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
720 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
721 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
722 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
723 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
725 other1 `conflictsWith` other2 = False
726 -- CAddr and literals are impossible on the LHS of an assignment
728 regConflictsWithRR :: MagicId -> RegRelative -> Bool
730 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
732 regConflictsWithRR SpA (SpARel _ _) = True
733 regConflictsWithRR SpB (SpBRel _ _) = True
734 regConflictsWithRR Hp (HpRel _ _) = True
735 regConflictsWithRR _ _ = False
737 rrConflictsWithRR :: Int -> Int -- Sizes of two things
738 -> RegRelative -> RegRelative -- The two amodes
741 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
743 rr (SpARel p1 o1) (SpARel p2 o2)
744 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
745 | s1 == 1 && s2 == 1 = b1 == b2
746 | otherwise = (b1+s1) >= b2 &&
752 rr (SpBRel p1 o1) (SpBRel p2 o2)
753 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
754 | s1 == 1 && s2 == 1 = b1 == b2
755 | otherwise = (b1+s1) >= b2 &&
761 rr (NodeRel o1) (NodeRel o2)
762 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
763 | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
764 | otherwise = True -- Give up
766 rr (HpRel _ _) (HpRel _ _) = True -- Give up
768 rr other1 other2 = False