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 ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget, isCasmTarget )
32 import StgSyn ( StgOp(..) )
33 import Panic ( panic )
36 import Maybe ( isJust )
41 Check if there is any real code in some Abstract~C. If so, return it
42 (@Just ...@); otherwise, return @Nothing@. Don't be too strict!
44 It returns the "reduced" code in the Just part so that the work of
45 discarding AbsCNops isn't lost, and so that if the caller uses
46 the reduced version there's less danger of a big tree of AbsCNops getting
47 materialised and causing a space leak.
50 nonemptyAbsC :: AbstractC -> Maybe AbstractC
51 nonemptyAbsC AbsCNop = Nothing
52 nonemptyAbsC (AbsCStmts s1 s2) = case (nonemptyAbsC s1) of
53 Nothing -> nonemptyAbsC s2
54 Just x -> Just (AbsCStmts x s2)
55 nonemptyAbsC s@(CSimultaneous c) = case (nonemptyAbsC c) of
58 nonemptyAbsC other = Just other
62 mkAbstractCs :: [AbstractC] -> AbstractC
63 mkAbstractCs [] = AbsCNop
64 mkAbstractCs cs = foldr1 mkAbsCStmts cs
66 -- for fiddling around w/ killing off AbsCNops ... (ToDo)
67 mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
68 mkAbsCStmts AbsCNop c = c
69 mkAbsCStmts c AbsCNop = c
70 mkAbsCStmts c1 c2 = c1 `AbsCStmts` c2
72 {- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
73 = case (case (nonemptyAbsC abc2) of
75 Just d2 -> d2) of { abc2b ->
77 case (nonemptyAbsC abc1) of {
79 Just d1 -> AbsCStmts d1 abc2b
84 Get the sho' 'nuff statements out of an @AbstractC@.
86 mkAbsCStmtList :: AbstractC -> [AbstractC]
88 mkAbsCStmtList absC = mkAbsCStmtList' absC []
90 -- Optimised a la foldr/build!
92 mkAbsCStmtList' AbsCNop r = r
94 mkAbsCStmtList' (AbsCStmts s1 s2) r
95 = mkAbsCStmtList' s1 (mkAbsCStmtList' s2 r)
97 mkAbsCStmtList' s@(CSimultaneous c) r
98 = if null (mkAbsCStmtList c) then r else s : r
100 mkAbsCStmtList' other r = other : r
104 mkAlgAltsCSwitch :: CAddrMode -> [(ConTag, AbstractC)] -> AbstractC -> AbstractC
106 mkAlgAltsCSwitch scrutinee tagged_alts deflt_absc
107 | isJust (nonemptyAbsC deflt_absc)
108 = CSwitch scrutinee (adjust tagged_alts) deflt_absc
110 = CSwitch scrutinee (adjust rest) first_alt
112 -- it's ok to convert one of the alts into a default if we don't already have
113 -- one, because this is an algebraic case and we're guaranteed that the tag
114 -- will match one of the branches.
115 ((_,first_alt):rest) = tagged_alts
117 -- Adjust the tags in the switch to start at zero.
118 -- This is the convention used by primitive ops which return algebraic
119 -- data types. Why? Because for two-constructor types, zero is faster
120 -- to create and distinguish from 1 than are 1 and 2.
122 -- We also need to convert to Literals to keep the CSwitch happy
124 = [ (mkMachWord (toInteger (tag - fIRST_TAG)), abs_c)
125 | (tag, abs_c) <- tagged_alts ]
128 %************************************************************************
130 \subsubsection[AbsCUtils-kinds-from-MagicIds]{Kinds from MagicIds}
132 %************************************************************************
135 magicIdPrimRep BaseReg = PtrRep
136 magicIdPrimRep (VanillaReg kind _) = kind
137 magicIdPrimRep (FloatReg _) = FloatRep
138 magicIdPrimRep (DoubleReg _) = DoubleRep
139 magicIdPrimRep (LongReg kind _) = kind
140 magicIdPrimRep Sp = PtrRep
141 magicIdPrimRep Su = PtrRep
142 magicIdPrimRep SpLim = PtrRep
143 magicIdPrimRep Hp = PtrRep
144 magicIdPrimRep HpLim = PtrRep
145 magicIdPrimRep CurCostCentre = CostCentreRep
146 magicIdPrimRep VoidReg = VoidRep
147 magicIdPrimRep CurrentTSO = ThreadIdRep
148 magicIdPrimRep CurrentNursery = PtrRep
151 %************************************************************************
153 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
155 %************************************************************************
157 See also the return conventions for unboxed things; currently living
158 in @CgCon@ (next to the constructor return conventions).
160 ToDo: tiny tweaking may be in order
162 getAmodeRep :: CAddrMode -> PrimRep
164 getAmodeRep (CVal _ kind) = kind
165 getAmodeRep (CAddr _) = PtrRep
166 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
167 getAmodeRep (CTemp uniq kind) = kind
168 getAmodeRep (CLbl _ kind) = kind
169 getAmodeRep (CCharLike _) = PtrRep
170 getAmodeRep (CIntLike _) = PtrRep
171 getAmodeRep (CLit lit) = literalPrimRep lit
172 getAmodeRep (CMacroExpr kind _ _) = kind
173 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
176 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
177 location; that is, one which can contain values of various types.
180 mixedTypeLocn :: CAddrMode -> Bool
182 mixedTypeLocn (CVal (NodeRel _) _) = True
183 mixedTypeLocn (CVal (SpRel _) _) = True
184 mixedTypeLocn (CVal (HpRel _) _) = True
185 mixedTypeLocn other = False -- All the rest
188 @mixedPtrLocn@ tells whether an amode identifies a
189 location which can contain values of various pointer types.
192 mixedPtrLocn :: CAddrMode -> Bool
194 mixedPtrLocn (CVal (SpRel _) _) = True
195 mixedPtrLocn other = False -- All the rest
198 %************************************************************************
200 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
202 %************************************************************************
204 The following bits take ``raw'' Abstract~C, which may have all sorts of
205 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
206 @CClosureInfos@ and code for switches are pulled out to the top level.
208 The various functions herein tend to produce
211 A {\em flattened} \tr{<something>} of interest for ``here'', and
213 Some {\em unflattened} Abstract~C statements to be carried up to the
214 top-level. The only real reason (now) that it is unflattened is
215 because it means the recursive flattening can be done in just one
216 place rather than having to remember lots of places.
219 Care is taken to reduce the occurrence of forward references, while still
220 keeping laziness a much as possible. Essentially, this means that:
223 {\em All} the top-level C statements resulting from flattening a
224 particular AbsC statement (whether the latter is nested or not) appear
225 before {\em any} of the code for a subsequent AbsC statement;
227 but stuff nested within any AbsC statement comes
228 out before the code for the statement itself.
231 The ``stuff to be carried up'' always includes a label: a
232 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
233 @CCodeBlock@. The latter turns into a C function, and is never
234 actually produced by the code generator. Rather it always starts life
235 as a @CCodeBlock@ addressing mode; when such an addr mode is
236 flattened, the ``tops'' stuff is a @CCodeBlock@.
239 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
242 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
243 here `mkAbsCStmts` tops }
246 %************************************************************************
248 \subsubsection{Flattening monadery}
250 %************************************************************************
252 The flattener is monadised. It's just a @UniqueSupply@.
255 type FlatM result = UniqSupply -> result
257 initFlt :: UniqSupply -> FlatM a -> a
259 initFlt init_us m = m init_us
261 {-# INLINE thenFlt #-}
262 {-# INLINE returnFlt #-}
264 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
267 = case (splitUniqSupply us) of { (s1, s2) ->
268 case (expr s1) of { result ->
271 returnFlt :: a -> FlatM a
272 returnFlt result us = result
274 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
276 mapFlt f [] = returnFlt []
278 = f x `thenFlt` \ r ->
279 mapFlt f xs `thenFlt` \ rs ->
282 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
284 mapAndUnzipFlt f [] = returnFlt ([],[])
285 mapAndUnzipFlt f (x:xs)
286 = f x `thenFlt` \ (r1, r2) ->
287 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
288 returnFlt (r1:rs1, r2:rs2)
290 getUniqFlt :: FlatM Unique
291 getUniqFlt us = uniqFromSupply us
293 getUniqsFlt :: FlatM [Unique]
294 getUniqsFlt us = uniqsFromSupply us
297 %************************************************************************
299 \subsubsection{Flattening the top level}
301 %************************************************************************
304 flatAbsC :: AbstractC
305 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
306 AbstractC) -- Stuff to put at top level flattened]
308 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
310 flatAbsC (AbsCStmts s1 s2)
311 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
312 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
313 returnFlt (mkAbsCStmts inline_s1 inline_s2,
314 mkAbsCStmts top_s1 top_s2)
316 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
317 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
318 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
319 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
320 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
323 flatAbsC (CCodeBlock lbl abs_C)
324 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
325 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
327 flatAbsC (CRetDirect uniq slow_code srt liveness)
328 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
330 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
332 flatAbsC (CSwitch discrim alts deflt)
333 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
334 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
336 CSwitch discrim flat_alts flat_def_alt,
337 mkAbstractCs (def_tops : flat_alts_tops)
341 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
342 returnFlt ( (tag, alt_heres), alt_tops )
344 flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
345 | is_dynamic -- Emit a typedef if its a dynamic call
346 || (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
347 = returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
349 is_dynamic = isDynamicTarget target
351 flatAbsC stmt@(CSimultaneous abs_c)
352 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
353 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
354 returnFlt (new_stmts_here, tops)
356 flatAbsC stmt@(CCheck macro amodes code)
357 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
358 returnFlt (CCheck macro amodes code_here, code_tops)
360 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
362 flatAbsC stmt@(CCallProfCtrMacro str amodes)
363 | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
364 | otherwise = returnFlt (stmt, AbsCNop)
366 -- Some statements need no flattening at all:
367 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
368 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
369 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
370 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
371 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
372 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
373 flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
374 flatAbsC stmt@(COpStmt results op args vol_regs) = returnFlt (stmt, AbsCNop)
376 -- Some statements only make sense at the top level, so we always float
377 -- them. This probably isn't necessary.
378 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
379 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
380 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
381 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
382 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
383 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
384 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
385 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
386 flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
390 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
391 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
392 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
393 returnFlt (Just heres, tops)
396 %************************************************************************
398 \subsection[flat-simultaneous]{Doing things simultaneously}
400 %************************************************************************
403 doSimultaneously :: AbstractC -> FlatM AbstractC
406 Generate code to perform the @CAssign@s and @COpStmt@s in the
407 input simultaneously, using temporary variables when necessary.
409 We use the strongly-connected component algorithm, in which
410 * the vertices are the statements
411 * an edge goes from s1 to s2 iff
412 s1 assigns to something s2 uses
413 that is, if s1 should *follow* s2 in the final order
416 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
417 -- for fast comparison
419 doSimultaneously abs_c
421 enlisted = en_list abs_c
423 case enlisted of -- it's often just one stmt
424 [] -> returnFlt AbsCNop
426 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
428 -- en_list puts all the assignments in a list, filtering out Nops and
429 -- assignments which do nothing
431 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
432 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
433 en_list other = [other]
435 sameAmode :: CAddrMode -> CAddrMode -> Bool
436 -- ToDo: Move this function, or make CAddrMode an instance of Eq
437 -- At the moment we put in just enough to catch the cases we want:
438 -- the second (destination) argument is always a CVal.
439 sameAmode (CReg r1) (CReg r2) = r1 == r2
440 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 ==# r2
441 sameAmode other1 other2 = False
443 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
444 doSimultaneously1 vertices
446 edges = [ (vertex, key1, edges_from stmt1)
447 | vertex@(key1, stmt1) <- vertices
449 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
450 stmt1 `should_follow` stmt2
452 components = stronglyConnComp edges
454 -- do_components deal with one strongly-connected component
455 -- Not cyclic, or singleton? Just do it
456 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
457 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
459 -- Cyclic? Then go via temporaries. Pick one to
460 -- break the loop and try again with the rest.
461 do_component (CyclicSCC ((n,first_stmt) : rest))
462 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
463 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
464 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
466 go_via_temps (CAssign dest src)
467 = getUniqFlt `thenFlt` \ uniq ->
469 the_temp = CTemp uniq (getAmodeRep dest)
471 returnFlt (CAssign the_temp src, CAssign dest the_temp)
473 go_via_temps (COpStmt dests op srcs vol_regs)
474 = getUniqsFlt `thenFlt` \ uniqs ->
476 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
478 returnFlt (COpStmt the_temps op srcs vol_regs,
479 mkAbstractCs (zipWith CAssign dests the_temps))
481 mapFlt do_component components `thenFlt` \ abs_cs ->
482 returnFlt (mkAbstractCs abs_cs)
485 should_follow :: AbstractC -> AbstractC -> Bool
486 (CAssign dest1 _) `should_follow` (CAssign _ src2)
487 = dest1 `conflictsWith` src2
488 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
489 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
490 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
491 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
492 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
493 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
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 n) (NodeRel _) | n ==# (_ILIT 1) = 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 s1b s2b rr1 rr2 = rr rr1 rr2
528 rr (SpRel o1) (SpRel o2)
529 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
530 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
531 | otherwise = (o1 +# s1) >=# o2 &&
534 rr (NodeRel o1) (NodeRel o2)
535 | s1 ==# (_ILIT 0) || s2 ==# (_ILIT 0) = False -- No conflict if either is size zero
536 | s1 ==# (_ILIT 1) && s2 ==# (_ILIT 1) = o1 ==# o2
537 | otherwise = True -- Give up
539 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
541 rr other1 other2 = False