2 % (c) The AQUA Project, Glasgow University, 1993-1995
6 #include "HsVersions.h"
11 -- and, of course, that's not enough...
12 AbstractC, Target, StixTree, UniqSupply, UniqSM(..)
16 import PrelInfo ( PrimOp(..), primOpNeedsWrapper, isCompareOp
17 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
18 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
20 import CgCompInfo ( mIN_UPD_SIZE )
21 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, fastLabelFromCI,
25 import Maybes ( Maybe(..), maybeToBool )
27 import PrimRep ( isFloatingRep )
28 import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
30 import StixInfo ( genCodeInfoTable )
35 For each independent chunk of AbstractC code, we generate a list of @StixTree@s,
36 where each tree corresponds to a single Stix instruction. We leave the chunks
37 separated so that register allocation can be performed locally within the chunk.
40 -- hacking with Uncle Will:
41 #define target_STRICT target@(Target _ _ _ _ _ _ _ _)
46 -> UniqSM [[StixTree]]
48 genCodeAbstractC target_STRICT absC =
49 mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
50 returnUs ([StComment SLIT("Native Code")] : trees)
52 -- "target" munging things... ---
53 a2stix = amodeToStix target
54 a2stix' = amodeToStix' target
55 volsaves = volatileSaves target
56 volrestores = volatileRestores target
57 p2stix = primToStix target
58 macro_code = macroCode target
60 -- real code follows... ---------
63 Here we handle top-level things, like @CCodeBlock@s and
74 gentopcode (CCodeBlock label absC) =
75 gencode absC `thenUs` \ code ->
76 returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
78 gentopcode stmt@(CStaticClosure label _ _ _) =
79 genCodeStaticClosure stmt `thenUs` \ code ->
80 returnUs (StSegment DataSegment : StLabel label : code [])
82 gentopcode stmt@(CRetUnVector _ _) = returnUs []
84 gentopcode stmt@(CFlatRetVector label _) =
85 genCodeVecTbl stmt `thenUs` \ code ->
86 returnUs (StSegment TextSegment : code [StLabel label])
88 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
91 = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
92 returnUs (StSegment TextSegment : itbl [])
95 = genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
96 gencode slow `thenUs` \ slow_code ->
97 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
98 slow_code [StFunEnd slow_lbl]))
100 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
101 slow_lbl = entryLabelFromCI cl_info
103 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
104 -- ToDo: what if this is empty? ------------------------^^^^
105 genCodeInfoTable hp_rel a2stix stmt `thenUs` \ itbl ->
106 gencode slow `thenUs` \ slow_code ->
107 gencode fast `thenUs` \ fast_code ->
108 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
109 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
110 fast_code [StFunEnd fast_lbl])))
112 slow_lbl = entryLabelFromCI cl_info
113 fast_lbl = fastLabelFromCI cl_info
116 gencode absC `thenUs` \ code ->
117 returnUs (StSegment TextSegment : code [])
121 Vector tables are trivial!
128 -> UniqSM StixTreeList
130 genCodeVecTbl (CFlatRetVector label amodes) =
131 returnUs (\xs -> vectbl : xs)
133 vectbl = StData PtrRep (reverse (map a2stix amodes))
137 Static closures are not so hard either.
144 -> UniqSM StixTreeList
146 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) =
147 returnUs (\xs -> table : xs)
149 table = StData PtrRep (StCLbl info_lbl : body)
150 info_lbl = infoTableLabelFromCI cl_info
152 body = if closureUpdReqd cl_info then
153 take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
157 zeros = StInt 0 : zeros
159 amodes' = map amodeZeroVoid amodes
161 -- Watch out for VoidKinds...cf. PprAbsC
163 | getAmodeRep item == VoidRep = StInt 0
164 | otherwise = a2stix item
168 Now the individual AbstractC statements.
175 -> UniqSM StixTreeList
179 @AbsCNop@s just disappear.
183 gencode AbsCNop = returnUs id
187 Split markers are a NOP in this land.
191 gencode CSplitMarker = returnUs id
195 AbstractC instruction sequences are handled individually, and the
196 resulting StixTreeLists are joined together.
200 gencode (AbsCStmts c1 c2) =
201 gencode c1 `thenUs` \ b1 ->
202 gencode c2 `thenUs` \ b2 ->
207 Initialising closure headers in the heap...a fairly complex ordeal if
208 done properly. For now, we just set the info pointer, but we should
209 really take a peek at the flags to determine whether or not there are
210 other things to be done (setting cost centres, age headers, global
215 gencode (CInitHdr cl_info reg_rel _ _) =
217 lhs = a2stix (CVal reg_rel PtrRep)
218 lbl = infoTableLabelFromCI cl_info
220 returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
224 Assignment, the curse of von Neumann, is the center of the code we
225 produce. In most cases, the type of the assignment is determined
226 by the type of the destination. However, when the destination can
227 have mixed types, the type of the assignment is ``StgWord'' (we use
228 PtrRep for lack of anything better). Think: do we also want a cast
229 of the source? Be careful about floats/doubles.
233 gencode (CAssign lhs rhs)
234 | getAmodeRep lhs == VoidRep = returnUs id
236 let pk = getAmodeRep lhs
237 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
241 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
245 Unconditional jumps, including the special ``enter closure'' operation.
246 Note that the new entry convention requires that we load the InfoPtr (R2)
247 with the address of the info table before jumping to the entry code for Node.
251 gencode (CJump dest) =
252 returnUs (\xs -> StJump (a2stix dest) : xs)
254 gencode (CFallThrough (CLbl lbl _)) =
255 returnUs (\xs -> StFallThrough lbl : xs)
257 gencode (CReturn dest DirectReturn) =
258 returnUs (\xs -> StJump (a2stix dest) : xs)
260 gencode (CReturn table (StaticVectoredReturn n)) =
261 returnUs (\xs -> StJump dest : xs)
263 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
264 (StInt (toInteger (-n-1))))
266 gencode (CReturn table (DynamicVectoredReturn am)) =
267 returnUs (\xs -> StJump dest : xs)
269 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
270 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
274 Now the PrimOps, some of which may need caller-saves register wrappers.
278 gencode (COpStmt results op args liveness_mask vols)
279 -- ToDo (ADR?): use that liveness mask
280 | primOpNeedsWrapper op =
282 saves = volsaves vols
283 restores = volrestores vols
285 p2stix (nonVoid results) op (nonVoid args)
287 returnUs (\xs -> saves ++ code (restores ++ xs))
289 | otherwise = p2stix (nonVoid results) op (nonVoid args)
291 nonVoid = filter ((/= VoidRep) . getAmodeRep)
295 Now the dreaded conditional jump.
297 Now the if statement. Almost *all* flow of control are of this form.
299 if (am==lit) { absC } else { absCdef }
313 gencode (CSwitch discrim alts deflt)
317 [(tag,alt_code)] -> case maybe_empty_deflt of
318 Nothing -> gencode alt_code
319 Just dc -> mkIfThenElse discrim tag alt_code dc
321 [(tag1@(MachInt i1 _), alt_code1),
322 (tag2@(MachInt i2 _), alt_code2)]
323 | deflt_is_empty && i1 == 0 && i2 == 1
324 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
325 | deflt_is_empty && i1 == 1 && i2 == 0
326 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
328 -- If the @discrim@ is simple, then this unfolding is safe.
329 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
331 -- Otherwise, we need to do a bit of work.
332 other -> getUnique `thenUs` \ u ->
334 (CAssign (CTemp u pk) discrim)
335 (CSwitch (CTemp u pk) alts deflt))
338 maybe_empty_deflt = nonemptyAbsC deflt
339 deflt_is_empty = case maybe_empty_deflt of
343 pk = getAmodeRep discrim
345 simple_discrim = case discrim of
353 Finally, all of the disgusting AbstractC macros.
357 gencode (CMacroStmt macro args) = macro_code macro args
359 gencode (CCallProfCtrMacro macro _) =
360 returnUs (\xs -> StComment macro : xs)
362 gencode (CCallProfCCMacro macro _) =
363 returnUs (\xs -> StComment macro : xs)
367 Here, we generate a jump table if there are more than four (integer) alternatives and
368 the jump table occupancy is greater than 50%. Otherwise, we generate a binary
369 comparison tree. (Perhaps this could be tuned.)
373 intTag :: Literal -> Integer
374 intTag (MachChar c) = toInteger (ord c)
375 intTag (MachInt i _) = i
376 intTag _ = panic "intTag"
378 fltTag :: Literal -> Rational
380 fltTag (MachFloat f) = f
381 fltTag (MachDouble d) = d
382 fltTag _ = panic "fltTag"
387 -> CAddrMode -> [(Literal,AbstractC)] -> AbstractC
388 -> UniqSM StixTreeList
390 mkSimpleSwitches am alts absC =
391 getUniqLabelNCG `thenUs` \ udlbl ->
392 getUniqLabelNCG `thenUs` \ ujlbl ->
394 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
395 sortedAlts = naturalMergeSortLe leAlt joinedAlts
396 -- naturalMergeSortLe, because we often get sorted alts to begin with
398 lowTag = intTag (fst (head sortedAlts))
399 highTag = intTag (fst (last sortedAlts))
401 -- lowest and highest possible values the discriminant could take
402 lowest = if floating then targetMinDouble else targetMinInt
403 highest = if floating then targetMaxDouble else targetMaxInt
405 -- These should come from somewhere else, depending on the target arch
406 -- (Note that the floating point values aren't terribly important.)
408 targetMinDouble = MachDouble (-1.7976931348623157e+308)
409 targetMaxDouble = MachDouble (1.7976931348623157e+308)
410 targetMinInt = mkMachInt (-2147483647)
411 targetMaxInt = mkMachInt 2147483647
414 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
415 mkJumpTable am' sortedAlts lowTag highTag udlbl
417 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
419 `thenUs` \ alt_code ->
420 gencode absC `thenUs` \ dflt_code ->
422 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
425 floating = isFloatingRep (getAmodeRep am)
426 choices = length alts
428 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
429 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
430 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
434 We use jump tables when doing an integer switch on a relatively dense list of
435 alternatives. We expect to be given a list of alternatives, sorted by tag,
436 and a range of values for which we are to generate a table. Of course, the tags of
437 the alternatives should lie within the indicated range. The alternatives need
438 not cover the range; a default target is provided for the missing alternatives.
440 If a join is necessary after the switch, the alternatives should already finish
441 with a jump to the join point.
447 -> StixTree -- discriminant
448 -> [(Literal, AbstractC)] -- alternatives
449 -> Integer -- low tag
450 -> Integer -- high tag
451 -> CLabel -- default label
452 -> UniqSM StixTreeList
455 mkJumpTable am alts lowTag highTag dflt =
456 getUniqLabelNCG `thenUs` \ utlbl ->
457 mapUs genLabel alts `thenUs` \ branches ->
458 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
459 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
461 offset = StPrim IntSubOp [am, StInt lowTag]
462 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
465 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
467 mapUs mkBranch branches `thenUs` \ alts ->
469 returnUs (\xs -> cjmpLo : cjmpHi : jump :
470 StSegment DataSegment : tlbl : table :
471 StSegment TextSegment : foldr1 (.) alts xs)
474 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
476 mkBranch (lbl,(_,alt)) =
477 gencode alt `thenUs` \ alt_code ->
478 returnUs (\xs -> StLabel lbl : alt_code xs)
480 mkTable _ [] tbl = reverse tbl
481 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
482 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
483 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
484 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
488 We generate binary comparison trees when a jump table is inappropriate.
489 We expect to be given a list of alternatives, sorted by tag, and for
490 convenience, the length of the alternative list. We recursively break
491 the list in half and do a comparison on the first tag of the second half
492 of the list. (Odd lists are broken so that the second half of the list
493 is longer.) We can handle either integer or floating kind alternatives,
494 so long as they are not mixed. (We assume that the type of the discriminant
495 determines the type of the alternatives.)
497 As with the jump table approach, if a join is necessary after the switch, the
498 alternatives should already finish with a jump to the join point.
504 -> StixTree -- discriminant
505 -> Bool -- floating point?
506 -> [(Literal, AbstractC)] -- alternatives
507 -> Int -- number of choices
508 -> Literal -- low tag
509 -> Literal -- high tag
510 -> CLabel -- default code label
511 -> UniqSM StixTreeList
514 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
515 | rangeOfOne = gencode alt
517 let tag' = a2stix (CLit tag)
518 cmpOp = if floating then DoubleNeOp else IntNeOp
519 test = StPrim cmpOp [am, tag']
520 cjmp = StCondJump udlbl test
522 gencode alt `thenUs` \ alt_code ->
523 returnUs (\xs -> cjmp : alt_code xs)
526 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
527 -- When there is only one possible tag left in range, we skip the comparison
529 mkBinaryTree am floating alts choices lowTag highTag udlbl =
530 getUniqLabelNCG `thenUs` \ uhlbl ->
531 let tag' = a2stix (CLit splitTag)
532 cmpOp = if floating then DoubleGeOp else IntGeOp
533 test = StPrim cmpOp [am, tag']
534 cjmp = StCondJump uhlbl test
536 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
537 `thenUs` \ lo_code ->
538 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
539 `thenUs` \ hi_code ->
541 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
544 half = choices `div` 2
545 (alts_lo, alts_hi) = splitAt half alts
546 splitTag = fst (head alts_hi)
554 -> CAddrMode -- discriminant
556 -> AbstractC -- if-part
557 -> AbstractC -- else-part
558 -> UniqSM StixTreeList
561 mkIfThenElse discrim tag alt deflt =
562 getUniqLabelNCG `thenUs` \ ujlbl ->
563 getUniqLabelNCG `thenUs` \ utlbl ->
564 let discrim' = a2stix discrim
565 tag' = a2stix (CLit tag)
566 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
567 test = StPrim cmpOp [discrim', tag']
568 cjmp = StCondJump utlbl test
572 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
573 gencode deflt `thenUs` \ dflt_code ->
574 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
576 mkJoin :: AbstractC -> CLabel -> AbstractC
579 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
583 %---------------------------------------------------------------------------
585 This answers the question: Can the code fall through to the next
586 line(s) of code? This errs towards saying True if it can't choose,
587 because it is used for eliminating needless jumps. In other words, if
588 you might possibly {\em not} jump, then say yes to falling through.
591 mightFallThrough :: AbstractC -> Bool
593 mightFallThrough absC = ft absC True
595 ft AbsCNop if_empty = if_empty
597 ft (CJump _) if_empty = False
598 ft (CReturn _ _) if_empty = False
599 ft (CSwitch _ alts deflt) if_empty
600 = ft deflt if_empty ||
601 or [ft alt if_empty | (_,alt) <- alts]
603 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
604 ft _ if_empty = if_empty
606 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
607 fallThroughAbsC (AbsCStmts c1 c2) =
608 case nonemptyAbsC c2 of
609 Nothing -> fallThroughAbsC c1
610 Just x -> fallThroughAbsC x
611 fallThroughAbsC (CJump _) = False
612 fallThroughAbsC (CReturn _ _) = False
613 fallThroughAbsC (CSwitch _ choices deflt)
614 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
615 || or (map (fallThroughAbsC . snd) choices)
616 fallThroughAbsC other = True
618 isEmptyAbsC :: AbstractC -> Bool
619 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
620 ================= End of old, quadratic, algorithm -}