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 ( retItblSize )
21 import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
22 mkClosureTblLabel, mkClosureLabel,
23 labelDynamic, mkSplitMarkerLabel )
25 import Literal ( Literal(..), word2IntLit )
26 import StgSyn ( StgOp(..) )
27 import MachOp ( MachOp(..), resultRepOfMachOp )
28 import PrimRep ( isFloatingRep, is64BitRep,
29 PrimRep(..), getPrimRepSizeInBytes )
30 import StixMacro ( macroCode, checkCode )
31 import StixPrim ( foreignCallCode, amodeToStix, amodeToStix' )
32 import Outputable ( pprPanic, ppr )
33 import UniqSupply ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
34 import Util ( naturalMergeSortLe )
35 import Panic ( panic )
36 import TyCon ( tyConDataCons )
37 import Name ( NamedThing(..) )
38 import CmdLineOpts ( opt_EnsureSplittableC )
39 import Outputable ( assertPanic )
42 --import TRACE ( trace )
43 --import Outputable ( showSDoc )
44 --import MachOp ( pprMachOp )
46 #include "nativeGen/NCG.h"
49 For each independent chunk of AbstractC code, we generate a list of
50 @StixTree@s, where each tree corresponds to a single Stix instruction.
51 We leave the chunks separated so that register allocation can be
52 performed locally within the chunk.
55 genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
61 a2stix' = amodeToStix'
62 volsaves = volatileSaves
63 volrestores = volatileRestores
64 macro_code = macroCode
65 -- real code follows... ---------
68 Here we handle top-level things, like @CCodeBlock@s and
78 gentopcode (CCodeBlock lbl absC)
79 = gencode absC `thenUs` \ code ->
80 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
82 gentopcode stmt@(CStaticClosure lbl closure_info _ _)
83 = genCodeStaticClosure stmt `thenUs` \ code ->
84 returnUs ( StSegment DataSegment
85 : StLabel lbl : code []
88 gentopcode stmt@(CRetVector lbl amodes srt liveness)
89 = returnUs ( StSegment TextSegment
95 table = map amodeToStix (mkVecInfoTable amodes srt liveness)
97 gentopcode stmt@(CRetDirect uniq absC srt liveness)
98 = gencode absC `thenUs` \ code ->
99 returnUs ( StSegment TextSegment
100 : StData PtrRep table
105 info_lbl = mkReturnInfoLabel uniq
106 ret_lbl = mkReturnPtLabel uniq
107 table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
109 gentopcode stmt@(CClosureInfoAndCode cl_info entry)
110 = gencode entry `thenUs` \ slow_code ->
111 returnUs ( StSegment TextSegment
112 : StData PtrRep table
114 : StFunBegin entry_lbl
115 : slow_code [StFunEnd entry_lbl])
117 entry_lbl = entryLabelFromCI cl_info
118 info_lbl = infoTableLabelFromCI cl_info
119 table = map amodeToStix (mkInfoTable cl_info)
121 gentopcode stmt@(CSRT lbl closures)
122 = returnUs [ StSegment TextSegment
124 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
127 mk_StCLbl_for_SRT :: CLabel -> StixExpr
128 mk_StCLbl_for_SRT label
130 = StIndex Int8Rep (StCLbl label) (StInt 1)
134 gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
136 [ StSegment TextSegment
138 , StData WordRep (map StInt (toInteger size : map toInteger mask))
141 gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap)
143 [ StSegment TextSegment
146 StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) :
147 map StInt (toInteger len : map toInteger bitmap)
151 gentopcode stmt@(CClosureTbl tycon)
152 = returnUs [ StSegment TextSegment
153 , StLabel (mkClosureTblLabel tycon)
154 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName)
155 (tyConDataCons tycon) )
158 gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
159 = gencode absC `thenUs` \ code ->
160 getUniqLabelNCG `thenUs` \ tmp_lbl ->
161 getUniqLabelNCG `thenUs` \ flag_lbl ->
162 returnUs ( StSegment DataSegment
164 : StData IntRep [StInt 0]
165 : StSegment TextSegment
167 : StJump NoDestInfo (StCLbl lbl)
169 : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
170 [StInd IntRep (StCLbl flag_lbl),
172 : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
175 , StAssignReg PtrRep stgSp
176 (StIndex PtrRep (StReg stgSp) (StInt (-1)))
177 , StJump NoDestInfo (StInd WordRep (StReg stgSp))
181 = gencode absC `thenUs` \ code ->
182 returnUs (StSegment TextSegment : code [])
189 -> UniqSM StixTreeList
191 genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
192 = returnUs (\xs -> table ++ xs)
194 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
195 foldr do_one_amode [] amodes
197 do_one_amode amode rest
198 | rep == VoidRep = rest
199 | otherwise = StData (promote_to_word rep) [a2stix amode] : rest
201 rep = getAmodeRep amode
203 -- We need to promote any item smaller than a word to a word
205 | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
209 Now the individual AbstractC statements.
215 -> UniqSM StixTreeList
219 @AbsCNop@s just disappear.
223 gencode AbsCNop = returnUs id
227 Split markers just insert a __stg_split_marker, which is caught by the
228 split-mangler later on and used to split the assembly into chunks.
233 | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
234 | otherwise = returnUs id
238 AbstractC instruction sequences are handled individually, and the
239 resulting StixTreeLists are joined together.
243 gencode (AbsCStmts c1 c2)
244 = gencode c1 `thenUs` \ b1 ->
245 gencode c2 `thenUs` \ b2 ->
248 gencode (CSequential stuff)
252 foo (s:ss) = gencode s `thenUs` \ stix ->
253 foo ss `thenUs` \ stixes ->
254 returnUs (stix . stixes)
258 Initialising closure headers in the heap...a fairly complex ordeal if
259 done properly. For now, we just set the info pointer, but we should
260 really take a peek at the flags to determine whether or not there are
261 other things to be done (setting cost centres, age headers, global
266 gencode (CInitHdr cl_info reg_rel _ _)
269 lbl = infoTableLabelFromCI cl_info
271 returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
279 gencode (CCheck macro args assts)
280 = gencode assts `thenUs` \assts_stix ->
281 checkCode macro args assts_stix
285 Assignment, the curse of von Neumann, is the center of the code we
286 produce. In most cases, the type of the assignment is determined
287 by the type of the destination. However, when the destination can
288 have mixed types, the type of the assignment is ``StgWord'' (we use
289 PtrRep for lack of anything better). Think: do we also want a cast
290 of the source? Be careful about floats/doubles.
294 gencode (CAssign lhs rhs)
298 = let -- This is a Hack. Should be cleaned up.
300 pk' | ncg_target_is_32bit && is64BitRep lhs_rep
303 = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep)
309 returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
311 lhs_rep = getAmodeRep lhs
315 Unconditional jumps, including the special ``enter closure'' operation.
316 Note that the new entry convention requires that we load the InfoPtr (R2)
317 with the address of the info table before jumping to the entry code for Node.
319 For a vectored return, we must subtract the size of the info table to
320 get at the return vector. This depends on the size of the info table,
321 which varies depending on whether we're profiling etc.
326 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
328 gencode (CFallThrough (CLbl lbl _))
329 = returnUs (\xs -> StFallThrough lbl : xs)
331 gencode (CReturn dest DirectReturn)
332 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
334 gencode (CReturn table (StaticVectoredReturn n))
335 = returnUs (\xs -> StJump NoDestInfo dest : xs)
337 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
338 (StInt (toInteger (-n-retItblSize-1))))
340 gencode (CReturn table (DynamicVectoredReturn am))
341 = returnUs (\xs -> StJump NoDestInfo dest : xs)
343 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
344 dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
345 StInt (toInteger (retItblSize+1))]
349 Now the PrimOps, some of which may need caller-saves register wrappers.
352 gencode (COpStmt results (StgFCallOp fcall _) args vols)
353 = ASSERT( null vols )
354 foreignCallCode (nonVoid results) fcall (nonVoid args)
356 gencode (COpStmt results (StgPrimOp op) args vols)
357 = panic "AbsCStixGen.gencode: un-translated PrimOp"
359 gencode (CMachOpStmt res mop args vols)
360 = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res)
361 (StMachOp mop (map a2stix args))
366 Now the dreaded conditional jump.
368 Now the if statement. Almost *all* flow of control are of this form.
370 if (am==lit) { absC } else { absCdef }
384 gencode (CSwitch discrim alts deflt)
388 [(tag,alt_code)] -> case maybe_empty_deflt of
389 Nothing -> gencode alt_code
390 Just dc -> mkIfThenElse discrim tag alt_code dc
392 [(tag1@(MachInt i1), alt_code1),
393 (tag2@(MachInt i2), alt_code2)]
394 | deflt_is_empty && i1 == 0 && i2 == 1
395 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
396 | deflt_is_empty && i1 == 1 && i2 == 0
397 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
399 -- If the @discrim@ is simple, then this unfolding is safe.
400 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
402 -- Otherwise, we need to do a bit of work.
403 other -> getUniqueUs `thenUs` \ u ->
405 (CAssign (CTemp u pk) discrim)
406 (CSwitch (CTemp u pk) alts deflt))
409 maybe_empty_deflt = nonemptyAbsC deflt
410 deflt_is_empty = case maybe_empty_deflt of
414 pk = getAmodeRep discrim
416 simple_discrim = case discrim of
424 Finally, all of the disgusting AbstractC macros.
428 gencode (CMacroStmt macro args) = macro_code macro args
430 gencode (CCallProfCtrMacro macro _)
431 = returnUs (\xs -> StComment macro : xs)
433 gencode (CCallProfCCMacro macro _)
434 = returnUs (\xs -> StComment macro : xs)
436 gencode CCallTypedef{} = returnUs id
439 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
441 nonVoid = filter ((/= VoidRep) . getAmodeRep)
444 Here, we generate a jump table if there are more than four (integer)
445 alternatives and the jump table occupancy is greater than 50%.
446 Otherwise, we generate a binary comparison tree. (Perhaps this could
451 intTag :: Literal -> Integer
452 intTag (MachChar c) = toInteger c
453 intTag (MachInt i) = i
454 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
455 intTag _ = panic "intTag"
457 fltTag :: Literal -> Rational
459 fltTag (MachFloat f) = f
460 fltTag (MachDouble d) = d
461 fltTag x = pprPanic "fltTag" (ppr x)
465 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
466 -> UniqSM StixTreeList
468 mkSimpleSwitches am alts absC
469 = getUniqLabelNCG `thenUs` \ udlbl ->
470 getUniqLabelNCG `thenUs` \ ujlbl ->
472 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
473 sortedAlts = naturalMergeSortLe leAlt joinedAlts
474 -- naturalMergeSortLe, because we often get sorted alts to begin with
476 lowTag = intTag (fst (head sortedAlts))
477 highTag = intTag (fst (last sortedAlts))
479 -- lowest and highest possible values the discriminant could take
480 lowest = if floating then targetMinDouble else targetMinInt
481 highest = if floating then targetMaxDouble else targetMaxInt
484 if not floating && choices > 4
485 && highTag - lowTag < toInteger (2 * choices)
487 mkJumpTable am' sortedAlts lowTag highTag udlbl
489 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
491 `thenUs` \ alt_code ->
492 gencode absC `thenUs` \ dflt_code ->
494 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
497 floating = isFloatingRep (getAmodeRep am)
498 choices = length alts
500 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
501 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
502 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
503 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
507 We use jump tables when doing an integer switch on a relatively dense
508 list of alternatives. We expect to be given a list of alternatives,
509 sorted by tag, and a range of values for which we are to generate a
510 table. Of course, the tags of the alternatives should lie within the
511 indicated range. The alternatives need not cover the range; a default
512 target is provided for the missing alternatives.
514 If a join is necessary after the switch, the alternatives should
515 already finish with a jump to the join point.
520 :: StixTree -- discriminant
521 -> [(Literal, AbstractC)] -- alternatives
522 -> Integer -- low tag
523 -> Integer -- high tag
524 -> CLabel -- default label
525 -> UniqSM StixTreeList
528 mkJumpTable am alts lowTag highTag dflt
529 = getUniqLabelNCG `thenUs` \ utlbl ->
530 mapUs genLabel alts `thenUs` \ branches ->
531 let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
532 cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
534 offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
535 dsts = DestInfo (dflt : map fst branches)
537 jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
539 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
541 mapUs mkBranch branches `thenUs` \ alts ->
543 returnUs (\xs -> cjmpLo : cjmpHi : jump :
544 StSegment DataSegment : tlbl : table :
545 StSegment TextSegment : foldr1 (.) alts xs)
548 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
550 mkBranch (lbl,(_,alt)) =
551 gencode alt `thenUs` \ alt_code ->
552 returnUs (\xs -> StLabel lbl : alt_code xs)
554 mkTable _ [] tbl = reverse tbl
555 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
556 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
557 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
558 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
562 We generate binary comparison trees when a jump table is inappropriate.
563 We expect to be given a list of alternatives, sorted by tag, and for
564 convenience, the length of the alternative list. We recursively break
565 the list in half and do a comparison on the first tag of the second half
566 of the list. (Odd lists are broken so that the second half of the list
567 is longer.) We can handle either integer or floating kind alternatives,
568 so long as they are not mixed. (We assume that the type of the discriminant
569 determines the type of the alternatives.)
571 As with the jump table approach, if a join is necessary after the switch, the
572 alternatives should already finish with a jump to the join point.
577 :: StixTree -- discriminant
578 -> Bool -- floating point?
579 -> [(Literal, AbstractC)] -- alternatives
580 -> Int -- number of choices
581 -> Literal -- low tag
582 -> Literal -- high tag
583 -> CLabel -- default code label
584 -> UniqSM StixTreeList
587 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
588 | rangeOfOne = gencode alt
590 = let tag' = a2stix (CLit tag)
591 cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
592 test = StMachOp cmpOp [am, tag']
593 cjmp = StCondJump udlbl test
595 gencode alt `thenUs` \ alt_code ->
596 returnUs (\xs -> cjmp : alt_code xs)
599 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
600 -- When there is only one possible tag left in range, we skip the comparison
602 mkBinaryTree am floating alts choices lowTag highTag udlbl
603 = getUniqLabelNCG `thenUs` \ uhlbl ->
604 let tag' = a2stix (CLit splitTag)
605 cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
606 test = StMachOp cmpOp [am, tag']
607 cjmp = StCondJump uhlbl test
609 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
610 `thenUs` \ lo_code ->
611 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
612 `thenUs` \ hi_code ->
614 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
617 half = choices `div` 2
618 (alts_lo, alts_hi) = splitAt half alts
619 splitTag = fst (head alts_hi)
626 :: CAddrMode -- discriminant
628 -> AbstractC -- if-part
629 -> AbstractC -- else-part
630 -> UniqSM StixTreeList
633 mkIfThenElse discrim tag alt deflt
634 = getUniqLabelNCG `thenUs` \ ujlbl ->
635 getUniqLabelNCG `thenUs` \ utlbl ->
636 let discrim' = a2stix discrim
637 tag' = a2stix (CLit tag)
638 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
639 test = StMachOp cmpOp [discrim', tag']
640 cjmp = StCondJump utlbl test
644 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
645 gencode deflt `thenUs` \ dflt_code ->
646 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
649 mkJoin :: AbstractC -> CLabel -> AbstractC
651 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
655 %---------------------------------------------------------------------------
657 This answers the question: Can the code fall through to the next
658 line(s) of code? This errs towards saying True if it can't choose,
659 because it is used for eliminating needless jumps. In other words, if
660 you might possibly {\em not} jump, then say yes to falling through.
663 mightFallThrough :: AbstractC -> Bool
665 mightFallThrough absC = ft absC True
667 ft AbsCNop if_empty = if_empty
669 ft (CJump _) if_empty = False
670 ft (CReturn _ _) if_empty = False
671 ft (CSwitch _ alts deflt) if_empty
672 = ft deflt if_empty ||
673 or [ft alt if_empty | (_,alt) <- alts]
675 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
676 ft _ if_empty = if_empty
678 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
679 fallThroughAbsC (AbsCStmts c1 c2)
680 = case nonemptyAbsC c2 of
681 Nothing -> fallThroughAbsC c1
682 Just x -> fallThroughAbsC x
683 fallThroughAbsC (CJump _) = False
684 fallThroughAbsC (CReturn _ _) = False
685 fallThroughAbsC (CSwitch _ choices deflt)
686 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
687 || or (map (fallThroughAbsC . snd) choices)
688 fallThroughAbsC other = True
690 isEmptyAbsC :: AbstractC -> Bool
691 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
692 ================= End of old, quadratic, algorithm -}