2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
4 \section[AbsCFuns]{Help functions for Abstract~C datatype}
7 #include "HsVersions.h"
11 mkAbstractCs, mkAbsCStmts,
14 getAmodeKind, amodeCanSurviveGC,
15 mixedTypeLocn, mixedPtrLocn,
17 --UNUSED: getDestinationRegs,
20 -- printing/forcing stuff comes from PprAbsC
22 -- and for interface self-sufficiency...
23 AbstractC, CAddrMode, PrimKind, SplitUniqSupply
28 import AbsPrel ( PrimOp(..)
29 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
30 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
32 import AbsUniType ( kindFromType, splitTyArgs, TauType(..),
33 TyVar, TyCon, Arity(..), Class, UniType
34 IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpClass)
35 IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
36 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
40 import CLabelInfo ( CLabel, mkReturnPtLabel, mkVecTblLabel )
42 import CLabelInfo ( CLabel, mkReturnPtLabel,
43 isNestableBlockLabel, isSlowFastLabelPair )
44 #endif {- Data Parallel Haskell -}
46 import BasicLit ( kindOfBasicLit )
47 import Digraph ( stronglyConnComp )
48 import Id ( fIRST_TAG, ConTag(..), DataCon(..), Id )
49 import Maybes ( Maybe(..) )
50 import PrimKind ( getKindSize, retKindSize, PrimKind(..) )
52 import StgSyn ( StgAtom )
53 import Unique -- UniqueSupply primitives used in flattening monad
59 Check if there is any real code in some Abstract~C. If so, return it
60 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
62 It returns the "reduced" code in the Just part so that the work of
63 discarding AbsCNops isn't lost, and so that if the caller uses
64 the reduced version there's less danger of a big tree of AbsCNops getting
65 materialised and causing a space leak.
68 nonemptyAbsC :: AbstractC -> Maybe AbstractC
69 nonemptyAbsC AbsCNop = Nothing
70 --UNUSED:nonemptyAbsC (CComment _) = Nothing
71 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
72 Nothing -> nonemptyAbsC s2
73 Just x -> Just (AbsCStmts x s2)
74 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
77 nonemptyAbsC other = Just other
81 mkAbstractCs :: [AbstractC] -> AbstractC
82 mkAbstractCs [] = AbsCNop
83 mkAbstractCs cs = foldr1 mkAbsCStmts cs
85 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
86 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
87 mkAbsCStmts = AbsCStmts
89 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
90 = BIND (case (nonemptyAbsC abc2) of
92 Just d2 -> d2) _TO_ abc2b ->
94 case (nonemptyAbsC abc1) of {
96 Just d1 -> AbsCStmts d1 abc2b
100 = case (nonemptyAbsC abc1) of
102 Just d1 -> AbsCStmts d1 abc2
105 = case (nonemptyAbsC abc1) of
106 Nothing -> case (nonemptyAbsC abc2) of
109 Just d1 -> AbsCStmts d1 abc2
116 else if {- abc1 not empty but -} abc2_empty then
118 else {- neither empty -}
121 abc1_empty = noAbsCcode abc1
122 abc2_empty = noAbsCcode abc2
126 Get the sho' 'nuff statements out of an @AbstractC@.
129 mkAbsCStmtList :: AbstractC -> [AbstractC]
131 mkAbsCStmtList AbsCNop = []
132 --UNUSED:mkAbsCStmtList (CComment _) = []
133 mkAbsCStmtList (AbsCStmts s1 s2) = mkAbsCStmtList s1 ++ mkAbsCStmtList s2
134 mkAbsCStmtList s@(CSimultaneous c) = if null (mkAbsCStmtList c)
137 mkAbsCStmtList other = [other]
140 mkAbsCStmtList :: AbstractC -> [AbstractC]
141 mkAbsCStmtList absC = mkAbsCStmtList' absC []
143 -- Optimised a la foldr/build!
145 mkAbsCStmtList' AbsCNop r = r
146 --UNUSED:mkAbsCStmtList' (CComment _) r = r
147 mkAbsCStmtList' (AbsCStmts s1 s2) r =
148 mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
149 mkAbsCStmtList' s@(CSimultaneous c) r =
150 if null (mkAbsCStmtList c) then r else s : r
151 mkAbsCStmtList' other r = other : r
156 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
158 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
159 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
161 -- Adjust the tags in the switch to start at zero.
162 -- This is the convention used by primitive ops which return algebraic
163 -- data types. Why? Because for two-constructor types, zero is faster
164 -- to create and distinguish from 1 than are 1 and 2.
166 -- We also need to convert to BasicLits to keep the CSwitch happy
168 = [ (MachInt (toInteger (tag - fIRST_TAG)) False{-unsigned-}, abs_c)
169 | (tag, abs_c) <- tagged_alts ]
172 %************************************************************************
174 \subsubsection[AbsCFuns-kinds-from-MagicIds]{Kinds from MagicIds}
176 %************************************************************************
179 kindFromMagicId BaseReg = PtrKind
180 kindFromMagicId StkOReg = PtrKind
181 kindFromMagicId (VanillaReg kind _) = kind
182 kindFromMagicId (FloatReg _) = FloatKind
183 kindFromMagicId (DoubleReg _) = DoubleKind
184 kindFromMagicId TagReg = IntKind
185 kindFromMagicId RetReg = RetKind
186 kindFromMagicId SpA = PtrKind
187 kindFromMagicId SuA = PtrKind
188 kindFromMagicId SpB = PtrKind
189 kindFromMagicId SuB = PtrKind
190 kindFromMagicId Hp = PtrKind
191 kindFromMagicId HpLim = PtrKind
192 kindFromMagicId LivenessReg = IntKind
193 --kindFromMagicId ActivityReg = IntKind -- UNUSED
194 kindFromMagicId StdUpdRetVecReg = PtrKind
195 kindFromMagicId StkStubReg = PtrKind
196 kindFromMagicId CurCostCentre = CostCentreKind
197 kindFromMagicId VoidReg = VoidKind
199 kindFromMagicId (DataReg _ n) = kind
200 #endif {- Data Parallel Haskell -}
203 %************************************************************************
205 \subsection[AbsCFuns-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
207 %************************************************************************
209 See also the return conventions for unboxed things; currently living
210 in @CgCon@ (next to the constructor return conventions).
212 ToDo: tiny tweaking may be in order
214 getAmodeKind :: CAddrMode -> PrimKind
216 getAmodeKind (CVal _ kind) = kind
217 getAmodeKind (CAddr _) = PtrKind
218 getAmodeKind (CReg magic_id) = kindFromMagicId magic_id
219 getAmodeKind (CTemp uniq kind) = kind
220 getAmodeKind (CLbl label kind) = kind
221 getAmodeKind (CUnVecLbl _ _) = PtrKind
222 getAmodeKind (CCharLike _) = PtrKind
223 getAmodeKind (CIntLike _) = PtrKind
224 getAmodeKind (CString _) = PtrKind
225 getAmodeKind (CLit lit) = kindOfBasicLit lit
226 getAmodeKind (CLitLit _ kind) = kind
227 getAmodeKind (COffset _) = IntKind
228 getAmodeKind (CCode abs_C) = CodePtrKind
229 getAmodeKind (CLabelledCode label abs_C) = CodePtrKind
230 getAmodeKind (CJoinPoint _ _) = panic "getAmodeKind:CJoinPoint"
231 getAmodeKind (CTableEntry _ _ kind) = kind
232 getAmodeKind (CMacroExpr kind _ _) = kind
233 getAmodeKind (CCostCentre _ _) = panic "getAmodeKind:CCostCentre"
236 @amodeCanSurviveGC@ tells, well, whether or not the amode is invariant
237 across a garbage collection. Used only for PrimOp arguments (not that
241 amodeCanSurviveGC :: CAddrMode -> Bool
243 amodeCanSurviveGC (CTableEntry base offset _)
244 = amodeCanSurviveGC base && amodeCanSurviveGC offset
245 -- "Fixed table, so it's OK" (JSM); code is slightly paranoid
247 amodeCanSurviveGC (CLbl _ _) = True
248 amodeCanSurviveGC (CUnVecLbl _ _) = True
249 amodeCanSurviveGC (CCharLike arg) = amodeCanSurviveGC arg
250 amodeCanSurviveGC (CIntLike arg) = amodeCanSurviveGC arg
251 amodeCanSurviveGC (CString _) = True
252 amodeCanSurviveGC (CLit _) = True
253 amodeCanSurviveGC (CLitLit _ _) = True
254 amodeCanSurviveGC (COffset _) = True
255 amodeCanSurviveGC (CMacroExpr _ _ args) = all amodeCanSurviveGC args
257 amodeCanSurviveGC _ = False
258 -- there are some amodes that "cannot occur" as args
259 -- to a PrimOp, but it is safe to return False (rather than panic)
262 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
263 location; that is, one which can contain values of various types.
266 mixedTypeLocn :: CAddrMode -> Bool
268 mixedTypeLocn (CVal (NodeRel _) _) = True
269 mixedTypeLocn (CVal (SpBRel _ _) _) = True
270 mixedTypeLocn (CVal (HpRel _ _) _) = True
271 mixedTypeLocn other = False -- All the rest
274 @mixedPtrLocn@ tells whether an amode identifies a
275 location which can contain values of various pointer types.
278 mixedPtrLocn :: CAddrMode -> Bool
280 mixedPtrLocn (CVal (SpARel _ _) _) = True
281 mixedPtrLocn other = False -- All the rest
284 %************************************************************************
286 \subsection[AbsCFuns-flattening]{Flatten Abstract~C}
288 %************************************************************************
290 The following bits take ``raw'' Abstract~C, which may have all sorts of
291 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
292 @CClosureInfos@ and code for switches are pulled out to the top level.
294 The various functions herein tend to produce
297 A {\em flattened} \tr{<something>} of interest for ``here'', and
299 Some {\em unflattened} Abstract~C statements to be carried up to the
300 top-level. The only real reason (now) that it is unflattened is
301 because it means the recursive flattening can be done in just one
302 place rather than having to remember lots of places.
305 Care is taken to reduce the occurrence of forward references, while still
306 keeping laziness a much as possible. Essentially, this means that:
309 {\em All} the top-level C statements resulting from flattening a
310 particular AbsC statement (whether the latter is nested or not) appear
311 before {\em any} of the code for a subsequent AbsC statement;
313 but stuff nested within any AbsC statement comes
314 out before the code for the statement itself.
317 The ``stuff to be carried up'' always includes a label: a
318 @CStaticClosure@, @CClosureUpdInfo@, @CRetUnVector@, @CFlatRetVector@, or
319 @CCodeBlock@. The latter turns into a C function, and is never
320 actually produced by the code generator. Rather it always starts life
321 as a @CLabelledCode@ addressing mode; when such an addr mode is
322 flattened, the ``tops'' stuff is a @CCodeBlock@.
325 flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
328 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
329 here `mkAbsCStmts` tops }
332 %************************************************************************
334 \subsubsection{Flattening monadery}
336 %************************************************************************
338 The flattener is monadised. It's just a @UniqueSupply@, along with a
339 ``come-back-to-here'' label to pin on heap and stack checks.
347 initFlt :: SplitUniqSupply -> FlatM a -> a
349 initFlt init_us m = m (panic "initFlt:CLabel") init_us
351 #ifdef __GLASGOW_HASKELL__
352 {-# INLINE thenFlt #-}
353 {-# INLINE returnFlt #-}
356 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
358 thenFlt expr cont label us
359 = case (splitUniqSupply us) of { (s1, s2) ->
360 case (expr label s1) of { result ->
361 cont result label s2 }}
363 returnFlt :: a -> FlatM a
364 returnFlt result label us = result
366 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
368 mapFlt f [] = returnFlt []
370 = f x `thenFlt` \ r ->
371 mapFlt f xs `thenFlt` \ rs ->
374 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
376 mapAndUnzipFlt f [] = returnFlt ([],[])
377 mapAndUnzipFlt f (x:xs)
378 = f x `thenFlt` \ (r1, r2) ->
379 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
380 returnFlt (r1:rs1, r2:rs2)
382 getUniqFlt :: FlatM Unique
383 getUniqFlt label us = getSUnique us
385 getUniqsFlt :: Int -> FlatM [Unique]
386 getUniqsFlt i label us = getSUniques i us
388 setLabelFlt :: CLabel -> FlatM a -> FlatM a
389 setLabelFlt new_label cont label us = cont new_label us
391 getLabelFlt :: FlatM CLabel
392 getLabelFlt label us = label
395 %************************************************************************
397 \subsubsection{Flattening the top level}
399 %************************************************************************
402 flatAbsC :: AbstractC
403 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
404 AbstractC) -- Stuff to put at top level flattened]
406 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
408 flatAbsC (AbsCStmts s1 s2)
409 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
410 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
411 returnFlt (mkAbsCStmts inline_s1 inline_s2,
412 mkAbsCStmts top_s1 top_s2)
414 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
415 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
416 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
417 flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
418 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
419 CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
422 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
423 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
424 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
425 returnFlt (Just heres, tops)
427 flatAbsC (CCodeBlock label abs_C)
428 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
429 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock label absC_heres)
431 flatAbsC (CClosureUpdInfo info) = flatAbsC info
433 flatAbsC (CStaticClosure closure_lbl closure_info cost_centre amodes)
434 = flatAmodes (cost_centre:amodes) `thenFlt` \ (new_cc:new_amodes, tops) ->
435 returnFlt (AbsCNop, tops `mkAbsCStmts`
436 CStaticClosure closure_lbl closure_info new_cc new_amodes)
438 flatAbsC (CRetVector tbl_label stuff deflt)
439 = do_deflt deflt `thenFlt` \ (deflt_amode, deflt_tops) ->
440 mapAndUnzipFlt (do_alt deflt_amode) stuff `thenFlt` \ (alt_amodes, alt_tops) ->
441 returnFlt (AbsCNop, mkAbstractCs [deflt_tops,
442 mkAbstractCs alt_tops,
443 CFlatRetVector tbl_label alt_amodes])
446 do_deflt deflt = case nonemptyAbsC deflt of
447 Nothing -> returnFlt (bogus_default_label, AbsCNop)
448 Just deflt' -> flatAmode (CCode deflt) -- Deals correctly with the
449 -- CJump (CLabelledCode ...) case
451 do_alt deflt_amode Nothing = returnFlt (deflt_amode, AbsCNop)
452 do_alt deflt_amode (Just alt) = flatAmode alt
454 bogus_default_label = panic "flatAbsC: CRetVector: default needed and not available"
457 flatAbsC (CRetUnVector label amode)
458 = flatAmode amode `thenFlt` \ (new_amode, tops) ->
459 returnFlt (AbsCNop, tops `mkAbsCStmts` CRetUnVector label new_amode)
461 flatAbsC (CFlatRetVector label amodes)
462 = flatAmodes amodes `thenFlt` \ (new_amodes, tops) ->
463 returnFlt (AbsCNop, tops `mkAbsCStmts` CFlatRetVector label new_amodes)
465 flatAbsC cc@(CCostCentreDecl _ _) -- at top, already flat
466 = returnFlt (AbsCNop, cc)
468 -- now the real stmts:
470 flatAbsC (CAssign dest source)
471 = flatAmode dest `thenFlt` \ (dest_amode, dest_tops) ->
472 flatAmode source `thenFlt` \ (src_amode, src_tops) ->
473 returnFlt ( CAssign dest_amode src_amode, mkAbsCStmts dest_tops src_tops )
475 -- special case: jump to some anonymous code
476 flatAbsC (CJump (CCode abs_C)) = flatAbsC abs_C
478 flatAbsC (CJump target)
479 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
480 returnFlt ( CJump targ_amode, targ_tops )
482 flatAbsC (CFallThrough target)
483 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
484 returnFlt ( CFallThrough targ_amode, targ_tops )
486 flatAbsC (CReturn target return_info)
487 = flatAmode target `thenFlt` \ (targ_amode, targ_tops) ->
488 returnFlt ( CReturn targ_amode return_info, targ_tops )
490 flatAbsC (CSwitch discrim alts deflt)
491 = flatAmode discrim `thenFlt` \ (discrim_amode, discrim_tops) ->
492 mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
493 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
495 CSwitch discrim_amode flat_alts flat_def_alt,
496 mkAbstractCs (discrim_tops : def_tops : flat_alts_tops)
500 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
501 returnFlt ( (tag, alt_heres), alt_tops )
503 flatAbsC stmt@(CInitHdr a b cc u)
504 = flatAmode cc `thenFlt` \ (new_cc, tops) ->
505 returnFlt (CInitHdr a b new_cc u, tops)
507 flatAbsC stmt@(COpStmt results op args liveness_mask vol_regs)
508 = flatAmodes results `thenFlt` \ (results_here, tops1) ->
509 flatAmodes args `thenFlt` \ (args_here, tops2) ->
510 returnFlt (COpStmt results_here op args_here liveness_mask vol_regs,
511 mkAbsCStmts tops1 tops2)
513 flatAbsC stmt@(CSimultaneous abs_c)
514 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
515 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
516 returnFlt (new_stmts_here, tops)
518 flatAbsC stmt@(CMacroStmt macro amodes)
519 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
520 returnFlt (CMacroStmt macro amodes_here, tops)
522 flatAbsC stmt@(CCallProfCtrMacro str amodes)
523 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
524 returnFlt (CCallProfCtrMacro str amodes_here, tops)
526 flatAbsC stmt@(CCallProfCCMacro str amodes)
527 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
528 returnFlt (CCallProfCCMacro str amodes_here, tops)
530 --UNUSED:flatAbsC comment_stmt@(CComment comment) = returnFlt (AbsCNop, AbsCNop)
532 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
535 -- Hack since 0.16 because Direct entry code blocks can be nested
536 -- within other Direct entry blocks...
537 flatAbsC (CNativeInfoTableAndCode cinfo descr
538 (CCodeBlock slow_label
539 (AbsCStmts slow_abs_c
540 (CCodeBlock fast_label fast_abs_c))))
541 | isSlowFastLabelPair slow_label fast_label
542 = flatAbsC slow_abs_c `thenFlt` \ (slow_here, slow_top) ->
543 flatAbsC fast_abs_c `thenFlt` \ (fast_here, fast_top) ->
544 returnFlt (CNativeInfoTableAndCode cinfo descr
545 (CCodeBlock slow_label
547 (CCodeBlock fast_label fast_here))),
548 mkAbsCStmts slow_top fast_top)
550 flatAbsC (CNativeInfoTableAndCode cinfo descr abs_C)
551 = flatAbsC abs_C `thenFlt` \ (heres, tops) ->
552 returnFlt (CNativeInfoTableAndCode cinfo descr heres, tops)
553 #endif {- Data Parallel Haskell -}
555 --flatAbsC stmt = panic ("flatAbsC: funny statement " ++ printRealC (\x->False) stmt)
558 %************************************************************************
560 \subsection[flat-amodes]{Flattening addressing modes}
562 %************************************************************************
565 flatAmode :: CAddrMode -> FlatM (CAddrMode, AbstractC)
568 flatAmode amode@(CVal _ _) = returnFlt (amode, AbsCNop)
570 flatAmode amode@(CAddr _) = returnFlt (amode, AbsCNop)
571 flatAmode amode@(CReg _) = returnFlt (amode, AbsCNop)
572 flatAmode amode@(CTemp _ _) = returnFlt (amode, AbsCNop)
573 flatAmode amode@(CLbl _ _) = returnFlt (amode, AbsCNop)
574 flatAmode amode@(CUnVecLbl _ _) = returnFlt (amode, AbsCNop)
575 flatAmode amode@(CString _) = returnFlt (amode, AbsCNop)
576 flatAmode amode@(CLit _) = returnFlt (amode, AbsCNop)
577 flatAmode amode@(CLitLit _ _) = returnFlt (amode, AbsCNop)
578 flatAmode amode@(COffset _) = returnFlt (amode, AbsCNop)
580 -- CIntLike must be a literal -- no flattening
581 flatAmode amode@(CIntLike int) = returnFlt(amode, AbsCNop)
583 -- CCharLike may be arbitrary value -- have to flatten
584 flatAmode amode@(CCharLike char)
585 = flatAmode char `thenFlt` \ (flat_char, tops) ->
586 returnFlt(CCharLike flat_char, tops)
588 flatAmode (CJoinPoint _ _) = panic "flatAmode:CJoinPoint"
590 flatAmode (CLabelledCode label abs_C)
591 -- Push the code (with this label) to the top level
592 = flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
593 returnFlt (CLbl label CodePtrKind,
594 tops `mkAbsCStmts` CCodeBlock label body_code)
596 flatAmode (CCode abs_C)
597 = case mkAbsCStmtList abs_C of
598 [CJump amode] -> flatAmode amode -- Elide redundant labels
600 -- de-anonymous-ise the code and push it (labelled) to the top level
601 getUniqFlt `thenFlt` \ new_uniq ->
602 BIND (mkReturnPtLabel new_uniq) _TO_ return_pt_label ->
603 flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
605 CLbl return_pt_label CodePtrKind,
606 tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
607 -- DO NOT TOUCH the stuff sent to the top...
611 flatAmode (CTableEntry base index kind)
612 = flatAmode base `thenFlt` \ (base_amode, base_tops) ->
613 flatAmode index `thenFlt` \ (ix_amode, ix_tops) ->
614 returnFlt ( CTableEntry base_amode ix_amode kind, mkAbsCStmts base_tops ix_tops )
616 flatAmode (CMacroExpr pk macro amodes)
617 = flatAmodes amodes `thenFlt` \ (amodes_here, tops) ->
618 returnFlt ( CMacroExpr pk macro amodes_here, tops )
620 flatAmode amode@(CCostCentre _ _) = returnFlt (amode, AbsCNop)
623 And a convenient way to do a whole bunch of 'em.
625 flatAmodes :: [CAddrMode] -> FlatM ([CAddrMode], AbstractC)
627 flatAmodes [] = returnFlt ([], AbsCNop)
630 = mapAndUnzipFlt flatAmode amodes `thenFlt` \ (amodes_here, tops) ->
631 returnFlt (amodes_here, mkAbstractCs tops)
634 %************************************************************************
636 \subsection[flat-simultaneous]{Doing things simultaneously}
638 %************************************************************************
641 doSimultaneously :: AbstractC -> FlatM AbstractC
644 Generate code to perform the @CAssign@s and @COpStmt@s in the
645 input simultaneously, using temporary variables when necessary.
647 We use the strongly-connected component algorithm, in which
648 * the vertices are the statements
649 * an edge goes from s1 to s2 iff
650 s1 assigns to something s2 uses
651 that is, if s1 should *follow* s2 in the final order
655 Wow - fancy stuff. But are we ever going to do anything other than
656 assignments in parallel? If not, wouldn't it be simpler to generate
659 x1, x2, x3 = e1, e2, e3
672 and leave it to the C compiler to figure out whether it needs al
675 (Likewise, why not let the C compiler delete silly code like
684 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
685 -- for fast comparison
687 type CEdge = (CVertex, CVertex)
689 doSimultaneously abs_c
691 enlisted = en_list abs_c
693 case enlisted of -- it's often just one stmt
694 [] -> returnFlt AbsCNop
696 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
698 -- en_list puts all the assignments in a list, filtering out Nops and
699 -- assignments which do nothing
701 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
702 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
703 en_list other = [other]
705 sameAmode :: CAddrMode -> CAddrMode -> Bool
706 -- ToDo: Move this function, or make CAddrMode an instance of Eq
707 -- At the moment we put in just enough to catch the cases we want:
708 -- the second (destination) argument is always a CVal.
709 sameAmode (CReg r1) (CReg r2) = r1 == r2
710 sameAmode (CVal (SpARel r1 v1) _) (CVal (SpARel r2 v2) _) = r1 == r2 && v1 == v2
711 sameAmode (CVal (SpBRel r1 v1) _) (CVal (SpBRel r2 v2) _) = r1 == r2 && v1 == v2
712 sameAmode other1 other2 = False
714 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
715 doSimultaneously1 vertices
718 edges = concat (map edges_from vertices)
720 edges_from :: CVertex -> [CEdge]
721 edges_from v1 = [(v1,v2) | v2 <- vertices, v1 `should_follow` v2]
723 should_follow :: CVertex -> CVertex -> Bool
724 (n1, CAssign dest1 _) `should_follow` (n2, CAssign _ src2)
725 = dest1 `conflictsWith` src2
726 (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, CAssign _ src2)
727 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
728 (n1, CAssign dest1 _)`should_follow` (n2, COpStmt _ _ srcs2 _ _)
729 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
730 (n1, COpStmt dests1 _ _ _ _) `should_follow` (n2, COpStmt _ _ srcs2 _ _)
731 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
733 -- (_, COpStmt _ _ _ _ _) `should_follow` (_, CCallProfCtrMacro _ _) = False
734 -- (_, CCallProfCtrMacro _ _) `should_follow` (_, COpStmt _ _ _ _ _) = False
736 eq_vertex :: CVertex -> CVertex -> Bool
737 (n1, _) `eq_vertex` (n2, _) = n1 == n2
739 components = stronglyConnComp eq_vertex edges vertices
741 -- do_components deal with one strongly-connected component
742 do_component :: [CVertex] -> FlatM AbstractC
744 -- A singleton? Then just do it.
745 do_component [(n,abs_c)] = returnFlt abs_c
747 -- Two or more? Then go via temporaries.
748 do_component ((n,first_stmt):rest)
749 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
750 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
751 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
753 go_via_temps (CAssign dest src)
754 = getUniqFlt `thenFlt` \ uniq ->
755 let the_temp = CTemp uniq (getAmodeKind dest) in
756 returnFlt (CAssign the_temp src, CAssign dest the_temp)
758 go_via_temps (COpStmt dests op srcs liveness_mask vol_regs)
759 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
760 let the_temps = zipWith (\ u d -> CTemp u (getAmodeKind d)) uniqs dests
762 returnFlt (COpStmt the_temps op srcs liveness_mask vol_regs,
763 mkAbstractCs (zipWith CAssign dests the_temps))
765 mapFlt do_component components `thenFlt` \ abs_cs ->
766 returnFlt (mkAbstractCs abs_cs)
770 @conflictsWith@ tells whether an assignment to its first argument will
771 screw up an access to its second.
774 conflictsWith :: CAddrMode -> CAddrMode -> Bool
775 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
776 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
777 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
778 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
779 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
780 = rrConflictsWithRR (getKindSize k1) (getKindSize k2) reg_rel1 reg_rel2
782 other1 `conflictsWith` other2 = False
783 -- CAddr and literals are impossible on the LHS of an assignment
785 regConflictsWithRR :: MagicId -> RegRelative -> Bool
787 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
789 regConflictsWithRR SpA (SpARel _ _) = True
790 regConflictsWithRR SpB (SpBRel _ _) = True
791 regConflictsWithRR Hp (HpRel _ _) = True
792 regConflictsWithRR _ _ = False
794 rrConflictsWithRR :: Int -> Int -- Sizes of two things
795 -> RegRelative -> RegRelative -- The two amodes
798 rrConflictsWithRR s1 s2 rr1 rr2 = rr rr1 rr2
800 rr (SpARel p1 o1) (SpARel p2 o2)
801 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
802 | s1 == 1 && s2 == 1 = b1 == b2
803 | otherwise = (b1+s1) >= b2 &&
809 rr (SpBRel p1 o1) (SpBRel p2 o2)
810 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
811 | s1 == 1 && s2 == 1 = b1 == b2
812 | otherwise = (b1+s1) >= b2 &&
818 rr (NodeRel o1) (NodeRel o2)
819 | s1 == 0 || s2 == 0 = False -- No conflict if either is size zero
820 | s1 == 1 && s2 == 1 = o1 `possiblyEqualHeapOffset` o2
821 | otherwise = True -- Give up
823 rr (HpRel _ _) (HpRel _ _) = True -- Give up
825 rr other1 other2 = False
828 %************************************************************************
830 \subsection[gaze-into-simultaneous]{Registers live in a @CSimultaneous@?}
832 %************************************************************************
834 Hidden in a blob of ``simultaneous assignments'' is the info of how
835 many pointer (``followable'') registers are live (i.e., assigned
836 into). What we do here is merely fish out the destination registers.
840 getDestinationRegs :: AbstractC -> [MagicId]
842 getDestinationRegs abs_c
843 = foldr gather [{-acc-}] (en_list abs_c)
845 gather :: AbstractC -> [MagicId] -> [MagicId]
847 -- only CAssigns and COpStmts now possible...
849 gather (CAssign (CReg magic_id) _) acc | magic_id `not_elem` acc
852 not_elem = isn'tIn "getDestinationRegs"
854 gather (COpStmt dests _ _ _ _) acc
855 = foldr gather2 acc dests
857 gather2 (CReg magic_id) acc | magic_id `not_elem` acc = magic_id : acc
860 not_elem = isn'tIn "getDestinationRegs2"