2 % (c) The AQUA Project, Glasgow University, 1993-1998
6 module AbsCStixGen ( genCodeAbstractC ) where
8 #include "HsVersions.h"
10 import Ratio ( Rational )
16 import AbsCUtils ( getAmodeRep, mixedTypeLocn,
17 nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
19 import SMRep ( fixedItblSize,
21 rET_VEC_SMALL, rET_VEC_BIG
23 import Constants ( mIN_UPD_SIZE )
24 import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel )
25 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
26 fastLabelFromCI, closureUpdReqd,
27 staticClosureNeedsLink
29 import Const ( Literal(..) )
30 import Maybes ( maybeToBool )
31 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
32 import PrimRep ( isFloatingRep, PrimRep(..) )
33 import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
34 import StixMacro ( macroCode, checkCode )
35 import StixPrim ( primCode, amodeToStix, amodeToStix' )
36 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
37 import Util ( naturalMergeSortLe )
38 import Panic ( panic )
39 import BitSet ( intBS )
41 #ifdef REALLY_HASKELL_1_3
42 ord = fromEnum :: Char -> Int
46 For each independent chunk of AbstractC code, we generate a list of
47 @StixTree@s, where each tree corresponds to a single Stix instruction.
48 We leave the chunks separated so that register allocation can be
49 performed locally within the chunk.
52 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
55 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
56 returnUs ([StComment SLIT("Native Code")] : trees)
59 a2stix' = amodeToStix'
60 volsaves = volatileSaves
61 volrestores = volatileRestores
63 macro_code = macroCode
64 -- real code follows... ---------
67 Here we handle top-level things, like @CCodeBlock@s and
77 gentopcode (CCodeBlock lbl absC)
78 = gencode absC `thenUs` \ code ->
79 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
81 gentopcode stmt@(CStaticClosure lbl _ _ _)
82 = genCodeStaticClosure stmt `thenUs` \ code ->
83 returnUs (StSegment DataSegment : StLabel lbl : code [])
85 gentopcode stmt@(CRetVector lbl _ _ _)
86 = genCodeVecTbl stmt `thenUs` \ code ->
87 returnUs (StSegment TextSegment : code [StLabel lbl])
89 gentopcode stmt@(CRetDirect uniq absC srt liveness)
90 = gencode absC `thenUs` \ code ->
91 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
92 returnUs (StSegment TextSegment :
93 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
95 lbl_info = mkReturnInfoLabel uniq
96 lbl_ret = mkReturnPtLabel uniq
97 closure_type = case liveness of
98 LvSmall _ -> rET_SMALL
101 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
104 = genCodeInfoTable stmt `thenUs` \ itbl ->
105 returnUs (StSegment TextSegment : itbl [])
108 = genCodeInfoTable stmt `thenUs` \ itbl ->
109 gencode slow `thenUs` \ slow_code ->
110 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
111 slow_code [StFunEnd slow_lbl]))
113 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
114 slow_lbl = entryLabelFromCI cl_info
116 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
117 -- ToDo: what if this is empty? ------------------------^^^^
118 genCodeInfoTable stmt `thenUs` \ itbl ->
119 gencode slow `thenUs` \ slow_code ->
120 gencode fast `thenUs` \ fast_code ->
121 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
122 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
123 fast_code [StFunEnd fast_lbl])))
125 slow_lbl = entryLabelFromCI cl_info
126 fast_lbl = fastLabelFromCI cl_info
128 gentopcode stmt@(CSRT lbl closures)
129 = returnUs [ StSegment TextSegment
131 , StData DataPtrRep (map StCLbl closures)
134 gentopcode stmt@(CBitmap lbl mask)
135 = returnUs [ StSegment TextSegment
137 , StData WordRep (StInt (toInteger (length mask)) :
138 map (StInt . toInteger . intBS) mask)
142 = gencode absC `thenUs` \ code ->
143 returnUs (StSegment TextSegment : code [])
151 -> UniqSM StixTreeList
153 genCodeVecTbl (CRetVector lbl amodes srt liveness)
154 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
155 returnUs (\xs -> vectbl : itbl xs)
157 vectbl = StData PtrRep (reverse (map a2stix amodes))
158 closure_type = case liveness of
159 LvSmall _ -> rET_VEC_SMALL
160 LvLarge _ -> rET_VEC_BIG
168 -> UniqSM StixTreeList
170 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
171 = returnUs (\xs -> table ++ xs)
173 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
174 map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
175 [StData PtrRep (padding_wds ++ static_link)]
177 -- always at least one padding word: this is the static link field
178 -- for the garbage collector.
179 padding_wds = if closureUpdReqd cl_info then
180 take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
184 static_link | staticClosureNeedsLink cl_info = [StInt 0]
187 zeros = StInt 0 : zeros
190 -- Watch out for VoidKinds...cf. PprAbsC
192 | getAmodeRep item == VoidRep = StInt 0
193 | otherwise = a2stix item
198 Now the individual AbstractC statements.
204 -> UniqSM StixTreeList
208 @AbsCNop@s just disappear.
212 gencode AbsCNop = returnUs id
216 Split markers are a NOP in this land.
220 gencode CSplitMarker = returnUs id
224 AbstractC instruction sequences are handled individually, and the
225 resulting StixTreeLists are joined together.
229 gencode (AbsCStmts c1 c2)
230 = gencode c1 `thenUs` \ b1 ->
231 gencode c2 `thenUs` \ b2 ->
236 Initialising closure headers in the heap...a fairly complex ordeal if
237 done properly. For now, we just set the info pointer, but we should
238 really take a peek at the flags to determine whether or not there are
239 other things to be done (setting cost centres, age headers, global
244 gencode (CInitHdr cl_info reg_rel _)
247 lbl = infoTableLabelFromCI cl_info
249 returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
257 gencode (CCheck macro args assts)
258 = gencode assts `thenUs` \assts_stix ->
259 checkCode macro args assts_stix
263 Assignment, the curse of von Neumann, is the center of the code we
264 produce. In most cases, the type of the assignment is determined
265 by the type of the destination. However, when the destination can
266 have mixed types, the type of the assignment is ``StgWord'' (we use
267 PtrRep for lack of anything better). Think: do we also want a cast
268 of the source? Be careful about floats/doubles.
272 gencode (CAssign lhs rhs)
273 | getAmodeRep lhs == VoidRep = returnUs id
275 = let pk = getAmodeRep lhs
276 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
280 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
284 Unconditional jumps, including the special ``enter closure'' operation.
285 Note that the new entry convention requires that we load the InfoPtr (R2)
286 with the address of the info table before jumping to the entry code for Node.
288 For a vectored return, we must subtract the size of the info table to
289 get at the return vector. This depends on the size of the info table,
290 which varies depending on whether we're profiling etc.
295 = returnUs (\xs -> StJump (a2stix dest) : xs)
297 gencode (CFallThrough (CLbl lbl _))
298 = returnUs (\xs -> StFallThrough lbl : xs)
300 gencode (CReturn dest DirectReturn)
301 = returnUs (\xs -> StJump (a2stix dest) : xs)
303 gencode (CReturn table (StaticVectoredReturn n))
304 = returnUs (\xs -> StJump dest : xs)
306 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
307 (StInt (toInteger (-n-fixedItblSize-1))))
309 gencode (CReturn table (DynamicVectoredReturn am))
310 = returnUs (\xs -> StJump dest : xs)
312 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
313 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
314 StInt (toInteger (fixedItblSize+1))]
318 Now the PrimOps, some of which may need caller-saves register wrappers.
322 gencode (COpStmt results op args vols)
323 -- ToDo (ADR?): use that liveness mask
324 | primOpNeedsWrapper op
326 saves = volsaves vols
327 restores = volrestores vols
329 p2stix (nonVoid results) op (nonVoid args)
331 returnUs (\xs -> saves ++ code (restores ++ xs))
333 | otherwise = p2stix (nonVoid results) op (nonVoid args)
335 nonVoid = filter ((/= VoidRep) . getAmodeRep)
339 Now the dreaded conditional jump.
341 Now the if statement. Almost *all* flow of control are of this form.
343 if (am==lit) { absC } else { absCdef }
357 gencode (CSwitch discrim alts deflt)
361 [(tag,alt_code)] -> case maybe_empty_deflt of
362 Nothing -> gencode alt_code
363 Just dc -> mkIfThenElse discrim tag alt_code dc
365 [(tag1@(MachInt i1 _), alt_code1),
366 (tag2@(MachInt i2 _), alt_code2)]
367 | deflt_is_empty && i1 == 0 && i2 == 1
368 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
369 | deflt_is_empty && i1 == 1 && i2 == 0
370 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
372 -- If the @discrim@ is simple, then this unfolding is safe.
373 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
375 -- Otherwise, we need to do a bit of work.
376 other -> getUniqueUs `thenUs` \ u ->
378 (CAssign (CTemp u pk) discrim)
379 (CSwitch (CTemp u pk) alts deflt))
382 maybe_empty_deflt = nonemptyAbsC deflt
383 deflt_is_empty = case maybe_empty_deflt of
387 pk = getAmodeRep discrim
389 simple_discrim = case discrim of
397 Finally, all of the disgusting AbstractC macros.
401 gencode (CMacroStmt macro args) = macro_code macro args
403 gencode (CCallProfCtrMacro macro _)
404 = returnUs (\xs -> StComment macro : xs)
406 gencode (CCallProfCCMacro macro _)
407 = returnUs (\xs -> StComment macro : xs)
411 Here, we generate a jump table if there are more than four (integer)
412 alternatives and the jump table occupancy is greater than 50%.
413 Otherwise, we generate a binary comparison tree. (Perhaps this could
418 intTag :: Literal -> Integer
419 intTag (MachChar c) = toInteger (ord c)
420 intTag (MachInt i _) = i
421 intTag _ = panic "intTag"
423 fltTag :: Literal -> Rational
425 fltTag (MachFloat f) = f
426 fltTag (MachDouble d) = d
427 fltTag _ = panic "fltTag"
431 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
432 -> UniqSM StixTreeList
434 mkSimpleSwitches am alts absC
435 = getUniqLabelNCG `thenUs` \ udlbl ->
436 getUniqLabelNCG `thenUs` \ ujlbl ->
438 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
439 sortedAlts = naturalMergeSortLe leAlt joinedAlts
440 -- naturalMergeSortLe, because we often get sorted alts to begin with
442 lowTag = intTag (fst (head sortedAlts))
443 highTag = intTag (fst (last sortedAlts))
445 -- lowest and highest possible values the discriminant could take
446 lowest = if floating then targetMinDouble else targetMinInt
447 highest = if floating then targetMaxDouble else targetMaxInt
450 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
451 mkJumpTable am' sortedAlts lowTag highTag udlbl
453 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
455 `thenUs` \ alt_code ->
456 gencode absC `thenUs` \ dflt_code ->
458 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
461 floating = isFloatingRep (getAmodeRep am)
462 choices = length alts
464 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
465 (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
466 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
470 We use jump tables when doing an integer switch on a relatively dense
471 list of alternatives. We expect to be given a list of alternatives,
472 sorted by tag, and a range of values for which we are to generate a
473 table. Of course, the tags of the alternatives should lie within the
474 indicated range. The alternatives need not cover the range; a default
475 target is provided for the missing alternatives.
477 If a join is necessary after the switch, the alternatives should
478 already finish with a jump to the join point.
483 :: StixTree -- discriminant
484 -> [(Literal, AbstractC)] -- alternatives
485 -> Integer -- low tag
486 -> Integer -- high tag
487 -> CLabel -- default label
488 -> UniqSM StixTreeList
491 mkJumpTable am alts lowTag highTag dflt
492 = getUniqLabelNCG `thenUs` \ utlbl ->
493 mapUs genLabel alts `thenUs` \ branches ->
494 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
495 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
497 offset = StPrim IntSubOp [am, StInt lowTag]
499 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
501 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
503 mapUs mkBranch branches `thenUs` \ alts ->
505 returnUs (\xs -> cjmpLo : cjmpHi : jump :
506 StSegment DataSegment : tlbl : table :
507 StSegment TextSegment : foldr1 (.) alts xs)
510 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
512 mkBranch (lbl,(_,alt)) =
513 gencode alt `thenUs` \ alt_code ->
514 returnUs (\xs -> StLabel lbl : alt_code xs)
516 mkTable _ [] tbl = reverse tbl
517 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
518 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
519 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
520 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
524 We generate binary comparison trees when a jump table is inappropriate.
525 We expect to be given a list of alternatives, sorted by tag, and for
526 convenience, the length of the alternative list. We recursively break
527 the list in half and do a comparison on the first tag of the second half
528 of the list. (Odd lists are broken so that the second half of the list
529 is longer.) We can handle either integer or floating kind alternatives,
530 so long as they are not mixed. (We assume that the type of the discriminant
531 determines the type of the alternatives.)
533 As with the jump table approach, if a join is necessary after the switch, the
534 alternatives should already finish with a jump to the join point.
539 :: StixTree -- discriminant
540 -> Bool -- floating point?
541 -> [(Literal, AbstractC)] -- alternatives
542 -> Int -- number of choices
543 -> Literal -- low tag
544 -> Literal -- high tag
545 -> CLabel -- default code label
546 -> UniqSM StixTreeList
549 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
550 | rangeOfOne = gencode alt
552 = let tag' = a2stix (CLit tag)
553 cmpOp = if floating then DoubleNeOp else IntNeOp
554 test = StPrim cmpOp [am, tag']
555 cjmp = StCondJump udlbl test
557 gencode alt `thenUs` \ alt_code ->
558 returnUs (\xs -> cjmp : alt_code xs)
561 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
562 -- When there is only one possible tag left in range, we skip the comparison
564 mkBinaryTree am floating alts choices lowTag highTag udlbl
565 = getUniqLabelNCG `thenUs` \ uhlbl ->
566 let tag' = a2stix (CLit splitTag)
567 cmpOp = if floating then DoubleGeOp else IntGeOp
568 test = StPrim cmpOp [am, tag']
569 cjmp = StCondJump uhlbl test
571 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
572 `thenUs` \ lo_code ->
573 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
574 `thenUs` \ hi_code ->
576 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
579 half = choices `div` 2
580 (alts_lo, alts_hi) = splitAt half alts
581 splitTag = fst (head alts_hi)
588 :: CAddrMode -- discriminant
590 -> AbstractC -- if-part
591 -> AbstractC -- else-part
592 -> UniqSM StixTreeList
595 mkIfThenElse discrim tag alt deflt
596 = getUniqLabelNCG `thenUs` \ ujlbl ->
597 getUniqLabelNCG `thenUs` \ utlbl ->
598 let discrim' = a2stix discrim
599 tag' = a2stix (CLit tag)
600 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
601 test = StPrim cmpOp [discrim', tag']
602 cjmp = StCondJump utlbl test
606 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
607 gencode deflt `thenUs` \ dflt_code ->
608 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
610 mkJoin :: AbstractC -> CLabel -> AbstractC
613 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
617 %---------------------------------------------------------------------------
619 This answers the question: Can the code fall through to the next
620 line(s) of code? This errs towards saying True if it can't choose,
621 because it is used for eliminating needless jumps. In other words, if
622 you might possibly {\em not} jump, then say yes to falling through.
625 mightFallThrough :: AbstractC -> Bool
627 mightFallThrough absC = ft absC True
629 ft AbsCNop if_empty = if_empty
631 ft (CJump _) if_empty = False
632 ft (CReturn _ _) if_empty = False
633 ft (CSwitch _ alts deflt) if_empty
634 = ft deflt if_empty ||
635 or [ft alt if_empty | (_,alt) <- alts]
637 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
638 ft _ if_empty = if_empty
640 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
641 fallThroughAbsC (AbsCStmts c1 c2)
642 = case nonemptyAbsC c2 of
643 Nothing -> fallThroughAbsC c1
644 Just x -> fallThroughAbsC x
645 fallThroughAbsC (CJump _) = False
646 fallThroughAbsC (CReturn _ _) = False
647 fallThroughAbsC (CSwitch _ choices deflt)
648 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
649 || or (map (fallThroughAbsC . snd) choices)
650 fallThroughAbsC other = True
652 isEmptyAbsC :: AbstractC -> Bool
653 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
654 ================= End of old, quadratic, algorithm -}