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 CLabel ( CLabel )
24 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
25 fastLabelFromCI, closureUpdReqd
27 import HeapOffs ( hpRelToInt )
28 import Literal ( Literal(..) )
29 import Maybes ( maybeToBool )
30 import OrdList ( OrdList )
31 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
32 import PrimRep ( isFloatingRep, PrimRep(..) )
33 import StixInfo ( genCodeInfoTable )
34 import StixMacro ( macroCode )
35 import StixPrim ( primCode, amodeToStix, amodeToStix' )
36 import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
37 import Util ( naturalMergeSortLe, panic )
39 #ifdef REALLY_HASKELL_1_3
40 ord = fromEnum :: Char -> Int
44 For each independent chunk of AbstractC code, we generate a list of
45 @StixTree@s, where each tree corresponds to a single Stix instruction.
46 We leave the chunks separated so that register allocation can be
47 performed locally within the chunk.
50 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
53 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
54 returnUs ([StComment SLIT("Native Code")] : trees)
57 a2stix' = amodeToStix'
58 volsaves = volatileSaves
59 volrestores = volatileRestores
61 macro_code = macroCode
63 -- real code follows... ---------
66 Here we handle top-level things, like @CCodeBlock@s and
76 gentopcode (CCodeBlock label absC)
77 = gencode absC `thenUs` \ code ->
78 returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
80 gentopcode stmt@(CStaticClosure label _ _ _)
81 = genCodeStaticClosure stmt `thenUs` \ code ->
82 returnUs (StSegment DataSegment : StLabel label : code [])
84 gentopcode stmt@(CRetUnVector _ _) = returnUs []
86 gentopcode stmt@(CFlatRetVector label _)
87 = genCodeVecTbl stmt `thenUs` \ code ->
88 returnUs (StSegment TextSegment : code [StLabel label])
90 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
93 = genCodeInfoTable stmt `thenUs` \ itbl ->
94 returnUs (StSegment TextSegment : itbl [])
97 = genCodeInfoTable stmt `thenUs` \ itbl ->
98 gencode slow `thenUs` \ slow_code ->
99 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
100 slow_code [StFunEnd slow_lbl]))
102 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
103 slow_lbl = entryLabelFromCI cl_info
105 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
106 -- ToDo: what if this is empty? ------------------------^^^^
107 genCodeInfoTable stmt `thenUs` \ itbl ->
108 gencode slow `thenUs` \ slow_code ->
109 gencode fast `thenUs` \ fast_code ->
110 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
111 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
112 fast_code [StFunEnd fast_lbl])))
114 slow_lbl = entryLabelFromCI cl_info
115 fast_lbl = fastLabelFromCI cl_info
118 = gencode absC `thenUs` \ code ->
119 returnUs (StSegment TextSegment : code [])
123 Vector tables are trivial!
129 -> UniqSM StixTreeList
131 genCodeVecTbl (CFlatRetVector label amodes)
132 = returnUs (\xs -> vectbl : xs)
134 vectbl = StData PtrRep (reverse (map a2stix amodes))
138 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.
174 -> UniqSM StixTreeList
178 @AbsCNop@s just disappear.
182 gencode AbsCNop = returnUs id
186 Split markers are a NOP in this land.
190 gencode CSplitMarker = returnUs id
194 AbstractC instruction sequences are handled individually, and the
195 resulting StixTreeLists are joined together.
199 gencode (AbsCStmts c1 c2)
200 = gencode c1 `thenUs` \ b1 ->
201 gencode c2 `thenUs` \ b2 ->
206 Initialising closure headers in the heap...a fairly complex ordeal if
207 done properly. For now, we just set the info pointer, but we should
208 really take a peek at the flags to determine whether or not there are
209 other things to be done (setting cost centres, age headers, global
214 gencode (CInitHdr cl_info reg_rel _ _)
216 lhs = a2stix (CVal reg_rel PtrRep)
217 lbl = infoTableLabelFromCI cl_info
219 returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
223 Assignment, the curse of von Neumann, is the center of the code we
224 produce. In most cases, the type of the assignment is determined
225 by the type of the destination. However, when the destination can
226 have mixed types, the type of the assignment is ``StgWord'' (we use
227 PtrRep for lack of anything better). Think: do we also want a cast
228 of the source? Be careful about floats/doubles.
232 gencode (CAssign lhs rhs)
233 | getAmodeRep lhs == VoidRep = returnUs id
235 = let pk = getAmodeRep lhs
236 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
240 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
244 Unconditional jumps, including the special ``enter closure'' operation.
245 Note that the new entry convention requires that we load the InfoPtr (R2)
246 with the address of the info table before jumping to the entry code for Node.
251 = returnUs (\xs -> StJump (a2stix dest) : xs)
253 gencode (CFallThrough (CLbl lbl _))
254 = returnUs (\xs -> StFallThrough lbl : xs)
256 gencode (CReturn dest DirectReturn)
257 = returnUs (\xs -> StJump (a2stix dest) : xs)
259 gencode (CReturn table (StaticVectoredReturn n))
260 = returnUs (\xs -> StJump dest : xs)
262 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
263 (StInt (toInteger (-n-1))))
265 gencode (CReturn table (DynamicVectoredReturn am))
266 = returnUs (\xs -> StJump dest : xs)
268 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
269 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
273 Now the PrimOps, some of which may need caller-saves register wrappers.
277 gencode (COpStmt results op args liveness_mask vols)
278 -- ToDo (ADR?): use that liveness mask
279 | primOpNeedsWrapper op
281 saves = volsaves vols
282 restores = volrestores vols
284 p2stix (nonVoid results) op (nonVoid args)
286 returnUs (\xs -> saves ++ code (restores ++ xs))
288 | otherwise = p2stix (nonVoid results) op (nonVoid args)
290 nonVoid = filter ((/= VoidRep) . getAmodeRep)
294 Now the dreaded conditional jump.
296 Now the if statement. Almost *all* flow of control are of this form.
298 if (am==lit) { absC } else { absCdef }
312 gencode (CSwitch discrim alts deflt)
316 [(tag,alt_code)] -> case maybe_empty_deflt of
317 Nothing -> gencode alt_code
318 Just dc -> mkIfThenElse discrim tag alt_code dc
320 [(tag1@(MachInt i1 _), alt_code1),
321 (tag2@(MachInt i2 _), alt_code2)]
322 | deflt_is_empty && i1 == 0 && i2 == 1
323 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
324 | deflt_is_empty && i1 == 1 && i2 == 0
325 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
327 -- If the @discrim@ is simple, then this unfolding is safe.
328 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
330 -- Otherwise, we need to do a bit of work.
331 other -> getUnique `thenUs` \ u ->
333 (CAssign (CTemp u pk) discrim)
334 (CSwitch (CTemp u pk) alts deflt))
337 maybe_empty_deflt = nonemptyAbsC deflt
338 deflt_is_empty = case maybe_empty_deflt of
342 pk = getAmodeRep discrim
344 simple_discrim = case discrim of
352 Finally, all of the disgusting AbstractC macros.
356 gencode (CMacroStmt macro args) = macro_code macro args
358 gencode (CCallProfCtrMacro macro _)
359 = returnUs (\xs -> StComment macro : xs)
361 gencode (CCallProfCCMacro macro _)
362 = returnUs (\xs -> StComment macro : xs)
366 Here, we generate a jump table if there are more than four (integer) alternatives and
367 the jump table occupancy is greater than 50%. Otherwise, we generate a binary
368 comparison tree. (Perhaps this could be tuned.)
372 intTag :: Literal -> Integer
373 intTag (MachChar c) = toInteger (ord c)
374 intTag (MachInt i _) = i
375 intTag _ = panic "intTag"
377 fltTag :: Literal -> Rational
379 fltTag (MachFloat f) = f
380 fltTag (MachDouble d) = d
381 fltTag _ = panic "fltTag"
385 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
386 -> UniqSM StixTreeList
388 mkSimpleSwitches am alts absC
389 = getUniqLabelNCG `thenUs` \ udlbl ->
390 getUniqLabelNCG `thenUs` \ ujlbl ->
392 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
393 sortedAlts = naturalMergeSortLe leAlt joinedAlts
394 -- naturalMergeSortLe, because we often get sorted alts to begin with
396 lowTag = intTag (fst (head sortedAlts))
397 highTag = intTag (fst (last sortedAlts))
399 -- lowest and highest possible values the discriminant could take
400 lowest = if floating then targetMinDouble else targetMinInt
401 highest = if floating then targetMaxDouble else targetMaxInt
404 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
405 mkJumpTable am' sortedAlts lowTag highTag udlbl
407 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
409 `thenUs` \ alt_code ->
410 gencode absC `thenUs` \ dflt_code ->
412 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
415 floating = isFloatingRep (getAmodeRep am)
416 choices = length alts
418 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
419 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
420 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
424 We use jump tables when doing an integer switch on a relatively dense
425 list of alternatives. We expect to be given a list of alternatives,
426 sorted by tag, and a range of values for which we are to generate a
427 table. Of course, the tags of the alternatives should lie within the
428 indicated range. The alternatives need not cover the range; a default
429 target is provided for the missing alternatives.
431 If a join is necessary after the switch, the alternatives should
432 already finish with a jump to the join point.
437 :: StixTree -- discriminant
438 -> [(Literal, AbstractC)] -- alternatives
439 -> Integer -- low tag
440 -> Integer -- high tag
441 -> CLabel -- default label
442 -> UniqSM StixTreeList
445 mkJumpTable am alts lowTag highTag dflt
446 = getUniqLabelNCG `thenUs` \ utlbl ->
447 mapUs genLabel alts `thenUs` \ branches ->
448 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
449 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
451 offset = StPrim IntSubOp [am, StInt lowTag]
453 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
455 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
457 mapUs mkBranch branches `thenUs` \ alts ->
459 returnUs (\xs -> cjmpLo : cjmpHi : jump :
460 StSegment DataSegment : tlbl : table :
461 StSegment TextSegment : foldr1 (.) alts xs)
464 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
466 mkBranch (lbl,(_,alt)) =
467 gencode alt `thenUs` \ alt_code ->
468 returnUs (\xs -> StLabel lbl : alt_code xs)
470 mkTable _ [] tbl = reverse tbl
471 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
472 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
473 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
474 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
478 We generate binary comparison trees when a jump table is inappropriate.
479 We expect to be given a list of alternatives, sorted by tag, and for
480 convenience, the length of the alternative list. We recursively break
481 the list in half and do a comparison on the first tag of the second half
482 of the list. (Odd lists are broken so that the second half of the list
483 is longer.) We can handle either integer or floating kind alternatives,
484 so long as they are not mixed. (We assume that the type of the discriminant
485 determines the type of the alternatives.)
487 As with the jump table approach, if a join is necessary after the switch, the
488 alternatives should already finish with a jump to the join point.
493 :: StixTree -- discriminant
494 -> Bool -- floating point?
495 -> [(Literal, AbstractC)] -- alternatives
496 -> Int -- number of choices
497 -> Literal -- low tag
498 -> Literal -- high tag
499 -> CLabel -- default code label
500 -> UniqSM StixTreeList
503 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
504 | rangeOfOne = gencode alt
506 = let tag' = a2stix (CLit tag)
507 cmpOp = if floating then DoubleNeOp else IntNeOp
508 test = StPrim cmpOp [am, tag']
509 cjmp = StCondJump udlbl test
511 gencode alt `thenUs` \ alt_code ->
512 returnUs (\xs -> cjmp : alt_code xs)
515 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
516 -- When there is only one possible tag left in range, we skip the comparison
518 mkBinaryTree am floating alts choices lowTag highTag udlbl
519 = getUniqLabelNCG `thenUs` \ uhlbl ->
520 let tag' = a2stix (CLit splitTag)
521 cmpOp = if floating then DoubleGeOp else IntGeOp
522 test = StPrim cmpOp [am, tag']
523 cjmp = StCondJump uhlbl test
525 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
526 `thenUs` \ lo_code ->
527 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
528 `thenUs` \ hi_code ->
530 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
533 half = choices `div` 2
534 (alts_lo, alts_hi) = splitAt half alts
535 splitTag = fst (head alts_hi)
542 :: CAddrMode -- discriminant
544 -> AbstractC -- if-part
545 -> AbstractC -- else-part
546 -> UniqSM StixTreeList
549 mkIfThenElse discrim tag alt deflt
550 = getUniqLabelNCG `thenUs` \ ujlbl ->
551 getUniqLabelNCG `thenUs` \ utlbl ->
552 let discrim' = a2stix discrim
553 tag' = a2stix (CLit tag)
554 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
555 test = StPrim cmpOp [discrim', tag']
556 cjmp = StCondJump utlbl test
560 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
561 gencode deflt `thenUs` \ dflt_code ->
562 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
564 mkJoin :: AbstractC -> CLabel -> AbstractC
567 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
571 %---------------------------------------------------------------------------
573 This answers the question: Can the code fall through to the next
574 line(s) of code? This errs towards saying True if it can't choose,
575 because it is used for eliminating needless jumps. In other words, if
576 you might possibly {\em not} jump, then say yes to falling through.
579 mightFallThrough :: AbstractC -> Bool
581 mightFallThrough absC = ft absC True
583 ft AbsCNop if_empty = if_empty
585 ft (CJump _) if_empty = False
586 ft (CReturn _ _) if_empty = False
587 ft (CSwitch _ alts deflt) if_empty
588 = ft deflt if_empty ||
589 or [ft alt if_empty | (_,alt) <- alts]
591 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
592 ft _ if_empty = if_empty
594 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
595 fallThroughAbsC (AbsCStmts c1 c2)
596 = case nonemptyAbsC c2 of
597 Nothing -> fallThroughAbsC c1
598 Just x -> fallThroughAbsC x
599 fallThroughAbsC (CJump _) = False
600 fallThroughAbsC (CReturn _ _) = False
601 fallThroughAbsC (CSwitch _ choices deflt)
602 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
603 || or (map (fallThroughAbsC . snd) choices)
604 fallThroughAbsC other = True
606 isEmptyAbsC :: AbstractC -> Bool
607 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
608 ================= End of old, quadratic, algorithm -}