2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[AbsCUtils]{Help functions for Abstract~C datatype}
9 mkAbstractCs, mkAbsCStmts,
13 mixedTypeLocn, mixedPtrLocn,
17 -- printing/forcing stuff comes from PprAbsC
20 #include "HsVersions.h"
23 import Digraph ( stronglyConnComp, SCC(..) )
24 import DataCon ( fIRST_TAG, ConTag )
25 import Const ( literalPrimRep, mkMachWord )
26 import PrimRep ( getPrimRepSize, PrimRep(..) )
27 import Unique ( Unique{-instance Eq-} )
28 import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
30 import CmdLineOpts ( opt_ProduceC, opt_EmitCExternDecls )
31 import Maybes ( maybeToBool )
32 import PrimOp ( PrimOp(..) )
33 import Panic ( panic )
38 Check if there is any real code in some Abstract~C. If so, return it
39 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
41 It returns the "reduced" code in the Just part so that the work of
42 discarding AbsCNops isn't lost, and so that if the caller uses
43 the reduced version there's less danger of a big tree of AbsCNops getting
44 materialised and causing a space leak.
47 nonemptyAbsC :: AbstractC -> Maybe AbstractC
48 nonemptyAbsC AbsCNop = Nothing
49 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
50 Nothing -> nonemptyAbsC s2
51 Just x -> Just (AbsCStmts x s2)
52 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
55 nonemptyAbsC other = Just other
59 mkAbstractCs :: [AbstractC] -> AbstractC
60 mkAbstractCs [] = AbsCNop
61 mkAbstractCs cs = foldr1 mkAbsCStmts cs
63 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
64 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
65 mkAbsCStmts AbsCNop c = c
66 mkAbsCStmts c AbsCNop = c
67 mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2
69 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
70 = case (case (nonemptyAbsC abc2) of
72 Just d2 -> d2) of { abc2b ->
74 case (nonemptyAbsC abc1) of {
76 Just d1 -> AbsCStmts d1 abc2b
81 Get the sho' 'nuff statements out of an @AbstractC@.
83 mkAbsCStmtList :: AbstractC -> [AbstractC]
85 mkAbsCStmtList absC = mkAbsCStmtList' absC []
87 -- Optimised a la foldr/build!
89 mkAbsCStmtList' AbsCNop r = r
91 mkAbsCStmtList' (AbsCStmts s1 s2) r
92 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
94 mkAbsCStmtList' s@(CSimultaneous c) r
95 = if null (mkAbsCStmtList c) then r else s : r
97 mkAbsCStmtList' other r = other : r
101 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
103 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
104 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
106 -- Adjust the tags in the switch to start at zero.
107 -- This is the convention used by primitive ops which return algebraic
108 -- data types. Why? Because for two-constructor types, zero is faster
109 -- to create and distinguish from 1 than are 1 and 2.
111 -- We also need to convert to Literals to keep the CSwitch happy
113 = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
114 | (tag, abs_c) <- tagged_alts ]
117 %************************************************************************
119 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
121 %************************************************************************
124 magicIdPrimRep BaseReg = PtrRep
125 magicIdPrimRep (VanillaReg kind _) = kind
126 magicIdPrimRep (FloatReg _) = FloatRep
127 magicIdPrimRep (DoubleReg _) = DoubleRep
128 magicIdPrimRep (LongReg kind _) = kind
129 magicIdPrimRep Sp = PtrRep
130 magicIdPrimRep Su = PtrRep
131 magicIdPrimRep SpLim = PtrRep
132 magicIdPrimRep Hp = PtrRep
133 magicIdPrimRep HpLim = PtrRep
134 magicIdPrimRep CurCostCentre = CostCentreRep
135 magicIdPrimRep VoidReg = VoidRep
138 %************************************************************************
140 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
142 %************************************************************************
144 See also the return conventions for unboxed things; currently living
145 in @CgCon@ (next to the constructor return conventions).
147 ToDo: tiny tweaking may be in order
149 getAmodeRep :: CAddrMode -> PrimRep
151 getAmodeRep (CVal _ kind) = kind
152 getAmodeRep (CAddr _) = PtrRep
153 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
154 getAmodeRep (CTemp uniq kind) = kind
155 getAmodeRep (CLbl _ kind) = kind
156 getAmodeRep (CCharLike _) = PtrRep
157 getAmodeRep (CIntLike _) = PtrRep
158 getAmodeRep (CLit lit) = literalPrimRep lit
159 getAmodeRep (CLitLit _ kind) = kind
160 getAmodeRep (CMacroExpr kind _ _) = kind
161 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
164 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
165 location; that is, one which can contain values of various types.
168 mixedTypeLocn :: CAddrMode -> Bool
170 mixedTypeLocn (CVal (NodeRel _) _) = True
171 mixedTypeLocn (CVal (SpRel _) _) = True
172 mixedTypeLocn (CVal (HpRel _) _) = True
173 mixedTypeLocn other = False -- All the rest
176 @mixedPtrLocn@ tells whether an amode identifies a
177 location which can contain values of various pointer types.
180 mixedPtrLocn :: CAddrMode -> Bool
182 mixedPtrLocn (CVal (SpRel _) _) = True
183 mixedPtrLocn other = False -- All the rest
186 %************************************************************************
188 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
190 %************************************************************************
192 The following bits take ``raw'' Abstract~C, which may have all sorts of
193 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
194 @CClosureInfos@ and code for switches are pulled out to the top level.
196 The various functions herein tend to produce
199 A {\em flattened} \tr{<something>} of interest for ``here'', and
201 Some {\em unflattened} Abstract~C statements to be carried up to the
202 top-level. The only real reason (now) that it is unflattened is
203 because it means the recursive flattening can be done in just one
204 place rather than having to remember lots of places.
207 Care is taken to reduce the occurrence of forward references, while still
208 keeping laziness a much as possible. Essentially, this means that:
211 {\em All} the top-level C statements resulting from flattening a
212 particular AbsC statement (whether the latter is nested or not) appear
213 before {\em any} of the code for a subsequent AbsC statement;
215 but stuff nested within any AbsC statement comes
216 out before the code for the statement itself.
219 The ``stuff to be carried up'' always includes a label: a
220 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
221 @CCodeBlock@. The latter turns into a C function, and is never
222 actually produced by the code generator. Rather it always starts life
223 as a @CCodeBlock@ addressing mode; when such an addr mode is
224 flattened, the ``tops'' stuff is a @CCodeBlock@.
227 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
230 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
231 here `mkAbsCStmts` tops }
234 %************************************************************************
236 \subsubsection{Flattening monadery}
238 %************************************************************************
240 The flattener is monadised. It's just a @UniqueSupply@.
243 type FlatM result = UniqSupply -> result
245 initFlt :: UniqSupply -> FlatM a -> a
247 initFlt init_us m = m init_us
249 {-# INLINE thenFlt #-}
250 {-# INLINE returnFlt #-}
252 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
255 = case (splitUniqSupply us) of { (s1, s2) ->
256 case (expr s1) of { result ->
259 returnFlt :: a -> FlatM a
260 returnFlt result us = result
262 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
264 mapFlt f [] = returnFlt []
266 = f x `thenFlt` \ r ->
267 mapFlt f xs `thenFlt` \ rs ->
270 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
272 mapAndUnzipFlt f [] = returnFlt ([],[])
273 mapAndUnzipFlt f (x:xs)
274 = f x `thenFlt` \ (r1, r2) ->
275 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
276 returnFlt (r1:rs1, r2:rs2)
278 getUniqFlt :: FlatM Unique
279 getUniqFlt us = uniqFromSupply us
281 getUniqsFlt :: Int -> FlatM [Unique]
282 getUniqsFlt i us = uniqsFromSupply i us
285 %************************************************************************
287 \subsubsection{Flattening the top level}
289 %************************************************************************
292 flatAbsC :: AbstractC
293 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
294 AbstractC) -- Stuff to put at top level flattened]
296 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
298 flatAbsC (AbsCStmts s1 s2)
299 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
300 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
301 returnFlt (mkAbsCStmts inline_s1 inline_s2,
302 mkAbsCStmts top_s1 top_s2)
304 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
305 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
306 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
307 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
308 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
311 flatAbsC (CCodeBlock lbl abs_C)
312 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
313 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
315 flatAbsC (CRetDirect uniq slow_code srt liveness)
316 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
318 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
320 flatAbsC (CSwitch discrim alts deflt)
321 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
322 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
324 CSwitch discrim flat_alts flat_def_alt,
325 mkAbstractCs (def_tops : flat_alts_tops)
329 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
330 returnFlt ( (tag, alt_heres), alt_tops )
332 flatAbsC stmt@(COpStmt results td@(CCallOp _ _ _ _) args vol_regs)
333 | isCandidate && maybeToBool opt_ProduceC
334 = returnFlt (stmt, tdef)
336 (isCandidate, isDyn) =
338 CCallOp (Right _) _ _ _ -> (True, True)
339 CCallOp (Left _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False)
342 tdef = CCallTypedef isDyn td results args
344 flatAbsC stmt@(CSimultaneous abs_c)
345 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
346 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
347 returnFlt (new_stmts_here, tops)
349 flatAbsC stmt@(CCheck macro amodes code)
350 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
351 returnFlt (CCheck macro amodes code_here, code_tops)
353 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
355 flatAbsC stmt@(CCallProfCtrMacro str amodes)
356 | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
357 | otherwise = returnFlt (stmt, AbsCNop)
359 -- Some statements need no flattening at all:
360 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
361 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
362 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
363 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
364 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
365 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
366 flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
367 flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
369 -- Some statements only make sense at the top level, so we always float
370 -- them. This probably isn't necessary.
371 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
372 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
373 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
374 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
375 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
376 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
377 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
378 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
379 flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
383 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
384 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
385 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
386 returnFlt (Just heres, tops)
389 %************************************************************************
391 \subsection[flat-simultaneous]{Doing things simultaneously}
393 %************************************************************************
396 doSimultaneously :: AbstractC -> FlatM AbstractC
399 Generate code to perform the @CAssign@s and @COpStmt@s in the
400 input simultaneously, using temporary variables when necessary.
402 We use the strongly-connected component algorithm, in which
403 * the vertices are the statements
404 * an edge goes from s1 to s2 iff
405 s1 assigns to something s2 uses
406 that is, if s1 should *follow* s2 in the final order
409 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
410 -- for fast comparison
412 type CEdge = (CVertex, CVertex)
414 doSimultaneously abs_c
416 enlisted = en_list abs_c
418 case enlisted of -- it's often just one stmt
419 [] -> returnFlt AbsCNop
421 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
423 -- en_list puts all the assignments in a list, filtering out Nops and
424 -- assignments which do nothing
426 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
427 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
428 en_list other = [other]
430 sameAmode :: CAddrMode -> CAddrMode -> Bool
431 -- ToDo: Move this function, or make CAddrMode an instance of Eq
432 -- At the moment we put in just enough to catch the cases we want:
433 -- the second (destination) argument is always a CVal.
434 sameAmode (CReg r1) (CReg r2) = r1 == r2
435 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 _EQ_ r2
436 sameAmode other1 other2 = False
438 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
439 doSimultaneously1 vertices
441 edges = [ (vertex, key1, edges_from stmt1)
442 | vertex@(key1, stmt1) <- vertices
444 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
445 stmt1 `should_follow` stmt2
447 components = stronglyConnComp edges
449 -- do_components deal with one strongly-connected component
450 -- Not cyclic, or singleton? Just do it
451 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
452 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
454 -- Cyclic? Then go via temporaries. Pick one to
455 -- break the loop and try again with the rest.
456 do_component (CyclicSCC ((n,first_stmt) : rest))
457 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
458 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
459 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
461 go_via_temps (CAssign dest src)
462 = getUniqFlt `thenFlt` \ uniq ->
464 the_temp = CTemp uniq (getAmodeRep dest)
466 returnFlt (CAssign the_temp src, CAssign dest the_temp)
468 go_via_temps (COpStmt dests op srcs vol_regs)
469 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
471 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
473 returnFlt (COpStmt the_temps op srcs vol_regs,
474 mkAbstractCs (zipWith CAssign dests the_temps))
476 mapFlt do_component components `thenFlt` \ abs_cs ->
477 returnFlt (mkAbstractCs abs_cs)
480 should_follow :: AbstractC -> AbstractC -> Bool
481 (CAssign dest1 _) `should_follow` (CAssign _ src2)
482 = dest1 `conflictsWith` src2
483 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
484 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
485 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
486 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
487 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
488 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
490 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
491 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
497 @conflictsWith@ tells whether an assignment to its first argument will
498 screw up an access to its second.
501 conflictsWith :: CAddrMode -> CAddrMode -> Bool
502 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
503 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
504 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
505 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
506 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
507 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
509 other1 `conflictsWith` other2 = False
510 -- CAddr and literals are impossible on the LHS of an assignment
512 regConflictsWithRR :: MagicId -> RegRelative -> Bool
514 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
516 regConflictsWithRR Sp (SpRel _) = True
517 regConflictsWithRR Hp (HpRel _) = True
518 regConflictsWithRR _ _ = False
520 rrConflictsWithRR :: Int -> Int -- Sizes of two things
521 -> RegRelative -> RegRelative -- The two amodes
524 rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2
526 rr (SpRel o1) (SpRel o2)
527 | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
528 | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
529 | otherwise = (o1 _ADD_ s1) _GE_ o2 &&
530 (o2 _ADD_ s2) _GE_ o1
532 rr (NodeRel o1) (NodeRel o2)
533 | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
534 | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
535 | otherwise = True -- Give up
537 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
539 rr other1 other2 = False