2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
9 mkAbstractCs, mkAbsCStmts,
12 getAmodeRep, amodeCanSurviveGC,
13 mixedTypeLocn, mixedPtrLocn,
17 -- printing/forcing stuff comes from PprAbsC
20 #include "HsVersions.h"
22 import {-# SOURCE #-} CLabel ( mkReturnPtLabel, CLabel )
23 -- The loop here is (CLabel -> CgRetConv -> AbsCUtils -> CLabel)
27 import Digraph ( stronglyConnComp, SCC(..) )
28 import HeapOffs ( possiblyEqualHeapOffset )
29 import Id ( fIRST_TAG, ConTag )
30 import Literal ( literalPrimRep, Literal(..), mkMachWord )
31 import PrimRep ( getPrimRepSize, PrimRep(..) )
32 import Unique ( Unique{-instance Eq-} )
33 import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply )
34 import Util ( assocDefaultUsing, panic )
35 import CmdLineOpts ( opt_ProduceC )
36 import Maybes ( maybeToBool )
37 import PrimOp ( PrimOp(..) )
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 = case (case (nonemptyAbsC abc2) of
74 Just d2 -> d2) of { abc2b ->
76 case (nonemptyAbsC abc1) of {
78 Just d1 -> AbsCStmts d1 abc2b
83 Get the sho' 'nuff statements out of an @AbstractC@.
85 mkAbsCStmtList :: AbstractC -> [AbstractC]
87 mkAbsCStmtList absC = mkAbsCStmtList' absC []
89 -- Optimised a la foldr/build!
91 mkAbsCStmtList' AbsCNop r = r
93 mkAbsCStmtList' (AbsCStmts s1 s2) r
94 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
96 mkAbsCStmtList' s@(CSimultaneous c) r
97 = if null (mkAbsCStmtList c) then r else s : r
99 mkAbsCStmtList' other r = other : r
103 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
105 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
106 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
108 -- Adjust the tags in the switch to start at zero.
109 -- This is the convention used by primitive ops which return algebraic
110 -- data types. Why? Because for two-constructor types, zero is faster
111 -- to create and distinguish from 1 than are 1 and 2.
113 -- We also need to convert to Literals to keep the CSwitch happy
115 = [ (mkMachWord (fromInt (tag - fIRST_TAG)), abs_c) | (tag, abs_c) <- tagged_alts ]
118 %************************************************************************
120 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
122 %************************************************************************
125 magicIdPrimRep BaseReg = PtrRep
126 magicIdPrimRep StkOReg = PtrRep
127 magicIdPrimRep (VanillaReg kind _) = kind
128 magicIdPrimRep (FloatReg _) = FloatRep
129 magicIdPrimRep (DoubleReg _) = DoubleRep
130 magicIdPrimRep (LongReg kind _) = kind
131 magicIdPrimRep TagReg = IntRep
132 magicIdPrimRep RetReg = RetRep
133 magicIdPrimRep SpA = PtrRep
134 magicIdPrimRep SuA = PtrRep
135 magicIdPrimRep SpB = PtrRep
136 magicIdPrimRep SuB = PtrRep
137 magicIdPrimRep Hp = PtrRep
138 magicIdPrimRep HpLim = PtrRep
139 magicIdPrimRep LivenessReg = IntRep
140 magicIdPrimRep StdUpdRetVecReg = PtrRep
141 magicIdPrimRep StkStubReg = PtrRep
142 magicIdPrimRep CurCostCentre = CostCentreRep
143 magicIdPrimRep VoidReg = VoidRep
146 %************************************************************************
148 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
150 %************************************************************************
152 See also the return conventions for unboxed things; currently living
153 in @CgCon@ (next to the constructor return conventions).
155 ToDo: tiny tweaking may be in order
157 getAmodeRep :: CAddrMode -> PrimRep
159 getAmodeRep (CVal _ kind) = kind
160 getAmodeRep (CAddr _) = PtrRep
161 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
162 getAmodeRep (CTemp uniq kind) = kind
163 getAmodeRep (CLbl label kind) = kind
164 getAmodeRep (CUnVecLbl _ _) = PtrRep
165 getAmodeRep (CCharLike _) = PtrRep
166 getAmodeRep (CIntLike _) = PtrRep
167 getAmodeRep (CString _) = PtrRep
168 getAmodeRep (CLit lit) = literalPrimRep lit
169 getAmodeRep (CLitLit _ kind) = kind
170 getAmodeRep (COffset _) = IntRep
171 getAmodeRep (CCode abs_C) = CodePtrRep
172 getAmodeRep (CLabelledCode label abs_C) = CodePtrRep
173 getAmodeRep (CTableEntry _ _ kind) = kind
174 getAmodeRep (CMacroExpr kind _ _) = kind
176 getAmodeRep (CJoinPoint _ _) = panic "getAmodeRep:CJoinPoint"
177 getAmodeRep (CCostCentre _ _) = panic "getAmodeRep:CCostCentre"
181 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
182 across a garbage collection. Used only for PrimOp arguments (not that
186 amodeCanSurviveGC :: CAddrMode -> Bool
188 amodeCanSurviveGC (CTableEntry base offset _)
189 = amodeCanSurviveGC base && amodeCanSurviveGC offset
190 -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
192 amodeCanSurviveGC (CLbl _ _) = True
193 amodeCanSurviveGC (CUnVecLbl _ _) = True
194 amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
195 amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
196 amodeCanSurviveGC (CString _) = True
197 amodeCanSurviveGC (CLit _) = True
198 amodeCanSurviveGC (CLitLit _ _) = True
199 amodeCanSurviveGC (COffset _) = True
200 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
202 amodeCanSurviveGC _ = False
203 -- there are some amodes that "cannot occur" as args
204 -- to a PrimOp, but it is safe to return False (rather than panic)
207 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
208 location; that is, one which can contain values of various types.
211 mixedTypeLocn :: CAddrMode -> Bool
213 mixedTypeLocn (CVal (NodeRel _) _) = True
214 mixedTypeLocn (CVal (SpBRel _ _) _) = True
215 mixedTypeLocn (CVal (HpRel _ _) _) = True
216 mixedTypeLocn other = False -- All the rest
219 @mixedPtrLocn@ tells whether an amode identifies a
220 location which can contain values of various pointer types.
223 mixedPtrLocn :: CAddrMode -> Bool
225 mixedPtrLocn (CVal (SpARel _ _) _) = True
226 mixedPtrLocn other = False -- All the rest
229 %************************************************************************
231 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
233 %************************************************************************
235 The following bits take ``raw'' Abstract~C, which may have all sorts of
236 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
237 @CClosureInfos@ and code for switches are pulled out to the top level.
239 The various functions herein tend to produce
242 A {\em flattened} \tr{<something>} of interest for ``here'', and
244 Some {\em unflattened} Abstract~C statements to be carried up to the
245 top-level. The only real reason (now) that it is unflattened is
246 because it means the recursive flattening can be done in just one
247 place rather than having to remember lots of places.
250 Care is taken to reduce the occurrence of forward references, while still
251 keeping laziness a much as possible. Essentially, this means that:
254 {\em All} the top-level C statements resulting from flattening a
255 particular AbsC statement (whether the latter is nested or not) appear
256 before {\em any} of the code for a subsequent AbsC statement;
258 but stuff nested within any AbsC statement comes
259 out before the code for the statement itself.
262 The ``stuff to be carried up'' always includes a label: a
263 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
264 @CCodeBlock@. The latter turns into a C function, and is never
265 actually produced by the code generator. Rather it always starts life
266 as a @CLabelledCode@ addressing mode; when such an addr mode is
267 flattened, the ``tops'' stuff is a @CCodeBlock@.
270 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
273 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
274 here `mkAbsCStmts` tops }
277 %************************************************************************
279 \subsubsection{Flattening monadery}
281 %************************************************************************
283 The flattener is monadised. It's just a @UniqueSupply@, along with a
284 ``come-back-to-here'' label to pin on heap and stack checks.
292 initFlt :: UniqSupply -> FlatM a -> a
294 initFlt init_us m = m (panic "initFlt:CLabel") init_us
296 {-# INLINE thenFlt #-}
297 {-# INLINE returnFlt #-}
299 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
301 thenFlt expr cont label us
302 = case (splitUniqSupply us) of { (s1, s2) ->
303 case (expr label s1) of { result ->
304 cont result label s2 }}
306 returnFlt :: a -> FlatM a
307 returnFlt result label us = result
309 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
311 mapFlt f [] = returnFlt []
313 = f x `thenFlt` \ r ->
314 mapFlt f xs `thenFlt` \ rs ->
317 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
319 mapAndUnzipFlt f [] = returnFlt ([],[])
320 mapAndUnzipFlt f (x:xs)
321 = f x `thenFlt` \ (r1, r2) ->
322 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
323 returnFlt (r1:rs1, r2:rs2)
325 getUniqFlt :: FlatM Unique
326 getUniqFlt label us = getUnique us
328 getUniqsFlt :: Int -> FlatM [Unique]
329 getUniqsFlt i label us = getUniques i us
331 setLabelFlt :: CLabel -> FlatM a -> FlatM a
332 setLabelFlt new_label cont label us = cont new_label us
334 getLabelFlt :: FlatM CLabel
335 getLabelFlt label us = label
338 %************************************************************************
340 \subsubsection{Flattening the top level}
342 %************************************************************************
345 flatAbsC :: AbstractC
346 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
347 AbstractC) -- Stuff to put at top level flattened]
349 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
351 flatAbsC (AbsCStmts s1 s2)
352 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
353 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
354 returnFlt (mkAbsCStmts inline_s1 inline_s2,
355 mkAbsCStmts top_s1 top_s2)
357 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
358 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
359 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
360 flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
361 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
362 CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
365 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
366 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
367 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
368 returnFlt (Just heres, tops)
370 flatAbsC (CCodeBlock label abs_C)
371 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
372 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
374 flatAbsC (CClosureUpdInfo info) = flatAbsC info
376 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
377 = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
378 returnFlt (AbsCNop, tops `mkAbsCStmts`
379 CStaticClosure closure_lbl closure_info new_cc new_amodes)
381 flatAbsC (CRetVector tbl_label stuff deflt)
382 = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
383 mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
384 returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
385 mkAbstractCs alt_tops,
386 CFlatRetVector tbl_label alt_amodes])
389 do_deflt deflt = case nonemptyAbsC deflt of
390 Nothing -> returnFlt (bogus_default_label, AbsCNop)
391 Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
392 -- CJump (CLabelledCode ...) case
394 do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
395 do_alt deflt_amode (Just alt) = flatAmode alt
397 bogus_default_label = panic ("flatAbsC: CRetVector: default needed and not available")
400 flatAbsC (CRetUnVector label amode)
401 = flatAmode amode `thenFlt` \ (new_amode, tops) ->
402 returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
404 flatAbsC (CFlatRetVector label amodes)
405 = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
406 returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
408 flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
409 = returnFlt (AbsCNop, cc)
411 -- now the real stmts:
413 flatAbsC (CAssign dest source)
414 = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
415 flatAmode source `thenFlt` \ (src_amode, src_tops) ->
416 returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
418 -- special case: jump to some anonymous code
419 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
421 flatAbsC (CJump target)
422 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
423 returnFlt ( CJump targ_amode, targ_tops )
425 flatAbsC (CFallThrough target)
426 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
427 returnFlt ( CFallThrough targ_amode, targ_tops )
429 flatAbsC (CReturn target return_info)
430 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
431 returnFlt ( CReturn targ_amode return_info, targ_tops )
433 flatAbsC (CSwitch discrim alts deflt)
434 = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
435 mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
436 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
438 CSwitch discrim_amode flat_alts flat_def_alt,
439 mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
443 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
444 returnFlt ( (tag, alt_heres), alt_tops )
446 flatAbsC stmt@(CInitHdr a b cc u)
447 = flatAmode cc `thenFlt` \ (new_cc, tops) ->
448 returnFlt (CInitHdr a b new_cc u, tops)
450 flatAbsC stmt@(COpStmt results td@(CCallOp (Right _) _ _ _ _ _) args liveness_mask vol_regs)
451 | maybeToBool opt_ProduceC
452 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
453 flatAmodes args `thenFlt` \ (args_here, tops2) ->
454 let tdef = CCallTypedef td results args in
455 returnFlt (COpStmt results_here td args_here liveness_mask vol_regs,
456 mkAbsCStmts tdef (mkAbsCStmts tops1 tops2))
458 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
459 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
460 flatAmodes args `thenFlt` \ (args_here, tops2) ->
461 returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
462 mkAbsCStmts tops1 tops2)
464 flatAbsC stmt@(CSimultaneous abs_c)
465 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
466 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
467 returnFlt (new_stmts_here, tops)
469 flatAbsC stmt@(CMacroStmt macro amodes)
470 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
471 returnFlt (CMacroStmt macro amodes_here, tops)
473 flatAbsC stmt@(CCallProfCtrMacro str amodes)
474 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
475 returnFlt (CCallProfCtrMacro str amodes_here, tops)
477 flatAbsC stmt@(CCallProfCCMacro str amodes)
478 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
479 returnFlt (CCallProfCCMacro str amodes_here, tops)
481 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
484 %************************************************************************
486 \subsection[flat-amodes]{Flattening addressing modes}
488 %************************************************************************
491 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
494 flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
496 flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
497 flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
498 flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
499 flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
500 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
501 flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
502 flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
503 flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
504 flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
506 -- CIntLike must be a literal -- no flattening
507 flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
509 -- CCharLike may be arbitrary value -- have to flatten
510 flatAmode amode@(CCharLike char)
511 = flatAmode char `thenFlt` \ (flat_char, tops) ->
512 returnFlt(CCharLike flat_char, tops)
514 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
516 flatAmode (CLabelledCode label abs_C)
517 -- Push the code (with this label) to the top level
518 = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
519 returnFlt (CLbl label CodePtrRep,
520 tops `mkAbsCStmts` CCodeBlock label body_code)
522 flatAmode (CCode abs_C)
523 = case mkAbsCStmtList abs_C of
524 [CJump amode] -> flatAmode amode -- Elide redundant labels
526 -- de-anonymous-ise the code and push it (labelled) to the top level
527 getUniqFlt `thenFlt` \ new_uniq ->
528 case (mkReturnPtLabel new_uniq) of { return_pt_label ->
529 flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
531 CLbl return_pt_label CodePtrRep,
532 tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
533 -- DO NOT TOUCH the stuff sent to the top...
536 flatAmode (CTableEntry base index kind)
537 = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
538 flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
539 returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
541 flatAmode (CMacroExpr pk macro amodes)
542 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
543 returnFlt ( CMacroExpr pk macro amodes_here, tops )
545 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
548 And a convenient way to do a whole bunch of 'em.
550 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
552 flatAmodes [] = returnFlt ([], AbsCNop)
555 = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
556 returnFlt (amodes_here, mkAbstractCs tops)
559 %************************************************************************
561 \subsection[flat-simultaneous]{Doing things simultaneously}
563 %************************************************************************
566 doSimultaneously :: AbstractC -> FlatM AbstractC
569 Generate code to perform the @CAssign@s and @COpStmt@s in the
570 input simultaneously, using temporary variables when necessary.
572 We use the strongly-connected component algorithm, in which
573 * the vertices are the statements
574 * an edge goes from s1 to s2 iff
575 s1 assigns to something s2 uses
576 that is, if s1 should *follow* s2 in the final order
580 Wow - fancy stuff. But are we ever going to do anything other than
581 assignments in parallel? If not, wouldn't it be simpler to generate
584 x1, x2, x3 = e1, e2, e3
597 and leave it to the C compiler to figure out whether it needs al
600 (Likewise, why not let the C compiler delete silly code like
609 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
610 -- for fast comparison
612 type CEdge = (CVertex, CVertex)
614 doSimultaneously abs_c
616 enlisted = en_list abs_c
618 case enlisted of -- it's often just one stmt
619 [] -> returnFlt AbsCNop
621 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
623 -- en_list puts all the assignments in a list, filtering out Nops and
624 -- assignments which do nothing
626 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
627 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
628 en_list other = [other]
630 sameAmode :: CAddrMode -> CAddrMode -> Bool
631 -- ToDo: Move this function, or make CAddrMode an instance of Eq
632 -- At the moment we put in just enough to catch the cases we want:
633 -- the second (destination) argument is always a CVal.
634 sameAmode (CReg r1) (CReg r2) = r1 == r2
635 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
636 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
637 sameAmode other1 other2 = False
639 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
640 doSimultaneously1 vertices
642 edges = [ (vertex, key1, edges_from stmt1)
643 | vertex@(key1, stmt1) <- vertices
645 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
646 stmt1 `should_follow` stmt2
648 components = stronglyConnComp edges
650 -- do_components deal with one strongly-connected component
651 -- Not cyclic, or singleton? Just do it
652 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
653 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
655 -- Cyclic? Then go via temporaries. Pick one to
656 -- break the loop and try again with the rest.
657 do_component (CyclicSCC ((n,first_stmt) : rest))
658 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
659 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
660 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
662 go_via_temps (CAssign dest src)
663 = getUniqFlt `thenFlt` \ uniq ->
665 the_temp = CTemp uniq (getAmodeRep dest)
667 returnFlt (CAssign the_temp src, CAssign dest the_temp)
669 go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
670 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
672 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
674 returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
675 mkAbstractCs (zipWith CAssign dests the_temps))
677 mapFlt do_component components `thenFlt` \ abs_cs ->
678 returnFlt (mkAbstractCs abs_cs)
681 should_follow :: AbstractC -> AbstractC -> Bool
682 (CAssign dest1 _) `should_follow` (CAssign _ src2)
683 = dest1 `conflictsWith` src2
684 (COpStmt dests1 _ _ _ _) `should_follow` (CAssign _ src2)
685 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
686 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _ _)
687 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
688 (COpStmt dests1 _ _ _ _) `should_follow` (COpStmt _ _ srcs2 _ _)
689 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
691 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
692 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
698 @conflictsWith@ tells whether an assignment to its first argument will
699 screw up an access to its second.
702 conflictsWith :: CAddrMode -> CAddrMode -> Bool
703 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
704 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
705 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
706 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
707 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
708 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
710 other1 `conflictsWith` other2 = False
711 -- CAddr and literals are impossible on the LHS of an assignment
713 regConflictsWithRR :: MagicId -> RegRelative -> Bool
715 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
717 regConflictsWithRR SpA (SpARel _ _) = True
718 regConflictsWithRR SpB (SpBRel _ _) = True
719 regConflictsWithRR Hp (HpRel _ _) = True
720 regConflictsWithRR _ _ = False
722 rrConflictsWithRR :: Int -> Int -- Sizes of two things
723 -> RegRelative -> RegRelative -- The two amodes
726 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
728 rr (SpARel p1 o1) (SpARel p2 o2)
729 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
730 | s1 == 1 && s2 == 1 = b1 == b2
731 | otherwise = (b1+s1) >= b2 &&
737 rr (SpBRel p1 o1) (SpBRel p2 o2)
738 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
739 | s1 == 1 && s2 == 1 = b1 == b2
740 | otherwise = (b1+s1) >= b2 &&
746 rr (NodeRel o1) (NodeRel o2)
747 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
748 | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
749 | otherwise = True -- Give up
751 rr (HpRel _ _) (HpRel _ _) = True -- Give up
753 rr other1 other2 = False