2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 module AbsCStixGen ( genCodeAbstractC ) where
8 #include "HsVersions.h"
10 import Ratio ( Rational )
16 import AbsCUtils ( getAmodeRep, mixedTypeLocn,
17 nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
19 import Constants ( mIN_UPD_SIZE )
20 import CLabel ( CLabel )
21 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
22 fastLabelFromCI, closureUpdReqd
24 import HeapOffs ( hpRelToInt )
25 import Literal ( Literal(..) )
26 import Maybes ( maybeToBool )
27 import OrdList ( OrdList )
28 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
29 import PrimRep ( isFloatingRep, PrimRep(..) )
30 import StixInfo ( genCodeInfoTable )
31 import StixMacro ( macroCode )
32 import StixPrim ( primCode, amodeToStix, amodeToStix' )
33 import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM )
34 import Util ( naturalMergeSortLe, panic )
36 #ifdef REALLY_HASKELL_1_3
37 ord = fromEnum :: Char -> Int
41 For each independent chunk of AbstractC code, we generate a list of
42 @StixTree@s, where each tree corresponds to a single Stix instruction.
43 We leave the chunks separated so that register allocation can be
44 performed locally within the chunk.
47 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
50 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
51 returnUs ([StComment SLIT("Native Code")] : trees)
54 a2stix' = amodeToStix'
55 volsaves = volatileSaves
56 volrestores = volatileRestores
58 macro_code = macroCode
60 -- real code follows... ---------
63 Here we handle top-level things, like @CCodeBlock@s and
73 gentopcode (CCodeBlock label absC)
74 = gencode absC `thenUs` \ code ->
75 returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
77 gentopcode stmt@(CStaticClosure label _ _ _)
78 = genCodeStaticClosure stmt `thenUs` \ code ->
79 returnUs (StSegment DataSegment : StLabel label : code [])
81 gentopcode stmt@(CRetUnVector _ _) = returnUs []
83 gentopcode stmt@(CFlatRetVector label _)
84 = genCodeVecTbl stmt `thenUs` \ code ->
85 returnUs (StSegment TextSegment : code [StLabel label])
87 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
90 = genCodeInfoTable stmt `thenUs` \ itbl ->
91 returnUs (StSegment TextSegment : itbl [])
94 = genCodeInfoTable stmt `thenUs` \ itbl ->
95 gencode slow `thenUs` \ slow_code ->
96 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
97 slow_code [StFunEnd slow_lbl]))
99 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
100 slow_lbl = entryLabelFromCI cl_info
102 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
103 -- ToDo: what if this is empty? ------------------------^^^^
104 genCodeInfoTable stmt `thenUs` \ itbl ->
105 gencode slow `thenUs` \ slow_code ->
106 gencode fast `thenUs` \ fast_code ->
107 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
108 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
109 fast_code [StFunEnd fast_lbl])))
111 slow_lbl = entryLabelFromCI cl_info
112 fast_lbl = fastLabelFromCI cl_info
115 = gencode absC `thenUs` \ code ->
116 returnUs (StSegment TextSegment : code [])
120 Vector tables are trivial!
126 -> UniqSM StixTreeList
128 genCodeVecTbl (CFlatRetVector label amodes)
129 = returnUs (\xs -> vectbl : xs)
131 vectbl = StData PtrRep (reverse (map a2stix amodes))
135 Static closures are not so hard either.
141 -> UniqSM StixTreeList
143 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
144 = returnUs (\xs -> table : xs)
146 table = StData PtrRep (StCLbl info_lbl : body)
147 info_lbl = infoTableLabelFromCI cl_info
149 body = if closureUpdReqd cl_info then
150 take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
154 zeros = StInt 0 : zeros
156 amodes' = map amodeZeroVoid amodes
158 -- Watch out for VoidKinds...cf. PprAbsC
160 | getAmodeRep item == VoidRep = StInt 0
161 | otherwise = a2stix item
165 Now the individual AbstractC statements.
171 -> UniqSM StixTreeList
175 @AbsCNop@s just disappear.
179 gencode AbsCNop = returnUs id
183 Split markers are a NOP in this land.
187 gencode CSplitMarker = returnUs id
191 AbstractC instruction sequences are handled individually, and the
192 resulting StixTreeLists are joined together.
196 gencode (AbsCStmts c1 c2)
197 = gencode c1 `thenUs` \ b1 ->
198 gencode c2 `thenUs` \ b2 ->
203 Initialising closure headers in the heap...a fairly complex ordeal if
204 done properly. For now, we just set the info pointer, but we should
205 really take a peek at the flags to determine whether or not there are
206 other things to be done (setting cost centres, age headers, global
211 gencode (CInitHdr cl_info reg_rel _ _)
213 lhs = a2stix (CVal reg_rel PtrRep)
214 lbl = infoTableLabelFromCI cl_info
216 returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
220 Assignment, the curse of von Neumann, is the center of the code we
221 produce. In most cases, the type of the assignment is determined
222 by the type of the destination. However, when the destination can
223 have mixed types, the type of the assignment is ``StgWord'' (we use
224 PtrRep for lack of anything better). Think: do we also want a cast
225 of the source? Be careful about floats/doubles.
229 gencode (CAssign lhs rhs)
230 | getAmodeRep lhs == VoidRep = returnUs id
232 = let pk = getAmodeRep lhs
233 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
237 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
241 Unconditional jumps, including the special ``enter closure'' operation.
242 Note that the new entry convention requires that we load the InfoPtr (R2)
243 with the address of the info table before jumping to the entry code for Node.
248 = returnUs (\xs -> StJump (a2stix dest) : xs)
250 gencode (CFallThrough (CLbl lbl _))
251 = returnUs (\xs -> StFallThrough lbl : xs)
253 gencode (CReturn dest DirectReturn)
254 = returnUs (\xs -> StJump (a2stix dest) : xs)
256 gencode (CReturn table (StaticVectoredReturn n))
257 = returnUs (\xs -> StJump dest : xs)
259 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
260 (StInt (toInteger (-n-1))))
262 gencode (CReturn table (DynamicVectoredReturn am))
263 = returnUs (\xs -> StJump dest : xs)
265 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
266 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
270 Now the PrimOps, some of which may need caller-saves register wrappers.
274 gencode (COpStmt results op args liveness_mask vols)
275 -- ToDo (ADR?): use that liveness mask
276 | primOpNeedsWrapper op
278 saves = volsaves vols
279 restores = volrestores vols
281 p2stix (nonVoid results) op (nonVoid args)
283 returnUs (\xs -> saves ++ code (restores ++ xs))
285 | otherwise = p2stix (nonVoid results) op (nonVoid args)
287 nonVoid = filter ((/= VoidRep) . getAmodeRep)
291 Now the dreaded conditional jump.
293 Now the if statement. Almost *all* flow of control are of this form.
295 if (am==lit) { absC } else { absCdef }
309 gencode (CSwitch discrim alts deflt)
313 [(tag,alt_code)] -> case maybe_empty_deflt of
314 Nothing -> gencode alt_code
315 Just dc -> mkIfThenElse discrim tag alt_code dc
317 [(tag1@(MachInt i1 _), alt_code1),
318 (tag2@(MachInt i2 _), alt_code2)]
319 | deflt_is_empty && i1 == 0 && i2 == 1
320 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
321 | deflt_is_empty && i1 == 1 && i2 == 0
322 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
324 -- If the @discrim@ is simple, then this unfolding is safe.
325 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
327 -- Otherwise, we need to do a bit of work.
328 other -> getUnique `thenUs` \ u ->
330 (CAssign (CTemp u pk) discrim)
331 (CSwitch (CTemp u pk) alts deflt))
334 maybe_empty_deflt = nonemptyAbsC deflt
335 deflt_is_empty = case maybe_empty_deflt of
339 pk = getAmodeRep discrim
341 simple_discrim = case discrim of
349 Finally, all of the disgusting AbstractC macros.
353 gencode (CMacroStmt macro args) = macro_code macro args
355 gencode (CCallProfCtrMacro macro _)
356 = returnUs (\xs -> StComment macro : xs)
358 gencode (CCallProfCCMacro macro _)
359 = returnUs (\xs -> StComment macro : xs)
363 Here, we generate a jump table if there are more than four (integer) alternatives and
364 the jump table occupancy is greater than 50%. Otherwise, we generate a binary
365 comparison tree. (Perhaps this could be tuned.)
369 intTag :: Literal -> Integer
370 intTag (MachChar c) = fromInt (ord c)
371 intTag (MachInt i _) = i
372 intTag _ = panic "intTag"
374 fltTag :: Literal -> Rational
376 fltTag (MachFloat f) = f
377 fltTag (MachDouble d) = d
378 fltTag _ = panic "fltTag"
382 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
383 -> UniqSM StixTreeList
385 mkSimpleSwitches am alts absC
386 = getUniqLabelNCG `thenUs` \ udlbl ->
387 getUniqLabelNCG `thenUs` \ ujlbl ->
389 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
390 sortedAlts = naturalMergeSortLe leAlt joinedAlts
391 -- naturalMergeSortLe, because we often get sorted alts to begin with
393 lowTag = intTag (fst (head sortedAlts))
394 highTag = intTag (fst (last sortedAlts))
396 -- lowest and highest possible values the discriminant could take
397 lowest = if floating then targetMinDouble else targetMinInt
398 highest = if floating then targetMaxDouble else targetMaxInt
401 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
402 mkJumpTable am' sortedAlts lowTag highTag udlbl
404 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
406 `thenUs` \ alt_code ->
407 gencode absC `thenUs` \ dflt_code ->
409 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
412 floating = isFloatingRep (getAmodeRep am)
413 choices = length alts
415 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
416 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
417 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
421 We use jump tables when doing an integer switch on a relatively dense
422 list of alternatives. We expect to be given a list of alternatives,
423 sorted by tag, and a range of values for which we are to generate a
424 table. Of course, the tags of the alternatives should lie within the
425 indicated range. The alternatives need not cover the range; a default
426 target is provided for the missing alternatives.
428 If a join is necessary after the switch, the alternatives should
429 already finish with a jump to the join point.
434 :: StixTree -- discriminant
435 -> [(Literal, AbstractC)] -- alternatives
436 -> Integer -- low tag
437 -> Integer -- high tag
438 -> CLabel -- default label
439 -> UniqSM StixTreeList
442 mkJumpTable am alts lowTag highTag dflt
443 = getUniqLabelNCG `thenUs` \ utlbl ->
444 mapUs genLabel alts `thenUs` \ branches ->
445 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
446 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
448 offset = StPrim IntSubOp [am, StInt lowTag]
450 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
452 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
454 mapUs mkBranch branches `thenUs` \ alts ->
456 returnUs (\xs -> cjmpLo : cjmpHi : jump :
457 StSegment DataSegment : tlbl : table :
458 StSegment TextSegment : foldr1 (.) alts xs)
461 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
463 mkBranch (lbl,(_,alt)) =
464 gencode alt `thenUs` \ alt_code ->
465 returnUs (\xs -> StLabel lbl : alt_code xs)
467 mkTable _ [] tbl = reverse tbl
468 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
469 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
470 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
471 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
475 We generate binary comparison trees when a jump table is inappropriate.
476 We expect to be given a list of alternatives, sorted by tag, and for
477 convenience, the length of the alternative list. We recursively break
478 the list in half and do a comparison on the first tag of the second half
479 of the list. (Odd lists are broken so that the second half of the list
480 is longer.) We can handle either integer or floating kind alternatives,
481 so long as they are not mixed. (We assume that the type of the discriminant
482 determines the type of the alternatives.)
484 As with the jump table approach, if a join is necessary after the switch, the
485 alternatives should already finish with a jump to the join point.
490 :: StixTree -- discriminant
491 -> Bool -- floating point?
492 -> [(Literal, AbstractC)] -- alternatives
493 -> Int -- number of choices
494 -> Literal -- low tag
495 -> Literal -- high tag
496 -> CLabel -- default code label
497 -> UniqSM StixTreeList
500 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
501 | rangeOfOne = gencode alt
503 = let tag' = a2stix (CLit tag)
504 cmpOp = if floating then DoubleNeOp else IntNeOp
505 test = StPrim cmpOp [am, tag']
506 cjmp = StCondJump udlbl test
508 gencode alt `thenUs` \ alt_code ->
509 returnUs (\xs -> cjmp : alt_code xs)
512 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
513 -- When there is only one possible tag left in range, we skip the comparison
515 mkBinaryTree am floating alts choices lowTag highTag udlbl
516 = getUniqLabelNCG `thenUs` \ uhlbl ->
517 let tag' = a2stix (CLit splitTag)
518 cmpOp = if floating then DoubleGeOp else IntGeOp
519 test = StPrim cmpOp [am, tag']
520 cjmp = StCondJump uhlbl test
522 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
523 `thenUs` \ lo_code ->
524 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
525 `thenUs` \ hi_code ->
527 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
530 half = choices `div` 2
531 (alts_lo, alts_hi) = splitAt half alts
532 splitTag = fst (head alts_hi)
539 :: CAddrMode -- discriminant
541 -> AbstractC -- if-part
542 -> AbstractC -- else-part
543 -> UniqSM StixTreeList
546 mkIfThenElse discrim tag alt deflt
547 = getUniqLabelNCG `thenUs` \ ujlbl ->
548 getUniqLabelNCG `thenUs` \ utlbl ->
549 let discrim' = a2stix discrim
550 tag' = a2stix (CLit tag)
551 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
552 test = StPrim cmpOp [discrim', tag']
553 cjmp = StCondJump utlbl test
557 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
558 gencode deflt `thenUs` \ dflt_code ->
559 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
561 mkJoin :: AbstractC -> CLabel -> AbstractC
564 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
568 %---------------------------------------------------------------------------
570 This answers the question: Can the code fall through to the next
571 line(s) of code? This errs towards saying True if it can't choose,
572 because it is used for eliminating needless jumps. In other words, if
573 you might possibly {\em not} jump, then say yes to falling through.
576 mightFallThrough :: AbstractC -> Bool
578 mightFallThrough absC = ft absC True
580 ft AbsCNop if_empty = if_empty
582 ft (CJump _) if_empty = False
583 ft (CReturn _ _) if_empty = False
584 ft (CSwitch _ alts deflt) if_empty
585 = ft deflt if_empty ||
586 or [ft alt if_empty | (_,alt) <- alts]
588 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
589 ft _ if_empty = if_empty
591 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
592 fallThroughAbsC (AbsCStmts c1 c2)
593 = case nonemptyAbsC c2 of
594 Nothing -> fallThroughAbsC c1
595 Just x -> fallThroughAbsC x
596 fallThroughAbsC (CJump _) = False
597 fallThroughAbsC (CReturn _ _) = False
598 fallThroughAbsC (CSwitch _ choices deflt)
599 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
600 || or (map (fallThroughAbsC . snd) choices)
601 fallThroughAbsC other = True
603 isEmptyAbsC :: AbstractC -> Bool
604 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
605 ================= End of old, quadratic, algorithm -}