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 (CLitLit _ kind) = kind
162 getAmodeRep (CMacroExpr kind _ _) = kind
163 getAmodeRep (CJoinPoint _) = panic "getAmodeRep:CJoinPoint"
166 @mixedTypeLocn@ tells whether an amode identifies an ``StgWord''
167 location; that is, one which can contain values of various types.
170 mixedTypeLocn :: CAddrMode -> Bool
172 mixedTypeLocn (CVal (NodeRel _) _) = True
173 mixedTypeLocn (CVal (SpRel _) _) = True
174 mixedTypeLocn (CVal (HpRel _) _) = True
175 mixedTypeLocn other = False -- All the rest
178 @mixedPtrLocn@ tells whether an amode identifies a
179 location which can contain values of various pointer types.
182 mixedPtrLocn :: CAddrMode -> Bool
184 mixedPtrLocn (CVal (SpRel _) _) = True
185 mixedPtrLocn other = False -- All the rest
188 %************************************************************************
190 \subsection[AbsCUtils-flattening]{Flatten Abstract~C}
192 %************************************************************************
194 The following bits take ``raw'' Abstract~C, which may have all sorts of
195 nesting, and flattens it into one long @AbsCStmtList@. Mainly,
196 @CClosureInfos@ and code for switches are pulled out to the top level.
198 The various functions herein tend to produce
201 A {\em flattened} \tr{<something>} of interest for ``here'', and
203 Some {\em unflattened} Abstract~C statements to be carried up to the
204 top-level. The only real reason (now) that it is unflattened is
205 because it means the recursive flattening can be done in just one
206 place rather than having to remember lots of places.
209 Care is taken to reduce the occurrence of forward references, while still
210 keeping laziness a much as possible. Essentially, this means that:
213 {\em All} the top-level C statements resulting from flattening a
214 particular AbsC statement (whether the latter is nested or not) appear
215 before {\em any} of the code for a subsequent AbsC statement;
217 but stuff nested within any AbsC statement comes
218 out before the code for the statement itself.
221 The ``stuff to be carried up'' always includes a label: a
222 @CStaticClosure@, @CRetDirect@, @CFlatRetVector@, or
223 @CCodeBlock@. The latter turns into a C function, and is never
224 actually produced by the code generator. Rather it always starts life
225 as a @CCodeBlock@ addressing mode; when such an addr mode is
226 flattened, the ``tops'' stuff is a @CCodeBlock@.
229 flattenAbsC :: UniqSupply -> AbstractC -> AbstractC
232 = case (initFlt us (flatAbsC abs_C)) of { (here, tops) ->
233 here `mkAbsCStmts` tops }
236 %************************************************************************
238 \subsubsection{Flattening monadery}
240 %************************************************************************
242 The flattener is monadised. It's just a @UniqueSupply@.
245 type FlatM result = UniqSupply -> result
247 initFlt :: UniqSupply -> FlatM a -> a
249 initFlt init_us m = m init_us
251 {-# INLINE thenFlt #-}
252 {-# INLINE returnFlt #-}
254 thenFlt :: FlatM a -> (a -> FlatM b) -> FlatM b
257 = case (splitUniqSupply us) of { (s1, s2) ->
258 case (expr s1) of { result ->
261 returnFlt :: a -> FlatM a
262 returnFlt result us = result
264 mapFlt :: (a -> FlatM b) -> [a] -> FlatM [b]
266 mapFlt f [] = returnFlt []
268 = f x `thenFlt` \ r ->
269 mapFlt f xs `thenFlt` \ rs ->
272 mapAndUnzipFlt :: (a -> FlatM (b,c)) -> [a] -> FlatM ([b],[c])
274 mapAndUnzipFlt f [] = returnFlt ([],[])
275 mapAndUnzipFlt f (x:xs)
276 = f x `thenFlt` \ (r1, r2) ->
277 mapAndUnzipFlt f xs `thenFlt` \ (rs1, rs2) ->
278 returnFlt (r1:rs1, r2:rs2)
280 getUniqFlt :: FlatM Unique
281 getUniqFlt us = uniqFromSupply us
283 getUniqsFlt :: Int -> FlatM [Unique]
284 getUniqsFlt i us = uniqsFromSupply i us
287 %************************************************************************
289 \subsubsection{Flattening the top level}
291 %************************************************************************
294 flatAbsC :: AbstractC
295 -> FlatM (AbstractC, -- Stuff to put inline [Both are fully
296 AbstractC) -- Stuff to put at top level flattened]
298 flatAbsC AbsCNop = returnFlt (AbsCNop, AbsCNop)
300 flatAbsC (AbsCStmts s1 s2)
301 = flatAbsC s1 `thenFlt` \ (inline_s1, top_s1) ->
302 flatAbsC s2 `thenFlt` \ (inline_s2, top_s2) ->
303 returnFlt (mkAbsCStmts inline_s1 inline_s2,
304 mkAbsCStmts top_s1 top_s2)
306 flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr)
307 = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
308 flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
309 returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops,
310 CClosureInfoAndCode cl_info slow_heres fast_heres descr]
313 flatAbsC (CCodeBlock lbl abs_C)
314 = flatAbsC abs_C `thenFlt` \ (absC_heres, absC_tops) ->
315 returnFlt (AbsCNop, absC_tops `mkAbsCStmts` CCodeBlock lbl absC_heres)
317 flatAbsC (CRetDirect uniq slow_code srt liveness)
318 = flatAbsC slow_code `thenFlt` \ (heres, tops) ->
320 mkAbstractCs [ tops, CRetDirect uniq heres srt liveness ])
322 flatAbsC (CSwitch discrim alts deflt)
323 = mapAndUnzipFlt flat_alt alts `thenFlt` \ (flat_alts, flat_alts_tops) ->
324 flatAbsC deflt `thenFlt` \ (flat_def_alt, def_tops) ->
326 CSwitch discrim flat_alts flat_def_alt,
327 mkAbstractCs (def_tops : flat_alts_tops)
331 = flatAbsC absC `thenFlt` \ (alt_heres, alt_tops) ->
332 returnFlt ( (tag, alt_heres), alt_tops )
334 flatAbsC stmt@(COpStmt results (CCallOp ccall@(CCall target is_asm _ _)) args vol_regs)
335 | isCandidate && opt_OutputLanguage == Just "C" -- Urgh
336 = returnFlt (stmt, tdef)
338 = returnFlt (stmt, AbsCNop)
340 isCandidate = is_dynamic || opt_EmitCExternDecls && not is_asm
341 is_dynamic = isDynamicTarget target
343 tdef = CCallTypedef is_dynamic ccall results args
345 flatAbsC stmt@(CSimultaneous abs_c)
346 = flatAbsC abs_c `thenFlt` \ (stmts_here, tops) ->
347 doSimultaneously stmts_here `thenFlt` \ new_stmts_here ->
348 returnFlt (new_stmts_here, tops)
350 flatAbsC stmt@(CCheck macro amodes code)
351 = flatAbsC code `thenFlt` \ (code_here, code_tops) ->
352 returnFlt (CCheck macro amodes code_here, code_tops)
354 -- the TICKY_CTR macro always needs to be hoisted out to the top level.
356 flatAbsC stmt@(CCallProfCtrMacro str amodes)
357 | str == SLIT("TICK_CTR") = returnFlt (AbsCNop, stmt)
358 | otherwise = returnFlt (stmt, AbsCNop)
360 -- Some statements need no flattening at all:
361 flatAbsC stmt@(CMacroStmt macro amodes) = returnFlt (stmt, AbsCNop)
362 flatAbsC stmt@(CCallProfCCMacro str amodes) = returnFlt (stmt, AbsCNop)
363 flatAbsC stmt@(CAssign dest source) = returnFlt (stmt, AbsCNop)
364 flatAbsC stmt@(CJump target) = returnFlt (stmt, AbsCNop)
365 flatAbsC stmt@(CFallThrough target) = returnFlt (stmt, AbsCNop)
366 flatAbsC stmt@(CReturn target return_info) = returnFlt (stmt, AbsCNop)
367 flatAbsC stmt@(CInitHdr a b cc) = returnFlt (stmt, AbsCNop)
368 flatAbsC stmt@(COpStmt results op args vol_regs)= returnFlt (stmt, AbsCNop)
370 -- Some statements only make sense at the top level, so we always float
371 -- them. This probably isn't necessary.
372 flatAbsC stmt@(CStaticClosure _ _ _ _) = returnFlt (AbsCNop, stmt)
373 flatAbsC stmt@(CClosureTbl _) = returnFlt (AbsCNop, stmt)
374 flatAbsC stmt@(CSRT _ _) = returnFlt (AbsCNop, stmt)
375 flatAbsC stmt@(CBitmap _ _) = returnFlt (AbsCNop, stmt)
376 flatAbsC stmt@(CCostCentreDecl _ _) = returnFlt (AbsCNop, stmt)
377 flatAbsC stmt@(CCostCentreStackDecl _) = returnFlt (AbsCNop, stmt)
378 flatAbsC stmt@(CSplitMarker) = returnFlt (AbsCNop, stmt)
379 flatAbsC stmt@(CRetVector _ _ _ _) = returnFlt (AbsCNop, stmt)
380 flatAbsC stmt@(CModuleInitBlock _ _) = returnFlt (AbsCNop, stmt)
384 flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
385 flat_maybe Nothing = returnFlt (Nothing, AbsCNop)
386 flat_maybe (Just abs_c) = flatAbsC abs_c `thenFlt` \ (heres, tops) ->
387 returnFlt (Just heres, tops)
390 %************************************************************************
392 \subsection[flat-simultaneous]{Doing things simultaneously}
394 %************************************************************************
397 doSimultaneously :: AbstractC -> FlatM AbstractC
400 Generate code to perform the @CAssign@s and @COpStmt@s in the
401 input simultaneously, using temporary variables when necessary.
403 We use the strongly-connected component algorithm, in which
404 * the vertices are the statements
405 * an edge goes from s1 to s2 iff
406 s1 assigns to something s2 uses
407 that is, if s1 should *follow* s2 in the final order
410 type CVertex = (Int, AbstractC) -- Give each vertex a unique number,
411 -- for fast comparison
413 type CEdge = (CVertex, CVertex)
415 doSimultaneously abs_c
417 enlisted = en_list abs_c
419 case enlisted of -- it's often just one stmt
420 [] -> returnFlt AbsCNop
422 _ -> doSimultaneously1 (zip [(1::Int)..] enlisted)
424 -- en_list puts all the assignments in a list, filtering out Nops and
425 -- assignments which do nothing
427 en_list (AbsCStmts a1 a2) = en_list a1 ++ en_list a2
428 en_list (CAssign am1 am2) | sameAmode am1 am2 = []
429 en_list other = [other]
431 sameAmode :: CAddrMode -> CAddrMode -> Bool
432 -- ToDo: Move this function, or make CAddrMode an instance of Eq
433 -- At the moment we put in just enough to catch the cases we want:
434 -- the second (destination) argument is always a CVal.
435 sameAmode (CReg r1) (CReg r2) = r1 == r2
436 sameAmode (CVal (SpRel r1) _) (CVal (SpRel r2) _) = r1 _EQ_ r2
437 sameAmode other1 other2 = False
439 doSimultaneously1 :: [CVertex] -> FlatM AbstractC
440 doSimultaneously1 vertices
442 edges = [ (vertex, key1, edges_from stmt1)
443 | vertex@(key1, stmt1) <- vertices
445 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
446 stmt1 `should_follow` stmt2
448 components = stronglyConnComp edges
450 -- do_components deal with one strongly-connected component
451 -- Not cyclic, or singleton? Just do it
452 do_component (AcyclicSCC (n,abs_c)) = returnFlt abs_c
453 do_component (CyclicSCC [(n,abs_c)]) = returnFlt abs_c
455 -- Cyclic? Then go via temporaries. Pick one to
456 -- break the loop and try again with the rest.
457 do_component (CyclicSCC ((n,first_stmt) : rest))
458 = doSimultaneously1 rest `thenFlt` \ abs_cs ->
459 go_via_temps first_stmt `thenFlt` \ (to_temps, from_temps) ->
460 returnFlt (mkAbstractCs [to_temps, abs_cs, from_temps])
462 go_via_temps (CAssign dest src)
463 = getUniqFlt `thenFlt` \ uniq ->
465 the_temp = CTemp uniq (getAmodeRep dest)
467 returnFlt (CAssign the_temp src, CAssign dest the_temp)
469 go_via_temps (COpStmt dests op srcs vol_regs)
470 = getUniqsFlt (length dests) `thenFlt` \ uniqs ->
472 the_temps = zipWith (\ u d -> CTemp u (getAmodeRep d)) uniqs dests
474 returnFlt (COpStmt the_temps op srcs vol_regs,
475 mkAbstractCs (zipWith CAssign dests the_temps))
477 mapFlt do_component components `thenFlt` \ abs_cs ->
478 returnFlt (mkAbstractCs abs_cs)
481 should_follow :: AbstractC -> AbstractC -> Bool
482 (CAssign dest1 _) `should_follow` (CAssign _ src2)
483 = dest1 `conflictsWith` src2
484 (COpStmt dests1 _ _ _) `should_follow` (CAssign _ src2)
485 = or [dest1 `conflictsWith` src2 | dest1 <- dests1]
486 (CAssign dest1 _)`should_follow` (COpStmt _ _ srcs2 _)
487 = or [dest1 `conflictsWith` src2 | src2 <- srcs2]
488 (COpStmt dests1 _ _ _) `should_follow` (COpStmt _ _ srcs2 _)
489 = or [dest1 `conflictsWith` src2 | dest1 <- dests1, src2 <- srcs2]
491 -- (COpStmt _ _ _ _ _) `should_follow` (CCallProfCtrMacro _ _) = False
492 -- (CCallProfCtrMacro _ _) `should_follow` (COpStmt _ _ _ _ _) = False
498 @conflictsWith@ tells whether an assignment to its first argument will
499 screw up an access to its second.
502 conflictsWith :: CAddrMode -> CAddrMode -> Bool
503 (CReg reg1) `conflictsWith` (CReg reg2) = reg1 == reg2
504 (CReg reg) `conflictsWith` (CVal reg_rel _) = reg `regConflictsWithRR` reg_rel
505 (CReg reg) `conflictsWith` (CAddr reg_rel) = reg `regConflictsWithRR` reg_rel
506 (CTemp u1 _) `conflictsWith` (CTemp u2 _) = u1 == u2
507 (CVal reg_rel1 k1) `conflictsWith` (CVal reg_rel2 k2)
508 = rrConflictsWithRR (getPrimRepSize k1) (getPrimRepSize k2) reg_rel1 reg_rel2
510 other1 `conflictsWith` other2 = False
511 -- CAddr and literals are impossible on the LHS of an assignment
513 regConflictsWithRR :: MagicId -> RegRelative -> Bool
515 regConflictsWithRR (VanillaReg k ILIT(1)) (NodeRel _) = True
517 regConflictsWithRR Sp (SpRel _) = True
518 regConflictsWithRR Hp (HpRel _) = True
519 regConflictsWithRR _ _ = False
521 rrConflictsWithRR :: Int -> Int -- Sizes of two things
522 -> RegRelative -> RegRelative -- The two amodes
525 rrConflictsWithRR (I# s1) (I# s2) rr1 rr2 = rr rr1 rr2
527 rr (SpRel o1) (SpRel o2)
528 | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
529 | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
530 | otherwise = (o1 _ADD_ s1) _GE_ o2 &&
531 (o2 _ADD_ s2) _GE_ o1
533 rr (NodeRel o1) (NodeRel o2)
534 | s1 _EQ_ ILIT(0) || s2 _EQ_ ILIT(0) = False -- No conflict if either is size zero
535 | s1 _EQ_ ILIT(1) && s2 _EQ_ ILIT(1) = o1 _EQ_ o2
536 | otherwise = True -- Give up
538 rr (HpRel _) (HpRel _) = True -- Give up (ToDo)
540 rr other1 other2 = False