2 % (c) The AQUA Project, Glasgow University, 1993-1996
6 #include "HsVersions.h"
8 module AbsCStixGen ( genCodeAbstractC ) where
11 IMPORT_1_3(Ratio(Rational))
19 import AbsCUtils ( getAmodeRep, mixedTypeLocn,
20 nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
22 import Constants ( mIN_UPD_SIZE )
23 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
24 fastLabelFromCI, closureUpdReqd
26 import HeapOffs ( hpRelToInt )
27 import Literal ( Literal(..) )
28 import Maybes ( maybeToBool )
29 import OrdList ( OrdList )
30 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
31 import PrimRep ( isFloatingRep, PrimRep(..) )
32 import StixInfo ( genCodeInfoTable )
33 import StixMacro ( macroCode )
34 import StixPrim ( primCode, amodeToStix, amodeToStix' )
35 import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
36 import Util ( naturalMergeSortLe, panic )
38 #ifdef REALLY_HASKELL_1_3
39 ord = fromEnum :: Char -> Int
43 For each independent chunk of AbstractC code, we generate a list of
44 @StixTree@s, where each tree corresponds to a single Stix instruction.
45 We leave the chunks separated so that register allocation can be
46 performed locally within the chunk.
49 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
52 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
53 returnUs ([StComment SLIT("Native Code")] : trees)
56 a2stix' = amodeToStix'
57 volsaves = volatileSaves
58 volrestores = volatileRestores
60 macro_code = macroCode
62 -- real code follows... ---------
65 Here we handle top-level things, like @CCodeBlock@s and
75 gentopcode (CCodeBlock label absC)
76 = gencode absC `thenUs` \ code ->
77 returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
79 gentopcode stmt@(CStaticClosure label _ _ _)
80 = genCodeStaticClosure stmt `thenUs` \ code ->
81 returnUs (StSegment DataSegment : StLabel label : code [])
83 gentopcode stmt@(CRetUnVector _ _) = returnUs []
85 gentopcode stmt@(CFlatRetVector label _)
86 = genCodeVecTbl stmt `thenUs` \ code ->
87 returnUs (StSegment TextSegment : code [StLabel label])
89 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
92 = genCodeInfoTable stmt `thenUs` \ itbl ->
93 returnUs (StSegment TextSegment : itbl [])
96 = genCodeInfoTable stmt `thenUs` \ itbl ->
97 gencode slow `thenUs` \ slow_code ->
98 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
99 slow_code [StFunEnd slow_lbl]))
101 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
102 slow_lbl = entryLabelFromCI cl_info
104 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
105 -- ToDo: what if this is empty? ------------------------^^^^
106 genCodeInfoTable stmt `thenUs` \ itbl ->
107 gencode slow `thenUs` \ slow_code ->
108 gencode fast `thenUs` \ fast_code ->
109 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
110 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
111 fast_code [StFunEnd fast_lbl])))
113 slow_lbl = entryLabelFromCI cl_info
114 fast_lbl = fastLabelFromCI cl_info
117 = gencode absC `thenUs` \ code ->
118 returnUs (StSegment TextSegment : code [])
122 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.
143 -> UniqSM StixTreeList
145 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
146 = returnUs (\xs -> table : xs)
148 table = StData PtrRep (StCLbl info_lbl : body)
149 info_lbl = infoTableLabelFromCI cl_info
151 body = if closureUpdReqd cl_info then
152 take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
156 zeros = StInt 0 : zeros
158 amodes' = map amodeZeroVoid amodes
160 -- Watch out for VoidKinds...cf. PprAbsC
162 | getAmodeRep item == VoidRep = StInt 0
163 | otherwise = a2stix item
167 Now the individual AbstractC statements.
173 -> UniqSM StixTreeList
177 @AbsCNop@s just disappear.
181 gencode AbsCNop = returnUs id
185 Split markers are a NOP in this land.
189 gencode CSplitMarker = returnUs id
193 AbstractC instruction sequences are handled individually, and the
194 resulting StixTreeLists are joined together.
198 gencode (AbsCStmts c1 c2)
199 = gencode c1 `thenUs` \ b1 ->
200 gencode c2 `thenUs` \ b2 ->
205 Initialising closure headers in the heap...a fairly complex ordeal if
206 done properly. For now, we just set the info pointer, but we should
207 really take a peek at the flags to determine whether or not there are
208 other things to be done (setting cost centres, age headers, global
213 gencode (CInitHdr cl_info reg_rel _ _)
215 lhs = a2stix (CVal reg_rel PtrRep)
216 lbl = infoTableLabelFromCI cl_info
218 returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
222 Assignment, the curse of von Neumann, is the center of the code we
223 produce. In most cases, the type of the assignment is determined
224 by the type of the destination. However, when the destination can
225 have mixed types, the type of the assignment is ``StgWord'' (we use
226 PtrRep for lack of anything better). Think: do we also want a cast
227 of the source? Be careful about floats/doubles.
231 gencode (CAssign lhs rhs)
232 | getAmodeRep lhs == VoidRep = returnUs id
234 = let pk = getAmodeRep lhs
235 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
239 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
243 Unconditional jumps, including the special ``enter closure'' operation.
244 Note that the new entry convention requires that we load the InfoPtr (R2)
245 with the address of the info table before jumping to the entry code for Node.
250 = returnUs (\xs -> StJump (a2stix dest) : xs)
252 gencode (CFallThrough (CLbl lbl _))
253 = returnUs (\xs -> StFallThrough lbl : xs)
255 gencode (CReturn dest DirectReturn)
256 = returnUs (\xs -> StJump (a2stix dest) : xs)
258 gencode (CReturn table (StaticVectoredReturn n))
259 = returnUs (\xs -> StJump dest : xs)
261 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
262 (StInt (toInteger (-n-1))))
264 gencode (CReturn table (DynamicVectoredReturn am))
265 = returnUs (\xs -> StJump dest : xs)
267 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
268 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
272 Now the PrimOps, some of which may need caller-saves register wrappers.
276 gencode (COpStmt results op args liveness_mask vols)
277 -- ToDo (ADR?): use that liveness mask
278 | primOpNeedsWrapper op
280 saves = volsaves vols
281 restores = volrestores vols
283 p2stix (nonVoid results) op (nonVoid args)
285 returnUs (\xs -> saves ++ code (restores ++ xs))
287 | otherwise = p2stix (nonVoid results) op (nonVoid args)
289 nonVoid = filter ((/= VoidRep) . getAmodeRep)
293 Now the dreaded conditional jump.
295 Now the if statement. Almost *all* flow of control are of this form.
297 if (am==lit) { absC } else { absCdef }
311 gencode (CSwitch discrim alts deflt)
315 [(tag,alt_code)] -> case maybe_empty_deflt of
316 Nothing -> gencode alt_code
317 Just dc -> mkIfThenElse discrim tag alt_code dc
319 [(tag1@(MachInt i1 _), alt_code1),
320 (tag2@(MachInt i2 _), alt_code2)]
321 | deflt_is_empty && i1 == 0 && i2 == 1
322 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
323 | deflt_is_empty && i1 == 1 && i2 == 0
324 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
326 -- If the @discrim@ is simple, then this unfolding is safe.
327 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
329 -- Otherwise, we need to do a bit of work.
330 other -> getUnique `thenUs` \ u ->
332 (CAssign (CTemp u pk) discrim)
333 (CSwitch (CTemp u pk) alts deflt))
336 maybe_empty_deflt = nonemptyAbsC deflt
337 deflt_is_empty = case maybe_empty_deflt of
341 pk = getAmodeRep discrim
343 simple_discrim = case discrim of
351 Finally, all of the disgusting AbstractC macros.
355 gencode (CMacroStmt macro args) = macro_code macro args
357 gencode (CCallProfCtrMacro macro _)
358 = returnUs (\xs -> StComment macro : xs)
360 gencode (CCallProfCCMacro macro _)
361 = returnUs (\xs -> StComment macro : xs)
365 Here, we generate a jump table if there are more than four (integer) alternatives and
366 the jump table occupancy is greater than 50%. Otherwise, we generate a binary
367 comparison tree. (Perhaps this could be tuned.)
371 intTag :: Literal -> Integer
372 intTag (MachChar c) = toInteger (ord c)
373 intTag (MachInt i _) = i
374 intTag _ = panic "intTag"
376 fltTag :: Literal -> Rational
378 fltTag (MachFloat f) = f
379 fltTag (MachDouble d) = d
380 fltTag _ = panic "fltTag"
384 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
385 -> UniqSM StixTreeList
387 mkSimpleSwitches am alts absC
388 = getUniqLabelNCG `thenUs` \ udlbl ->
389 getUniqLabelNCG `thenUs` \ ujlbl ->
391 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
392 sortedAlts = naturalMergeSortLe leAlt joinedAlts
393 -- naturalMergeSortLe, because we often get sorted alts to begin with
395 lowTag = intTag (fst (head sortedAlts))
396 highTag = intTag (fst (last sortedAlts))
398 -- lowest and highest possible values the discriminant could take
399 lowest = if floating then targetMinDouble else targetMinInt
400 highest = if floating then targetMaxDouble else targetMaxInt
403 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
404 mkJumpTable am' sortedAlts lowTag highTag udlbl
406 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
408 `thenUs` \ alt_code ->
409 gencode absC `thenUs` \ dflt_code ->
411 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
414 floating = isFloatingRep (getAmodeRep am)
415 choices = length alts
417 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
418 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
419 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
423 We use jump tables when doing an integer switch on a relatively dense
424 list of alternatives. We expect to be given a list of alternatives,
425 sorted by tag, and a range of values for which we are to generate a
426 table. Of course, the tags of the alternatives should lie within the
427 indicated range. The alternatives need not cover the range; a default
428 target is provided for the missing alternatives.
430 If a join is necessary after the switch, the alternatives should
431 already finish with a jump to the join point.
436 :: StixTree -- discriminant
437 -> [(Literal, AbstractC)] -- alternatives
438 -> Integer -- low tag
439 -> Integer -- high tag
440 -> CLabel -- default label
441 -> UniqSM StixTreeList
444 mkJumpTable am alts lowTag highTag dflt
445 = getUniqLabelNCG `thenUs` \ utlbl ->
446 mapUs genLabel alts `thenUs` \ branches ->
447 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
448 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
450 offset = StPrim IntSubOp [am, StInt lowTag]
451 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
454 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
456 mapUs mkBranch branches `thenUs` \ alts ->
458 returnUs (\xs -> cjmpLo : cjmpHi : jump :
459 StSegment DataSegment : tlbl : table :
460 StSegment TextSegment : foldr1 (.) alts xs)
463 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
465 mkBranch (lbl,(_,alt)) =
466 gencode alt `thenUs` \ alt_code ->
467 returnUs (\xs -> StLabel lbl : alt_code xs)
469 mkTable _ [] tbl = reverse tbl
470 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
471 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
472 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
473 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
477 We generate binary comparison trees when a jump table is inappropriate.
478 We expect to be given a list of alternatives, sorted by tag, and for
479 convenience, the length of the alternative list. We recursively break
480 the list in half and do a comparison on the first tag of the second half
481 of the list. (Odd lists are broken so that the second half of the list
482 is longer.) We can handle either integer or floating kind alternatives,
483 so long as they are not mixed. (We assume that the type of the discriminant
484 determines the type of the alternatives.)
486 As with the jump table approach, if a join is necessary after the switch, the
487 alternatives should already finish with a jump to the join point.
492 :: StixTree -- discriminant
493 -> Bool -- floating point?
494 -> [(Literal, AbstractC)] -- alternatives
495 -> Int -- number of choices
496 -> Literal -- low tag
497 -> Literal -- high tag
498 -> CLabel -- default code label
499 -> UniqSM StixTreeList
502 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
503 | rangeOfOne = gencode alt
505 = let tag' = a2stix (CLit tag)
506 cmpOp = if floating then DoubleNeOp else IntNeOp
507 test = StPrim cmpOp [am, tag']
508 cjmp = StCondJump udlbl test
510 gencode alt `thenUs` \ alt_code ->
511 returnUs (\xs -> cjmp : alt_code xs)
514 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
515 -- When there is only one possible tag left in range, we skip the comparison
517 mkBinaryTree am floating alts choices lowTag highTag udlbl
518 = getUniqLabelNCG `thenUs` \ uhlbl ->
519 let tag' = a2stix (CLit splitTag)
520 cmpOp = if floating then DoubleGeOp else IntGeOp
521 test = StPrim cmpOp [am, tag']
522 cjmp = StCondJump uhlbl test
524 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
525 `thenUs` \ lo_code ->
526 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
527 `thenUs` \ hi_code ->
529 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
532 half = choices `div` 2
533 (alts_lo, alts_hi) = splitAt half alts
534 splitTag = fst (head alts_hi)
541 :: CAddrMode -- discriminant
543 -> AbstractC -- if-part
544 -> AbstractC -- else-part
545 -> UniqSM StixTreeList
548 mkIfThenElse discrim tag alt deflt
549 = getUniqLabelNCG `thenUs` \ ujlbl ->
550 getUniqLabelNCG `thenUs` \ utlbl ->
551 let discrim' = a2stix discrim
552 tag' = a2stix (CLit tag)
553 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
554 test = StPrim cmpOp [discrim', tag']
555 cjmp = StCondJump utlbl test
559 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
560 gencode deflt `thenUs` \ dflt_code ->
561 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
563 mkJoin :: AbstractC -> CLabel -> AbstractC
566 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
570 %---------------------------------------------------------------------------
572 This answers the question: Can the code fall through to the next
573 line(s) of code? This errs towards saying True if it can't choose,
574 because it is used for eliminating needless jumps. In other words, if
575 you might possibly {\em not} jump, then say yes to falling through.
578 mightFallThrough :: AbstractC -> Bool
580 mightFallThrough absC = ft absC True
582 ft AbsCNop if_empty = if_empty
584 ft (CJump _) if_empty = False
585 ft (CReturn _ _) if_empty = False
586 ft (CSwitch _ alts deflt) if_empty
587 = ft deflt if_empty ||
588 or [ft alt if_empty | (_,alt) <- alts]
590 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
591 ft _ if_empty = if_empty
593 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
594 fallThroughAbsC (AbsCStmts c1 c2)
595 = case nonemptyAbsC c2 of
596 Nothing -> fallThroughAbsC c1
597 Just x -> fallThroughAbsC x
598 fallThroughAbsC (CJump _) = False
599 fallThroughAbsC (CReturn _ _) = False
600 fallThroughAbsC (CSwitch _ choices deflt)
601 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
602 || or (map (fallThroughAbsC . snd) choices)
603 fallThroughAbsC other = True
605 isEmptyAbsC :: AbstractC -> Bool
606 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
607 ================= End of old, quadratic, algorithm -}