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_EmitCExternDecls )
31 import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
32 import Panic ( panic )
35 import Maybe ( isJust )
40 Check if there is any real code in some Abstract~C. If so, return it
41 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
43 It returns the "reduced" code in the Just part so that the work of
44 discarding AbsCNops isn't lost, and so that if the caller uses
45 the reduced version there's less danger of a big tree of AbsCNops getting
46 materialised and causing a space leak.
49 nonemptyAbsC :: AbstractC -> Maybe AbstractC
50 nonemptyAbsC AbsCNop = Nothing
51 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
52 Nothing -> nonemptyAbsC s2
53 Just x -> Just (AbsCStmts x s2)
54 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
57 nonemptyAbsC other = Just other
61 mkAbstractCs :: [AbstractC] -> AbstractC
62 mkAbstractCs [] = AbsCNop
63 mkAbstractCs cs = foldr1 mkAbsCStmts cs
65 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
66 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
67 mkAbsCStmts AbsCNop c = c
68 mkAbsCStmts c AbsCNop = c
69 mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2
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 | isJust (nonemptyAbsC deflt_absc)
107 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
109 = CSwitch scrutinee (adjust rest) first_alt
111 -- it's ok to convert one of the alts into a default if we don't already have
112 -- one, because this is an algebraic case and we're guaranteed that the tag
113 -- will match one of the branches.
114 ((_,first_alt):rest) = tagged_alts
116 -- Adjust the tags in the switch to start at zero.
117 -- This is the convention used by primitive ops which return algebraic
118 -- data types. Why? Because for two-constructor types, zero is faster
119 -- to create and distinguish from 1 than are 1 and 2.
121 -- We also need to convert to Literals to keep the CSwitch happy
123 = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
124 | (tag, abs_c) <- tagged_alts ]
127 %************************************************************************
129 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
131 %************************************************************************
134 magicIdPrimRep BaseReg = PtrRep
135 magicIdPrimRep (VanillaReg kind _) = kind
136 magicIdPrimRep (FloatReg _) = FloatRep
137 magicIdPrimRep (DoubleReg _) = DoubleRep
138 magicIdPrimRep (LongReg kind _) = kind
139 magicIdPrimRep Sp = PtrRep
140 magicIdPrimRep Su = PtrRep
141 magicIdPrimRep SpLim = PtrRep
142 magicIdPrimRep Hp = PtrRep
143 magicIdPrimRep HpLim = PtrRep
144 magicIdPrimRep CurCostCentre = CostCentreRep
145 magicIdPrimRep VoidReg = VoidRep
146 magicIdPrimRep CurrentTSO = ThreadIdRep
147 magicIdPrimRep CurrentNursery = PtrRep
150 %************************************************************************
152 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
154 %************************************************************************
156 See also the return conventions for unboxed things; currently living
157 in @CgCon@ (next to the constructor return conventions).
159 ToDo: tiny tweaking may be in order
161 getAmodeRep :: CAddrMode -> PrimRep
163 getAmodeRep (CVal _ kind) = kind
164 getAmodeRep (CAddr _) = PtrRep
165 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
166 getAmodeRep (CTemp uniq kind) = kind
167 getAmodeRep (CLbl _ kind) = kind
168 getAmodeRep (CCharLike _) = PtrRep
169 getAmodeRep (CIntLike _) = PtrRep
170 getAmodeRep (CLit lit) = literalPrimRep lit
171 getAmodeRep (CMacroExpr kind _ _) = kind
172 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
175 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
176 location; that is, one which can contain values of various types.
179 mixedTypeLocn :: CAddrMode -> Bool
181 mixedTypeLocn (CVal (NodeRel _) _) = True
182 mixedTypeLocn (CVal (SpRel _) _) = True
183 mixedTypeLocn (CVal (HpRel _) _) = True
184 mixedTypeLocn other = False -- All the rest
187 @mixedPtrLocn@ tells whether an amode identifies a
188 location which can contain values of various pointer types.
191 mixedPtrLocn :: CAddrMode -> Bool
193 mixedPtrLocn (CVal (SpRel _) _) = True
194 mixedPtrLocn other = False -- All the rest
197 %************************************************************************
199 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
201 %************************************************************************
203 The following bits take ``raw'' Abstract~C, which may have all sorts of
204 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
205 @CClosureInfos@ and code for switches are pulled out to the top level.
207 The various functions herein tend to produce
210 A {\em flattened} \tr{<something>} of interest for ``here'', and
212 Some {\em unflattened} Abstract~C statements to be carried up to the
213 top-level. The only real reason (now) that it is unflattened is
214 because it means the recursive flattening can be done in just one
215 place rather than having to remember lots of places.
218 Care is taken to reduce the occurrence of forward references, while still
219 keeping laziness a much as possible. Essentially, this means that:
222 {\em All} the top-level C statements resulting from flattening a
223 particular AbsC statement (whether the latter is nested or not) appear
224 before {\em any} of the code for a subsequent AbsC statement;
226 but stuff nested within any AbsC statement comes
227 out before the code for the statement itself.
230 The ``stuff to be carried up'' always includes a label: a
231 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
232 @CCodeBlock@. The latter turns into a C function, and is never
233 actually produced by the code generator. Rather it always starts life
234 as a @CCodeBlock@ addressing mode; when such an addr mode is
235 flattened, the ``tops'' stuff is a @CCodeBlock@.
238 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
241 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
242 here `mkAbsCStmts` tops }
245 %************************************************************************
247 \subsubsection{Flattening monadery}
249 %************************************************************************
251 The flattener is monadised. It's just a @UniqueSupply@.
254 type FlatM result = UniqSupply -> result
256 initFlt :: UniqSupply -> FlatM a -> a
258 initFlt init_us m = m init_us
260 {-# INLINE thenFlt #-}
261 {-# INLINE returnFlt #-}
263 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
266 = case (splitUniqSupply us) of { (s1, s2) ->
267 case (expr s1) of { result ->
270 returnFlt :: a -> FlatM a
271 returnFlt result us = result
273 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
275 mapFlt f [] = returnFlt []
277 = f x `thenFlt` \ r ->
278 mapFlt f xs `thenFlt` \ rs ->
281 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
283 mapAndUnzipFlt f [] = returnFlt ([],[])
284 mapAndUnzipFlt f (x:xs)
285 = f x `thenFlt` \ (r1, r2) ->
286 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
287 returnFlt (r1:rs1, r2:rs2)
289 getUniqFlt :: FlatM Unique
290 getUniqFlt us = uniqFromSupply us
292 getUniqsFlt :: Int -> FlatM [Unique]
293 getUniqsFlt i us = uniqsFromSupply i us
296 %************************************************************************
298 \subsubsection{Flattening the top level}
300 %************************************************************************
303 flatAbsC :: AbstractC
304 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
305 AbstractC) -- Stuff to put at top level flattened]
307 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
309 flatAbsC (AbsCStmts s1 s2)
310 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
311 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
312 returnFlt (mkAbsCStmts inline_s1 inline_s2,
313 mkAbsCStmts top_s1 top_s2)
315 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
316 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
317 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
318 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
319 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
322 flatAbsC (CCodeBlock lbl abs_C)
323 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
324 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
326 flatAbsC (CRetDirect uniq slow_code srt liveness)
327 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
329 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
331 flatAbsC (CSwitch discrim alts deflt)
332 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
333 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
335 CSwitch discrim flat_alts flat_def_alt,
336 mkAbstractCs (def_tops : flat_alts_tops)
340 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
341 returnFlt ( (tag, alt_heres), alt_tops )
343 flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
345 = returnFlt (stmt, tdef)
347 = returnFlt (stmt, AbsCNop)
349 isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
350 is_dynamic = isDynamicTarget target
352 tdef = CCallTypedef is_dynamic ccall results args
354 flatAbsC stmt@(CSimultaneous abs_c)
355 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
356 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
357 returnFlt (new_stmts_here, tops)
359 flatAbsC stmt@(CCheck macro amodes code)
360 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
361 returnFlt (CCheck macro amodes code_here, code_tops)
363 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
365 flatAbsC stmt@(CCallProfCtrMacro str amodes)
366 | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
367 | otherwise = returnFlt (stmt, AbsCNop)
369 -- Some statements need no flattening at all:
370 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
371 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
372 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
373 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
374 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
375 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
376 flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
377 flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
379 -- Some statements only make sense at the top level, so we always float
380 -- them. This probably isn't necessary.
381 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
382 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
383 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
384 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
385 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
386 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
387 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
388 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
389 flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
393 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
394 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
395 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
396 returnFlt (Just heres, tops)
399 %************************************************************************
401 \subsection[flat-simultaneous]{Doing things simultaneously}
403 %************************************************************************
406 doSimultaneously :: AbstractC -> FlatM AbstractC
409 Generate code to perform the @CAssign@s and @COpStmt@s in the
410 input simultaneously, using temporary variables when necessary.
412 We use the strongly-connected component algorithm, in which
413 * the vertices are the statements
414 * an edge goes from s1 to s2 iff
415 s1 assigns to something s2 uses
416 that is, if s1 should *follow* s2 in the final order
419 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
420 -- for fast comparison
422 doSimultaneously abs_c
424 enlisted = en_list abs_c
426 case enlisted of -- it's often just one stmt
427 [] -> returnFlt AbsCNop
429 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
431 -- en_list puts all the assignments in a list, filtering out Nops and
432 -- assignments which do nothing
434 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
435 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
436 en_list other = [other]
438 sameAmode :: CAddrMode -> CAddrMode -> Bool
439 -- ToDo: Move this function, or make CAddrMode an instance of Eq
440 -- At the moment we put in just enough to catch the cases we want:
441 -- the second (destination) argument is always a CVal.
442 sameAmode (CReg r1) (CReg r2) = r1 == r2
443 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
444 sameAmode other1 other2 = False
446 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
447 doSimultaneously1 vertices
449 edges = [ (vertex, key1, edges_from stmt1)
450 | vertex@(key1, stmt1) <- vertices
452 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
453 stmt1 `should_follow` stmt2
455 components = stronglyConnComp edges
457 -- do_components deal with one strongly-connected component
458 -- Not cyclic, or singleton? Just do it
459 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
460 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
462 -- Cyclic? Then go via temporaries. Pick one to
463 -- break the loop and try again with the rest.
464 do_component (CyclicSCC ((n,first_stmt) : rest))
465 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
466 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
467 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
469 go_via_temps (CAssign dest src)
470 = getUniqFlt `thenFlt` \ uniq ->
472 the_temp = CTemp uniq (getAmodeRep dest)
474 returnFlt (CAssign the_temp src, CAssign dest the_temp)
476 go_via_temps (COpStmt dests op srcs vol_regs)
477 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
479 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
481 returnFlt (COpStmt the_temps op srcs vol_regs,
482 mkAbstractCs (zipWith CAssign dests the_temps))
484 mapFlt do_component components `thenFlt` \ abs_cs ->
485 returnFlt (mkAbstractCs abs_cs)
488 should_follow :: AbstractC -> AbstractC -> Bool
489 (CAssign dest1 _) `should_follow` (CAssign _ src2)
490 = dest1 `conflictsWith` src2
491 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
492 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
493 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
494 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
495 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
496 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
498 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
499 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
505 @conflictsWith@ tells whether an assignment to its first argument will
506 screw up an access to its second.
509 conflictsWith :: CAddrMode -> CAddrMode -> Bool
510 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
511 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
512 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
513 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
514 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
515 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
517 other1 `conflictsWith` other2 = False
518 -- CAddr and literals are impossible on the LHS of an assignment
520 regConflictsWithRR :: MagicId -> RegRelative -> Bool
522 regConflictsWithRR (VanillaReg k n) (NodeRel _) | n ==# (_ILIT 1) = True
523 regConflictsWithRR Sp (SpRel _) = True
524 regConflictsWithRR Hp (HpRel _) = True
525 regConflictsWithRR _ _ = False
527 rrConflictsWithRR :: Int -> Int -- Sizes of two things
528 -> RegRelative -> RegRelative -- The two amodes
531 rrConflictsWithRR s1b s2b rr1 rr2 = rr rr1 rr2
536 rr (SpRel o1) (SpRel o2)
537 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
538 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
539 | otherwise = (o1 +# s1) >=# o2 &&
542 rr (NodeRel o1) (NodeRel o2)
543 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
544 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
545 | otherwise = True -- Give up
547 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
549 rr other1 other2 = False