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 PprAbsC ( dumpRealC )
20 import SMRep ( fixedItblSize,
22 rET_VEC_SMALL, rET_VEC_BIG
24 import Constants ( mIN_UPD_SIZE )
25 import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
26 mkClosureTblLabel, mkClosureLabel,
28 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
29 fastLabelFromCI, closureUpdReqd,
30 staticClosureNeedsLink
32 import Literal ( Literal(..), word2IntLit )
33 import Maybes ( maybeToBool )
34 import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
35 import PrimRep ( isFloatingRep, PrimRep(..) )
36 import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
37 import StixMacro ( macroCode, checkCode )
38 import StixPrim ( primCode, amodeToStix, amodeToStix' )
39 import Outputable ( pprPanic, ppr )
40 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
41 import Util ( naturalMergeSortLe )
42 import Panic ( panic )
43 import TyCon ( tyConDataCons )
44 import DataCon ( dataConWrapId )
45 import BitSet ( intBS )
46 import Name ( NamedThing(..) )
48 #ifdef REALLY_HASKELL_1_3
49 ord = fromEnum :: Char -> Int
53 For each independent chunk of AbstractC code, we generate a list of
54 @StixTree@s, where each tree corresponds to a single Stix instruction.
55 We leave the chunks separated so that register allocation can be
56 performed locally within the chunk.
59 genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
62 = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
63 returnUs ([StComment SLIT("Native Code")] : trees)
66 a2stix' = amodeToStix'
67 volsaves = volatileSaves
68 volrestores = volatileRestores
70 macro_code = macroCode
71 -- real code follows... ---------
74 Here we handle top-level things, like @CCodeBlock@s and
84 gentopcode (CCodeBlock lbl absC)
85 = gencode absC `thenUs` \ code ->
86 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
88 gentopcode stmt@(CStaticClosure lbl _ _ _)
89 = genCodeStaticClosure stmt `thenUs` \ code ->
90 returnUs (StSegment DataSegment : StLabel lbl : code [])
92 gentopcode stmt@(CRetVector lbl _ _ _)
93 = genCodeVecTbl stmt `thenUs` \ code ->
94 returnUs (StSegment TextSegment : code [StLabel lbl])
96 gentopcode stmt@(CRetDirect uniq absC srt liveness)
97 = gencode absC `thenUs` \ code ->
98 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
99 returnUs (StSegment TextSegment :
100 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
102 lbl_info = mkReturnInfoLabel uniq
103 lbl_ret = mkReturnPtLabel uniq
104 closure_type = case liveness of
105 LvSmall _ -> rET_SMALL
108 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
111 = genCodeInfoTable stmt `thenUs` \ itbl ->
112 returnUs (StSegment TextSegment : itbl [])
115 = genCodeInfoTable stmt `thenUs` \ itbl ->
116 gencode slow `thenUs` \ slow_code ->
117 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
118 slow_code [StFunEnd slow_lbl]))
120 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
121 slow_lbl = entryLabelFromCI cl_info
123 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
124 -- ToDo: what if this is empty? ------------------------^^^^
125 genCodeInfoTable stmt `thenUs` \ itbl ->
126 gencode slow `thenUs` \ slow_code ->
127 gencode fast `thenUs` \ fast_code ->
128 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
129 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
130 fast_code [StFunEnd fast_lbl])))
132 slow_lbl = entryLabelFromCI cl_info
133 fast_lbl = fastLabelFromCI cl_info
135 gentopcode stmt@(CSRT lbl closures)
136 = returnUs [ StSegment TextSegment
138 , StData DataPtrRep (map StCLbl closures)
141 gentopcode stmt@(CBitmap lbl mask)
142 = returnUs [ StSegment TextSegment
144 , StData WordRep (StInt (toInteger (length mask)) :
145 map (StInt . toInteger . intBS) mask)
148 gentopcode stmt@(CClosureTbl tycon)
149 = returnUs [ StSegment TextSegment
150 , StLabel (mkClosureTblLabel tycon)
151 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
152 (tyConDataCons tycon) )
155 gentopcode stmt@(CModuleInitBlock lbl absC)
156 = gencode absC `thenUs` \ code ->
157 getUniqLabelNCG `thenUs` \ tmp_lbl ->
158 returnUs ( StSegment DataSegment
159 : StLabel moduleRegdLabel
160 : StData IntRep [StInt 0]
161 : StSegment TextSegment
163 : StCondJump tmp_lbl (StPrim IntNeOp [StCLbl moduleRegdLabel,
165 : StAssign IntRep (StInd IntRep (StCLbl moduleRegdLabel)) (StInt 1)
168 , StAssign PtrRep stgSp (StPrim IntSubOp [stgSp, StInt 4])
169 , StJump (StInd WordRep stgSp)
173 = gencode absC `thenUs` \ code ->
174 returnUs (StSegment TextSegment : code [])
181 -> UniqSM StixTreeList
183 genCodeVecTbl (CRetVector lbl amodes srt liveness)
184 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
185 returnUs (\xs -> vectbl : itbl xs)
187 vectbl = StData PtrRep (reverse (map a2stix amodes))
188 closure_type = case liveness of
189 LvSmall _ -> rET_VEC_SMALL
190 LvLarge _ -> rET_VEC_BIG
198 -> UniqSM StixTreeList
200 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
201 = returnUs (\xs -> table ++ xs)
203 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
204 map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++
205 [StData PtrRep (padding_wds ++ static_link)]
207 -- always at least one padding word: this is the static link field
208 -- for the garbage collector.
209 padding_wds = if closureUpdReqd cl_info then
210 take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
214 static_link | staticClosureNeedsLink cl_info = [StInt 0]
217 zeros = StInt 0 : zeros
220 -- Watch out for VoidKinds...cf. PprAbsC
222 | getAmodeRep item == VoidRep = StInt 0
223 | otherwise = a2stix item
228 Now the individual AbstractC statements.
234 -> UniqSM StixTreeList
238 @AbsCNop@s just disappear.
242 gencode AbsCNop = returnUs id
246 Split markers are a NOP in this land.
250 gencode CSplitMarker = returnUs id
254 AbstractC instruction sequences are handled individually, and the
255 resulting StixTreeLists are joined together.
259 gencode (AbsCStmts c1 c2)
260 = gencode c1 `thenUs` \ b1 ->
261 gencode c2 `thenUs` \ b2 ->
266 Initialising closure headers in the heap...a fairly complex ordeal if
267 done properly. For now, we just set the info pointer, but we should
268 really take a peek at the flags to determine whether or not there are
269 other things to be done (setting cost centres, age headers, global
274 gencode (CInitHdr cl_info reg_rel _)
277 lbl = infoTableLabelFromCI cl_info
279 returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
287 gencode (CCheck macro args assts)
288 = gencode assts `thenUs` \assts_stix ->
289 checkCode macro args assts_stix
293 Assignment, the curse of von Neumann, is the center of the code we
294 produce. In most cases, the type of the assignment is determined
295 by the type of the destination. However, when the destination can
296 have mixed types, the type of the assignment is ``StgWord'' (we use
297 PtrRep for lack of anything better). Think: do we also want a cast
298 of the source? Be careful about floats/doubles.
302 gencode (CAssign lhs rhs)
303 | getAmodeRep lhs == VoidRep = returnUs id
305 = let pk = getAmodeRep lhs
306 pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
310 returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
314 Unconditional jumps, including the special ``enter closure'' operation.
315 Note that the new entry convention requires that we load the InfoPtr (R2)
316 with the address of the info table before jumping to the entry code for Node.
318 For a vectored return, we must subtract the size of the info table to
319 get at the return vector. This depends on the size of the info table,
320 which varies depending on whether we're profiling etc.
325 = returnUs (\xs -> StJump (a2stix dest) : xs)
327 gencode (CFallThrough (CLbl lbl _))
328 = returnUs (\xs -> StFallThrough lbl : xs)
330 gencode (CReturn dest DirectReturn)
331 = returnUs (\xs -> StJump (a2stix dest) : xs)
333 gencode (CReturn table (StaticVectoredReturn n))
334 = returnUs (\xs -> StJump dest : xs)
336 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
337 (StInt (toInteger (-n-fixedItblSize-1))))
339 gencode (CReturn table (DynamicVectoredReturn am))
340 = returnUs (\xs -> StJump dest : xs)
342 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
343 dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am],
344 StInt (toInteger (fixedItblSize+1))]
348 Now the PrimOps, some of which may need caller-saves register wrappers.
352 gencode (COpStmt results op args vols)
353 -- ToDo (ADR?): use that liveness mask
354 | primOpNeedsWrapper op
356 saves = volsaves vols
357 restores = volrestores vols
359 p2stix (nonVoid results) op (nonVoid args)
361 returnUs (\xs -> saves ++ code (restores ++ xs))
363 | otherwise = p2stix (nonVoid results) op (nonVoid args)
365 nonVoid = filter ((/= VoidRep) . getAmodeRep)
369 Now the dreaded conditional jump.
371 Now the if statement. Almost *all* flow of control are of this form.
373 if (am==lit) { absC } else { absCdef }
387 gencode (CSwitch discrim alts deflt)
391 [(tag,alt_code)] -> case maybe_empty_deflt of
392 Nothing -> gencode alt_code
393 Just dc -> mkIfThenElse discrim tag alt_code dc
395 [(tag1@(MachInt i1), alt_code1),
396 (tag2@(MachInt i2), alt_code2)]
397 | deflt_is_empty && i1 == 0 && i2 == 1
398 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
399 | deflt_is_empty && i1 == 1 && i2 == 0
400 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
402 -- If the @discrim@ is simple, then this unfolding is safe.
403 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
405 -- Otherwise, we need to do a bit of work.
406 other -> getUniqueUs `thenUs` \ u ->
408 (CAssign (CTemp u pk) discrim)
409 (CSwitch (CTemp u pk) alts deflt))
412 maybe_empty_deflt = nonemptyAbsC deflt
413 deflt_is_empty = case maybe_empty_deflt of
417 pk = getAmodeRep discrim
419 simple_discrim = case discrim of
427 Finally, all of the disgusting AbstractC macros.
431 gencode (CMacroStmt macro args) = macro_code macro args
433 gencode (CCallProfCtrMacro macro _)
434 = returnUs (\xs -> StComment macro : xs)
436 gencode (CCallProfCCMacro macro _)
437 = returnUs (\xs -> StComment macro : xs)
440 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
443 Here, we generate a jump table if there are more than four (integer)
444 alternatives and the jump table occupancy is greater than 50%.
445 Otherwise, we generate a binary comparison tree. (Perhaps this could
450 intTag :: Literal -> Integer
451 intTag (MachChar c) = toInteger (ord c)
452 intTag (MachInt i) = i
453 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
454 intTag _ = panic "intTag"
456 fltTag :: Literal -> Rational
458 fltTag (MachFloat f) = f
459 fltTag (MachDouble d) = d
460 fltTag x = pprPanic "fltTag" (ppr x)
464 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
465 -> UniqSM StixTreeList
467 mkSimpleSwitches am alts absC
468 = getUniqLabelNCG `thenUs` \ udlbl ->
469 getUniqLabelNCG `thenUs` \ ujlbl ->
471 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
472 sortedAlts = naturalMergeSortLe leAlt joinedAlts
473 -- naturalMergeSortLe, because we often get sorted alts to begin with
475 lowTag = intTag (fst (head sortedAlts))
476 highTag = intTag (fst (last sortedAlts))
478 -- lowest and highest possible values the discriminant could take
479 lowest = if floating then targetMinDouble else targetMinInt
480 highest = if floating then targetMaxDouble else targetMaxInt
483 if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
484 mkJumpTable am' sortedAlts lowTag highTag udlbl
486 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
488 `thenUs` \ alt_code ->
489 gencode absC `thenUs` \ dflt_code ->
491 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
494 floating = isFloatingRep (getAmodeRep am)
495 choices = length alts
497 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
498 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
499 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
500 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
504 We use jump tables when doing an integer switch on a relatively dense
505 list of alternatives. We expect to be given a list of alternatives,
506 sorted by tag, and a range of values for which we are to generate a
507 table. Of course, the tags of the alternatives should lie within the
508 indicated range. The alternatives need not cover the range; a default
509 target is provided for the missing alternatives.
511 If a join is necessary after the switch, the alternatives should
512 already finish with a jump to the join point.
517 :: StixTree -- discriminant
518 -> [(Literal, AbstractC)] -- alternatives
519 -> Integer -- low tag
520 -> Integer -- high tag
521 -> CLabel -- default label
522 -> UniqSM StixTreeList
525 mkJumpTable am alts lowTag highTag dflt
526 = getUniqLabelNCG `thenUs` \ utlbl ->
527 mapUs genLabel alts `thenUs` \ branches ->
528 let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
529 cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
531 offset = StPrim IntSubOp [am, StInt lowTag]
533 jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
535 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
537 mapUs mkBranch branches `thenUs` \ alts ->
539 returnUs (\xs -> cjmpLo : cjmpHi : jump :
540 StSegment DataSegment : tlbl : table :
541 StSegment TextSegment : foldr1 (.) alts xs)
544 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
546 mkBranch (lbl,(_,alt)) =
547 gencode alt `thenUs` \ alt_code ->
548 returnUs (\xs -> StLabel lbl : alt_code xs)
550 mkTable _ [] tbl = reverse tbl
551 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
552 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
553 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
554 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
558 We generate binary comparison trees when a jump table is inappropriate.
559 We expect to be given a list of alternatives, sorted by tag, and for
560 convenience, the length of the alternative list. We recursively break
561 the list in half and do a comparison on the first tag of the second half
562 of the list. (Odd lists are broken so that the second half of the list
563 is longer.) We can handle either integer or floating kind alternatives,
564 so long as they are not mixed. (We assume that the type of the discriminant
565 determines the type of the alternatives.)
567 As with the jump table approach, if a join is necessary after the switch, the
568 alternatives should already finish with a jump to the join point.
573 :: StixTree -- discriminant
574 -> Bool -- floating point?
575 -> [(Literal, AbstractC)] -- alternatives
576 -> Int -- number of choices
577 -> Literal -- low tag
578 -> Literal -- high tag
579 -> CLabel -- default code label
580 -> UniqSM StixTreeList
583 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
584 | rangeOfOne = gencode alt
586 = let tag' = a2stix (CLit tag)
587 cmpOp = if floating then DoubleNeOp else IntNeOp
588 test = StPrim cmpOp [am, tag']
589 cjmp = StCondJump udlbl test
591 gencode alt `thenUs` \ alt_code ->
592 returnUs (\xs -> cjmp : alt_code xs)
595 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
596 -- When there is only one possible tag left in range, we skip the comparison
598 mkBinaryTree am floating alts choices lowTag highTag udlbl
599 = getUniqLabelNCG `thenUs` \ uhlbl ->
600 let tag' = a2stix (CLit splitTag)
601 cmpOp = if floating then DoubleGeOp else IntGeOp
602 test = StPrim cmpOp [am, tag']
603 cjmp = StCondJump uhlbl test
605 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
606 `thenUs` \ lo_code ->
607 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
608 `thenUs` \ hi_code ->
610 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
613 half = choices `div` 2
614 (alts_lo, alts_hi) = splitAt half alts
615 splitTag = fst (head alts_hi)
622 :: CAddrMode -- discriminant
624 -> AbstractC -- if-part
625 -> AbstractC -- else-part
626 -> UniqSM StixTreeList
629 mkIfThenElse discrim tag alt deflt
630 = getUniqLabelNCG `thenUs` \ ujlbl ->
631 getUniqLabelNCG `thenUs` \ utlbl ->
632 let discrim' = a2stix discrim
633 tag' = a2stix (CLit tag)
634 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
635 test = StPrim cmpOp [discrim', tag']
636 cjmp = StCondJump utlbl test
640 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
641 gencode deflt `thenUs` \ dflt_code ->
642 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
644 mkJoin :: AbstractC -> CLabel -> AbstractC
647 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
651 %---------------------------------------------------------------------------
653 This answers the question: Can the code fall through to the next
654 line(s) of code? This errs towards saying True if it can't choose,
655 because it is used for eliminating needless jumps. In other words, if
656 you might possibly {\em not} jump, then say yes to falling through.
659 mightFallThrough :: AbstractC -> Bool
661 mightFallThrough absC = ft absC True
663 ft AbsCNop if_empty = if_empty
665 ft (CJump _) if_empty = False
666 ft (CReturn _ _) if_empty = False
667 ft (CSwitch _ alts deflt) if_empty
668 = ft deflt if_empty ||
669 or [ft alt if_empty | (_,alt) <- alts]
671 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
672 ft _ if_empty = if_empty
674 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
675 fallThroughAbsC (AbsCStmts c1 c2)
676 = case nonemptyAbsC c2 of
677 Nothing -> fallThroughAbsC c1
678 Just x -> fallThroughAbsC x
679 fallThroughAbsC (CJump _) = False
680 fallThroughAbsC (CReturn _ _) = False
681 fallThroughAbsC (CSwitch _ choices deflt)
682 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
683 || or (map (fallThroughAbsC . snd) choices)
684 fallThroughAbsC other = True
686 isEmptyAbsC :: AbstractC -> Bool
687 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
688 ================= End of old, quadratic, algorithm -}