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_OutputLanguage, opt_EmitCExternDecls )
31 import Maybes ( maybeToBool )
32 import PrimOp ( PrimOp(..), CCall(..), isDynamicTarget )
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
136 magicIdPrimRep CurrentTSO = ThreadIdRep
137 magicIdPrimRep CurrentNursery = PtrRep
140 %************************************************************************
142 \subsection[AbsCUtils-amode-kinds]{Finding @PrimitiveKinds@ of amodes}
144 %************************************************************************
146 See also the return conventions for unboxed things; currently living
147 in @CgCon@ (next to the constructor return conventions).
149 ToDo: tiny tweaking may be in order
151 getAmodeRep :: CAddrMode -> PrimRep
153 getAmodeRep (CVal _ kind) = kind
154 getAmodeRep (CAddr _) = PtrRep
155 getAmodeRep (CReg magic_id) = magicIdPrimRep magic_id
156 getAmodeRep (CTemp uniq kind) = kind
157 getAmodeRep (CLbl _ kind) = kind
158 getAmodeRep (CCharLike _) = PtrRep
159 getAmodeRep (CIntLike _) = PtrRep
160 getAmodeRep (CLit lit) = literalPrimRep lit
161 getAmodeRep (CMacroExpr kind _ _) = kind
162 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
165 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
166 location; that is, one which can contain values of various types.
169 mixedTypeLocn :: CAddrMode -> Bool
171 mixedTypeLocn (CVal (NodeRel _) _) = True
172 mixedTypeLocn (CVal (SpRel _) _) = True
173 mixedTypeLocn (CVal (HpRel _) _) = True
174 mixedTypeLocn other = False -- All the rest
177 @mixedPtrLocn@ tells whether an amode identifies a
178 location which can contain values of various pointer types.
181 mixedPtrLocn :: CAddrMode -> Bool
183 mixedPtrLocn (CVal (SpRel _) _) = True
184 mixedPtrLocn other = False -- All the rest
187 %************************************************************************
189 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
191 %************************************************************************
193 The following bits take ``raw'' Abstract~C, which may have all sorts of
194 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
195 @CClosureInfos@ and code for switches are pulled out to the top level.
197 The various functions herein tend to produce
200 A {\em flattened} \tr{<something>} of interest for ``here'', and
202 Some {\em unflattened} Abstract~C statements to be carried up to the
203 top-level. The only real reason (now) that it is unflattened is
204 because it means the recursive flattening can be done in just one
205 place rather than having to remember lots of places.
208 Care is taken to reduce the occurrence of forward references, while still
209 keeping laziness a much as possible. Essentially, this means that:
212 {\em All} the top-level C statements resulting from flattening a
213 particular AbsC statement (whether the latter is nested or not) appear
214 before {\em any} of the code for a subsequent AbsC statement;
216 but stuff nested within any AbsC statement comes
217 out before the code for the statement itself.
220 The ``stuff to be carried up'' always includes a label: a
221 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
222 @CCodeBlock@. The latter turns into a C function, and is never
223 actually produced by the code generator. Rather it always starts life
224 as a @CCodeBlock@ addressing mode; when such an addr mode is
225 flattened, the ``tops'' stuff is a @CCodeBlock@.
228 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
231 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
232 here `mkAbsCStmts` tops }
235 %************************************************************************
237 \subsubsection{Flattening monadery}
239 %************************************************************************
241 The flattener is monadised. It's just a @UniqueSupply@.
244 type FlatM result = UniqSupply -> result
246 initFlt :: UniqSupply -> FlatM a -> a
248 initFlt init_us m = m init_us
250 {-# INLINE thenFlt #-}
251 {-# INLINE returnFlt #-}
253 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
256 = case (splitUniqSupply us) of { (s1, s2) ->
257 case (expr s1) of { result ->
260 returnFlt :: a -> FlatM a
261 returnFlt result us = result
263 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
265 mapFlt f [] = returnFlt []
267 = f x `thenFlt` \ r ->
268 mapFlt f xs `thenFlt` \ rs ->
271 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
273 mapAndUnzipFlt f [] = returnFlt ([],[])
274 mapAndUnzipFlt f (x:xs)
275 = f x `thenFlt` \ (r1, r2) ->
276 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
277 returnFlt (r1:rs1, r2:rs2)
279 getUniqFlt :: FlatM Unique
280 getUniqFlt us = uniqFromSupply us
282 getUniqsFlt :: Int -> FlatM [Unique]
283 getUniqsFlt i us = uniqsFromSupply i us
286 %************************************************************************
288 \subsubsection{Flattening the top level}
290 %************************************************************************
293 flatAbsC :: AbstractC
294 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
295 AbstractC) -- Stuff to put at top level flattened]
297 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
299 flatAbsC (AbsCStmts s1 s2)
300 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
301 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
302 returnFlt (mkAbsCStmts inline_s1 inline_s2,
303 mkAbsCStmts top_s1 top_s2)
305 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
306 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
307 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
308 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
309 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
312 flatAbsC (CCodeBlock lbl abs_C)
313 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
314 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
316 flatAbsC (CRetDirect uniq slow_code srt liveness)
317 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
319 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
321 flatAbsC (CSwitch discrim alts deflt)
322 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
323 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
325 CSwitch discrim flat_alts flat_def_alt,
326 mkAbstractCs (def_tops : flat_alts_tops)
330 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
331 returnFlt ( (tag, alt_heres), alt_tops )
333 flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
334 | isCandidate && opt_OutputLanguage == Just "C" -- Urgh
335 = returnFlt (stmt, tdef)
337 = returnFlt (stmt, AbsCNop)
339 isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
340 is_dynamic = isDynamicTarget target
342 tdef = CCallTypedef is_dynamic ccall 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