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 Literal ( 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(..), CCall(..), CCallTarget(..) )
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 (CCallOp ccall) args vol_regs)
333 | isCandidate && maybeToBool opt_ProduceC
334 = returnFlt (stmt, tdef)
336 (isCandidate, isDyn) =
338 CCall (DynamicTarget _) _ _ _ -> (True, True)
339 CCall (StaticTarget _) is_asm _ _ -> (opt_EmitCExternDecls && not is_asm, False)
341 tdef = CCallTypedef isDyn ccall results args
343 flatAbsC stmt@(CSimultaneous abs_c)
344 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
345 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
346 returnFlt (new_stmts_here, tops)
348 flatAbsC stmt@(CCheck macro amodes code)
349 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
350 returnFlt (CCheck macro amodes code_here, code_tops)
352 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
354 flatAbsC stmt@(CCallProfCtrMacro str amodes)
355 | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
356 | otherwise = returnFlt (stmt, AbsCNop)
358 -- Some statements need no flattening at all:
359 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
360 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
361 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
362 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
363 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
364 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
365 flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
366 flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
368 -- Some statements only make sense at the top level, so we always float
369 -- them. This probably isn't necessary.
370 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
371 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
372 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
373 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
374 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
375 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
376 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
377 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
378 flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
382 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
383 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
384 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
385 returnFlt (Just heres, tops)
388 %************************************************************************
390 \subsection[flat-simultaneous]{Doing things simultaneously}
392 %************************************************************************
395 doSimultaneously :: AbstractC -> FlatM AbstractC
398 Generate code to perform the @CAssign@s and @COpStmt@s in the
399 input simultaneously, using temporary variables when necessary.
401 We use the strongly-connected component algorithm, in which
402 * the vertices are the statements
403 * an edge goes from s1 to s2 iff
404 s1 assigns to something s2 uses
405 that is, if s1 should *follow* s2 in the final order
408 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
409 -- for fast comparison
411 type CEdge = (CVertex, CVertex)
413 doSimultaneously abs_c
415 enlisted = en_list abs_c
417 case enlisted of -- it's often just one stmt
418 [] -> returnFlt AbsCNop
420 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
422 -- en_list puts all the assignments in a list, filtering out Nops and
423 -- assignments which do nothing
425 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
426 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
427 en_list other = [other]
429 sameAmode :: CAddrMode -> CAddrMode -> Bool
430 -- ToDo: Move this function, or make CAddrMode an instance of Eq
431 -- At the moment we put in just enough to catch the cases we want:
432 -- the second (destination) argument is always a CVal.
433 sameAmode (CReg r1) (CReg r2) = r1 == r2
434 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 _EQ_ r2
435 sameAmode other1 other2 = False
437 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
438 doSimultaneously1 vertices
440 edges = [ (vertex, key1, edges_from stmt1)
441 | vertex@(key1, stmt1) <- vertices
443 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
444 stmt1 `should_follow` stmt2
446 components = stronglyConnComp edges
448 -- do_components deal with one strongly-connected component
449 -- Not cyclic, or singleton? Just do it
450 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
451 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
453 -- Cyclic? Then go via temporaries. Pick one to
454 -- break the loop and try again with the rest.
455 do_component (CyclicSCC ((n,first_stmt) : rest))
456 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
457 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
458 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
460 go_via_temps (CAssign dest src)
461 = getUniqFlt `thenFlt` \ uniq ->
463 the_temp = CTemp uniq (getAmodeRep dest)
465 returnFlt (CAssign the_temp src, CAssign dest the_temp)
467 go_via_temps (COpStmt dests op srcs vol_regs)
468 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
470 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
472 returnFlt (COpStmt the_temps op srcs vol_regs,
473 mkAbstractCs (zipWith CAssign dests the_temps))
475 mapFlt do_component components `thenFlt` \ abs_cs ->
476 returnFlt (mkAbstractCs abs_cs)
479 should_follow :: AbstractC -> AbstractC -> Bool
480 (CAssign dest1 _) `should_follow` (CAssign _ src2)
481 = dest1 `conflictsWith` src2
482 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
483 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
484 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
485 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
486 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
487 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
489 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
490 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
496 @conflictsWith@ tells whether an assignment to its first argument will
497 screw up an access to its second.
500 conflictsWith :: CAddrMode -> CAddrMode -> Bool
501 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
502 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
503 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
504 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
505 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
506 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
508 other1 `conflictsWith` other2 = False
509 -- CAddr and literals are impossible on the LHS of an assignment
511 regConflictsWithRR :: MagicId -> RegRelative -> Bool
513 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
515 regConflictsWithRR Sp (SpRel _) = True
516 regConflictsWithRR Hp (HpRel _) = True
517 regConflictsWithRR _ _ = False
519 rrConflictsWithRR :: Int -> Int -- Sizes of two things
520 -> RegRelative -> RegRelative -- The two amodes
523 rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2
525 rr (SpRel o1) (SpRel o2)
526 | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
527 | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
528 | otherwise = (o1 _ADD_ s1) _GE_ o2 &&
529 (o2 _ADD_ s2) _GE_ o1
531 rr (NodeRel o1) (NodeRel o2)
532 | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
533 | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
534 | otherwise = True -- Give up
536 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
538 rr other1 other2 = False