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
19 import PprAbsC ( dumpRealC )
20 import SMRep ( fixedItblSize,
22 rET_VEC_SMALL, rET_VEC_BIG
24 import Constants ( mIN_UPD_SIZE, wORD_SIZE )
25 import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
26 mkClosureTblLabel, mkClosureLabel,
27 labelDynamic, mkSplitMarkerLabel )
28 import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
29 closureLabelFromCI, fastLabelFromCI
31 import Literal ( Literal(..), word2IntLit )
32 import Maybes ( maybeToBool )
33 import StgSyn ( StgOp(..) )
34 import MachOp ( MachOp(..), resultRepOfMachOp )
35 import PrimRep ( isFloatingRep, is64BitRep,
36 PrimRep(..), getPrimRepSizeInBytes )
37 import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
38 livenessIsSmall, bitmapToIntegers )
39 import StixMacro ( macroCode, checkCode )
40 import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
41 import Outputable ( pprPanic, ppr )
42 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
43 import Util ( naturalMergeSortLe )
44 import Panic ( panic )
45 import TyCon ( tyConDataCons )
46 import DataCon ( dataConWrapId )
47 import Name ( NamedThing(..) )
48 import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
49 import Outputable ( assertPanic )
52 --import TRACE ( trace )
53 --import Outputable ( showSDoc )
54 --import MachOp ( pprMachOp )
58 For each independent chunk of AbstractC code, we generate a list of
59 @StixTree@s, where each tree corresponds to a single Stix instruction.
60 We leave the chunks separated so that register allocation can be
61 performed locally within the chunk.
64 genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
70 a2stix' = amodeToStix'
71 volsaves = volatileSaves
72 volrestores = volatileRestores
73 macro_code = macroCode
74 -- real code follows... ---------
77 Here we handle top-level things, like @CCodeBlock@s and
87 gentopcode (CCodeBlock lbl absC)
88 = gencode absC `thenUs` \ code ->
89 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
91 gentopcode stmt@(CStaticClosure closure_info _ _)
92 = genCodeStaticClosure stmt `thenUs` \ code ->
95 then StSegment DataSegment
96 : StLabel lbl : code []
97 else StSegment DataSegment
98 : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
99 : StLabel lbl : code []
102 lbl = closureLabelFromCI closure_info
104 gentopcode stmt@(CRetVector lbl _ _ _)
105 = genCodeVecTbl stmt `thenUs` \ code ->
106 returnUs (StSegment TextSegment
107 : code [StLabel lbl, vtbl_post_label_word])
109 -- We put a dummy word after the vtbl label so as to ensure the label
110 -- is in the same (Text) section as the vtbl it labels. This is critical
111 -- for ensuring the GC works correctly, although GC crashes due to
112 -- misclassification are much more likely to show up in the interactive
113 -- system than in compile code. For details see comment near line 1164
114 -- of ghc/driver/mangler/ghc-asm.lprl, which contains an analogous fix
115 -- for the mangled via-C route.
116 vtbl_post_label_word = StData PtrRep [StInt 0]
118 gentopcode stmt@(CRetDirect uniq absC srt liveness)
119 = gencode absC `thenUs` \ code ->
120 genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
121 returnUs (StSegment TextSegment :
122 itbl (StLabel lbl_info : StLabel lbl_ret : code []))
124 lbl_info = mkReturnInfoLabel uniq
125 lbl_ret = mkReturnPtLabel uniq
126 closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
128 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
131 = genCodeInfoTable stmt `thenUs` \ itbl ->
132 returnUs (StSegment TextSegment : itbl [])
135 = genCodeInfoTable stmt `thenUs` \ itbl ->
136 gencode slow `thenUs` \ slow_code ->
137 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
138 slow_code [StFunEnd slow_lbl]))
140 slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
141 slow_lbl = entryLabelFromCI cl_info
143 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
144 -- ToDo: what if this is empty? ------------------------^^^^
145 genCodeInfoTable stmt `thenUs` \ itbl ->
146 gencode slow `thenUs` \ slow_code ->
147 gencode fast `thenUs` \ fast_code ->
148 returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
149 slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
150 fast_code [StFunEnd fast_lbl])))
152 slow_lbl = entryLabelFromCI cl_info
153 fast_lbl = fastLabelFromCI cl_info
155 gentopcode stmt@(CSRT lbl closures)
156 = returnUs [ StSegment TextSegment
158 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
161 mk_StCLbl_for_SRT :: CLabel -> StixExpr
162 mk_StCLbl_for_SRT label
164 = StIndex Int8Rep (StCLbl label) (StInt 1)
168 gentopcode stmt@(CBitmap lbl mask)
169 = returnUs $ case bitmapToIntegers mask of
171 [ StSegment TextSegment
173 , StData WordRep (map StInt (toInteger (length mask') : mask'))
177 gentopcode stmt@(CClosureTbl tycon)
178 = returnUs [ StSegment TextSegment
179 , StLabel (mkClosureTblLabel tycon)
180 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
181 (tyConDataCons tycon) )
184 gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
185 = gencode absC `thenUs` \ code ->
186 getUniqLabelNCG `thenUs` \ tmp_lbl ->
187 getUniqLabelNCG `thenUs` \ flag_lbl ->
188 returnUs ( StSegment DataSegment
190 : StData IntRep [StInt 0]
191 : StSegment TextSegment
193 : StJump NoDestInfo (StCLbl lbl)
195 : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
196 [StInd IntRep (StCLbl flag_lbl),
198 : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
201 , StAssignReg PtrRep stgSp
202 (StIndex PtrRep (StReg stgSp) (StInt (-1)))
203 , StJump NoDestInfo (StInd WordRep (StReg stgSp))
207 = gencode absC `thenUs` \ code ->
208 returnUs (StSegment TextSegment : code [])
215 -> UniqSM StixTreeList
217 genCodeVecTbl (CRetVector lbl amodes srt liveness)
218 = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
219 returnUs (\xs -> vectbl : itbl xs)
221 vectbl = StData PtrRep (reverse (map a2stix amodes))
222 closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
230 -> UniqSM StixTreeList
232 genCodeStaticClosure (CStaticClosure cl_info cost_centre amodes)
233 = returnUs (\xs -> table ++ xs)
235 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
236 foldr do_one_amode [] amodes
238 do_one_amode amode rest
239 | rep == VoidRep = rest
240 | otherwise = StData (promote_to_word rep) [a2stix amode] : rest
242 rep = getAmodeRep amode
244 -- We need to promote any item smaller than a word to a word
246 | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
250 Now the individual AbstractC statements.
256 -> UniqSM StixTreeList
260 @AbsCNop@s just disappear.
264 gencode AbsCNop = returnUs id
268 Split markers just insert a __stg_split_marker, which is caught by the
269 split-mangler later on and used to split the assembly into chunks.
274 | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
275 | otherwise = returnUs id
279 AbstractC instruction sequences are handled individually, and the
280 resulting StixTreeLists are joined together.
284 gencode (AbsCStmts c1 c2)
285 = gencode c1 `thenUs` \ b1 ->
286 gencode c2 `thenUs` \ b2 ->
289 gencode (CSequential stuff)
293 foo (s:ss) = gencode s `thenUs` \ stix ->
294 foo ss `thenUs` \ stixes ->
295 returnUs (stix . stixes)
299 Initialising closure headers in the heap...a fairly complex ordeal if
300 done properly. For now, we just set the info pointer, but we should
301 really take a peek at the flags to determine whether or not there are
302 other things to be done (setting cost centres, age headers, global
307 gencode (CInitHdr cl_info reg_rel _ _)
310 lbl = infoTableLabelFromCI cl_info
312 returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
320 gencode (CCheck macro args assts)
321 = gencode assts `thenUs` \assts_stix ->
322 checkCode macro args assts_stix
326 Assignment, the curse of von Neumann, is the center of the code we
327 produce. In most cases, the type of the assignment is determined
328 by the type of the destination. However, when the destination can
329 have mixed types, the type of the assignment is ``StgWord'' (we use
330 PtrRep for lack of anything better). Think: do we also want a cast
331 of the source? Be careful about floats/doubles.
335 gencode (CAssign lhs rhs)
339 = let -- This is a Hack. Should be cleaned up.
341 pk' | ncg_target_is_32bit && is64BitRep lhs_rep
344 = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep)
350 returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
352 lhs_rep = getAmodeRep lhs
356 Unconditional jumps, including the special ``enter closure'' operation.
357 Note that the new entry convention requires that we load the InfoPtr (R2)
358 with the address of the info table before jumping to the entry code for Node.
360 For a vectored return, we must subtract the size of the info table to
361 get at the return vector. This depends on the size of the info table,
362 which varies depending on whether we're profiling etc.
367 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
369 gencode (CFallThrough (CLbl lbl _))
370 = returnUs (\xs -> StFallThrough lbl : xs)
372 gencode (CReturn dest DirectReturn)
373 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
375 gencode (CReturn table (StaticVectoredReturn n))
376 = returnUs (\xs -> StJump NoDestInfo dest : xs)
378 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
379 (StInt (toInteger (-n-fixedItblSize-1))))
381 gencode (CReturn table (DynamicVectoredReturn am))
382 = returnUs (\xs -> StJump NoDestInfo dest : xs)
384 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
385 dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
386 StInt (toInteger (fixedItblSize+1))]
390 Now the PrimOps, some of which may need caller-saves register wrappers.
393 gencode (COpStmt results (StgFCallOp fcall _) args vols)
394 = ASSERT( null vols )
395 foreignCallCode (nonVoid results) fcall (nonVoid args)
397 gencode (COpStmt results (StgPrimOp op) args vols)
398 = panic "AbsCStixGen.gencode: un-translated PrimOp"
400 gencode (CMachOpStmt res mop args vols)
401 = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res)
402 (StMachOp mop (map a2stix args))
407 Now the dreaded conditional jump.
409 Now the if statement. Almost *all* flow of control are of this form.
411 if (am==lit) { absC } else { absCdef }
425 gencode (CSwitch discrim alts deflt)
429 [(tag,alt_code)] -> case maybe_empty_deflt of
430 Nothing -> gencode alt_code
431 Just dc -> mkIfThenElse discrim tag alt_code dc
433 [(tag1@(MachInt i1), alt_code1),
434 (tag2@(MachInt i2), alt_code2)]
435 | deflt_is_empty && i1 == 0 && i2 == 1
436 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
437 | deflt_is_empty && i1 == 1 && i2 == 0
438 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
440 -- If the @discrim@ is simple, then this unfolding is safe.
441 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
443 -- Otherwise, we need to do a bit of work.
444 other -> getUniqueUs `thenUs` \ u ->
446 (CAssign (CTemp u pk) discrim)
447 (CSwitch (CTemp u pk) alts deflt))
450 maybe_empty_deflt = nonemptyAbsC deflt
451 deflt_is_empty = case maybe_empty_deflt of
455 pk = getAmodeRep discrim
457 simple_discrim = case discrim of
465 Finally, all of the disgusting AbstractC macros.
469 gencode (CMacroStmt macro args) = macro_code macro args
471 gencode (CCallProfCtrMacro macro _)
472 = returnUs (\xs -> StComment macro : xs)
474 gencode (CCallProfCCMacro macro _)
475 = returnUs (\xs -> StComment macro : xs)
477 gencode CCallTypedef{} = returnUs id
480 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
482 nonVoid = filter ((/= VoidRep) . getAmodeRep)
485 Here, we generate a jump table if there are more than four (integer)
486 alternatives and the jump table occupancy is greater than 50%.
487 Otherwise, we generate a binary comparison tree. (Perhaps this could
492 intTag :: Literal -> Integer
493 intTag (MachChar c) = toInteger c
494 intTag (MachInt i) = i
495 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
496 intTag _ = panic "intTag"
498 fltTag :: Literal -> Rational
500 fltTag (MachFloat f) = f
501 fltTag (MachDouble d) = d
502 fltTag x = pprPanic "fltTag" (ppr x)
506 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
507 -> UniqSM StixTreeList
509 mkSimpleSwitches am alts absC
510 = getUniqLabelNCG `thenUs` \ udlbl ->
511 getUniqLabelNCG `thenUs` \ ujlbl ->
513 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
514 sortedAlts = naturalMergeSortLe leAlt joinedAlts
515 -- naturalMergeSortLe, because we often get sorted alts to begin with
517 lowTag = intTag (fst (head sortedAlts))
518 highTag = intTag (fst (last sortedAlts))
520 -- lowest and highest possible values the discriminant could take
521 lowest = if floating then targetMinDouble else targetMinInt
522 highest = if floating then targetMaxDouble else targetMaxInt
525 if not floating && choices > 4
526 && highTag - lowTag < toInteger (2 * choices)
528 mkJumpTable am' sortedAlts lowTag highTag udlbl
530 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
532 `thenUs` \ alt_code ->
533 gencode absC `thenUs` \ dflt_code ->
535 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
538 floating = isFloatingRep (getAmodeRep am)
539 choices = length alts
541 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
542 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
543 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
544 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
548 We use jump tables when doing an integer switch on a relatively dense
549 list of alternatives. We expect to be given a list of alternatives,
550 sorted by tag, and a range of values for which we are to generate a
551 table. Of course, the tags of the alternatives should lie within the
552 indicated range. The alternatives need not cover the range; a default
553 target is provided for the missing alternatives.
555 If a join is necessary after the switch, the alternatives should
556 already finish with a jump to the join point.
561 :: StixTree -- discriminant
562 -> [(Literal, AbstractC)] -- alternatives
563 -> Integer -- low tag
564 -> Integer -- high tag
565 -> CLabel -- default label
566 -> UniqSM StixTreeList
569 mkJumpTable am alts lowTag highTag dflt
570 = getUniqLabelNCG `thenUs` \ utlbl ->
571 mapUs genLabel alts `thenUs` \ branches ->
572 let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
573 cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
575 offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
576 dsts = DestInfo (dflt : map fst branches)
578 jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
580 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
582 mapUs mkBranch branches `thenUs` \ alts ->
584 returnUs (\xs -> cjmpLo : cjmpHi : jump :
585 StSegment DataSegment : tlbl : table :
586 StSegment TextSegment : foldr1 (.) alts xs)
589 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
591 mkBranch (lbl,(_,alt)) =
592 gencode alt `thenUs` \ alt_code ->
593 returnUs (\xs -> StLabel lbl : alt_code xs)
595 mkTable _ [] tbl = reverse tbl
596 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
597 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
598 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
599 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
603 We generate binary comparison trees when a jump table is inappropriate.
604 We expect to be given a list of alternatives, sorted by tag, and for
605 convenience, the length of the alternative list. We recursively break
606 the list in half and do a comparison on the first tag of the second half
607 of the list. (Odd lists are broken so that the second half of the list
608 is longer.) We can handle either integer or floating kind alternatives,
609 so long as they are not mixed. (We assume that the type of the discriminant
610 determines the type of the alternatives.)
612 As with the jump table approach, if a join is necessary after the switch, the
613 alternatives should already finish with a jump to the join point.
618 :: StixTree -- discriminant
619 -> Bool -- floating point?
620 -> [(Literal, AbstractC)] -- alternatives
621 -> Int -- number of choices
622 -> Literal -- low tag
623 -> Literal -- high tag
624 -> CLabel -- default code label
625 -> UniqSM StixTreeList
628 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
629 | rangeOfOne = gencode alt
631 = let tag' = a2stix (CLit tag)
632 cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
633 test = StMachOp cmpOp [am, tag']
634 cjmp = StCondJump udlbl test
636 gencode alt `thenUs` \ alt_code ->
637 returnUs (\xs -> cjmp : alt_code xs)
640 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
641 -- When there is only one possible tag left in range, we skip the comparison
643 mkBinaryTree am floating alts choices lowTag highTag udlbl
644 = getUniqLabelNCG `thenUs` \ uhlbl ->
645 let tag' = a2stix (CLit splitTag)
646 cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
647 test = StMachOp cmpOp [am, tag']
648 cjmp = StCondJump uhlbl test
650 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
651 `thenUs` \ lo_code ->
652 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
653 `thenUs` \ hi_code ->
655 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
658 half = choices `div` 2
659 (alts_lo, alts_hi) = splitAt half alts
660 splitTag = fst (head alts_hi)
667 :: CAddrMode -- discriminant
669 -> AbstractC -- if-part
670 -> AbstractC -- else-part
671 -> UniqSM StixTreeList
674 mkIfThenElse discrim tag alt deflt
675 = getUniqLabelNCG `thenUs` \ ujlbl ->
676 getUniqLabelNCG `thenUs` \ utlbl ->
677 let discrim' = a2stix discrim
678 tag' = a2stix (CLit tag)
679 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
680 test = StMachOp cmpOp [discrim', tag']
681 cjmp = StCondJump utlbl test
685 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
686 gencode deflt `thenUs` \ dflt_code ->
687 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
690 mkJoin :: AbstractC -> CLabel -> AbstractC
692 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
696 %---------------------------------------------------------------------------
698 This answers the question: Can the code fall through to the next
699 line(s) of code? This errs towards saying True if it can't choose,
700 because it is used for eliminating needless jumps. In other words, if
701 you might possibly {\em not} jump, then say yes to falling through.
704 mightFallThrough :: AbstractC -> Bool
706 mightFallThrough absC = ft absC True
708 ft AbsCNop if_empty = if_empty
710 ft (CJump _) if_empty = False
711 ft (CReturn _ _) if_empty = False
712 ft (CSwitch _ alts deflt) if_empty
713 = ft deflt if_empty ||
714 or [ft alt if_empty | (_,alt) <- alts]
716 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
717 ft _ if_empty = if_empty
719 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
720 fallThroughAbsC (AbsCStmts c1 c2)
721 = case nonemptyAbsC c2 of
722 Nothing -> fallThroughAbsC c1
723 Just x -> fallThroughAbsC x
724 fallThroughAbsC (CJump _) = False
725 fallThroughAbsC (CReturn _ _) = False
726 fallThroughAbsC (CSwitch _ choices deflt)
727 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
728 || or (map (fallThroughAbsC . snd) choices)
729 fallThroughAbsC other = True
731 isEmptyAbsC :: AbstractC -> Bool
732 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
733 ================= End of old, quadratic, algorithm -}