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 -- 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 closure_info _ _)
82 = genCodeStaticClosure stmt `thenUs` \ code ->
83 returnUs ( StSegment DataSegment
84 : StLabel lbl : code []
87 gentopcode stmt@(CRetVector lbl amodes srt liveness)
88 = returnUs ( StSegment TextSegment
94 table = map amodeToStix (mkVecInfoTable amodes srt liveness)
96 gentopcode stmt@(CRetDirect uniq absC srt liveness)
97 = gencode absC `thenUs` \ code ->
98 returnUs ( StSegment TextSegment
104 info_lbl = mkReturnInfoLabel uniq
105 ret_lbl = mkReturnPtLabel uniq
106 table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
108 gentopcode stmt@(CClosureInfoAndCode cl_info entry)
109 = gencode entry `thenUs` \ slow_code ->
110 returnUs ( StSegment TextSegment
111 : StData PtrRep table
113 : StFunBegin entry_lbl
114 : slow_code [StFunEnd entry_lbl])
116 entry_lbl = entryLabelFromCI cl_info
117 info_lbl = infoTableLabelFromCI cl_info
118 table = map amodeToStix (mkInfoTable cl_info)
120 gentopcode stmt@(CSRT lbl closures)
121 = returnUs [ StSegment TextSegment
123 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
126 mk_StCLbl_for_SRT :: CLabel -> StixExpr
127 mk_StCLbl_for_SRT label
129 = StIndex Int8Rep (StCLbl label) (StInt 1)
133 gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
135 [ StSegment TextSegment
137 , StData WordRep (map StInt (toInteger size : map toInteger mask))
140 gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap)
142 [ StSegment TextSegment
145 StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) :
146 map StInt (toInteger len : map toInteger bitmap)
150 gentopcode stmt@(CClosureTbl tycon)
151 = returnUs [ StSegment TextSegment
152 , StLabel (mkClosureTblLabel tycon)
153 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName)
154 (tyConDataCons tycon) )
157 gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
158 = gencode absC `thenUs` \ code ->
159 getUniqLabelNCG `thenUs` \ tmp_lbl ->
160 getUniqLabelNCG `thenUs` \ flag_lbl ->
161 returnUs ( StSegment DataSegment
163 : StData IntRep [StInt 0]
164 : StSegment TextSegment
166 : StJump NoDestInfo (StCLbl lbl)
168 : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
169 [StInd IntRep (StCLbl flag_lbl),
171 : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
174 , StAssignReg PtrRep stgSp
175 (StIndex PtrRep (StReg stgSp) (StInt (-1)))
176 , StJump NoDestInfo (StInd WordRep (StReg stgSp))
180 = gencode absC `thenUs` \ code ->
181 returnUs (StSegment TextSegment : code [])
188 -> UniqSM StixTreeList
190 genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
191 = returnUs (\xs -> table ++ xs)
193 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
194 foldr do_one_amode [] amodes
196 do_one_amode amode rest
197 | rep == VoidRep = rest
198 | otherwise = StData (promote_to_word rep) [a2stix amode] : rest
200 rep = getAmodeRep amode
202 -- We need to promote any item smaller than a word to a word
204 | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
208 Now the individual AbstractC statements.
214 -> UniqSM StixTreeList
218 @AbsCNop@s just disappear.
222 gencode AbsCNop = returnUs id
226 Split markers just insert a __stg_split_marker, which is caught by the
227 split-mangler later on and used to split the assembly into chunks.
232 | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
233 | otherwise = returnUs id
237 AbstractC instruction sequences are handled individually, and the
238 resulting StixTreeLists are joined together.
242 gencode (AbsCStmts c1 c2)
243 = gencode c1 `thenUs` \ b1 ->
244 gencode c2 `thenUs` \ b2 ->
247 gencode (CSequential stuff)
251 foo (s:ss) = gencode s `thenUs` \ stix ->
252 foo ss `thenUs` \ stixes ->
253 returnUs (stix . stixes)
257 Initialising closure headers in the heap...a fairly complex ordeal if
258 done properly. For now, we just set the info pointer, but we should
259 really take a peek at the flags to determine whether or not there are
260 other things to be done (setting cost centres, age headers, global
265 gencode (CInitHdr cl_info reg_rel _ _)
268 lbl = infoTableLabelFromCI cl_info
270 returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
278 gencode (CCheck macro args assts)
279 = gencode assts `thenUs` \assts_stix ->
280 checkCode macro args assts_stix
284 Assignment, the curse of von Neumann, is the center of the code we
285 produce. In most cases, the type of the assignment is determined
286 by the type of the destination. However, when the destination can
287 have mixed types, the type of the assignment is ``StgWord'' (we use
288 PtrRep for lack of anything better). Think: do we also want a cast
289 of the source? Be careful about floats/doubles.
293 gencode (CAssign lhs rhs)
297 = let -- This is a Hack. Should be cleaned up.
299 pk' | ncg_target_is_32bit && is64BitRep lhs_rep
302 = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep)
308 returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
310 lhs_rep = getAmodeRep lhs
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 NoDestInfo (a2stix dest) : xs)
327 gencode (CFallThrough (CLbl lbl _))
328 = returnUs (\xs -> StFallThrough lbl : xs)
330 gencode (CReturn dest DirectReturn)
331 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
333 gencode (CReturn table (StaticVectoredReturn n))
334 = returnUs (\xs -> StJump NoDestInfo dest : xs)
336 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
337 (StInt (toInteger (-n-retItblSize-1))))
339 gencode (CReturn table (DynamicVectoredReturn am))
340 = returnUs (\xs -> StJump NoDestInfo dest : xs)
342 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
343 dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
344 StInt (toInteger (retItblSize+1))]
348 Now the PrimOps, some of which may need caller-saves register wrappers.
351 gencode (COpStmt results (StgFCallOp fcall _) args vols)
352 = ASSERT( null vols )
353 foreignCallCode (nonVoid results) fcall (nonVoid args)
355 gencode (COpStmt results (StgPrimOp op) args vols)
356 = panic "AbsCStixGen.gencode: un-translated PrimOp"
358 gencode (CMachOpStmt res mop args vols)
359 = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res)
360 (StMachOp mop (map a2stix args))
365 Now the dreaded conditional jump.
367 Now the if statement. Almost *all* flow of control are of this form.
369 if (am==lit) { absC } else { absCdef }
383 gencode (CSwitch discrim alts deflt)
387 [(tag,alt_code)] -> case maybe_empty_deflt of
388 Nothing -> gencode alt_code
389 Just dc -> mkIfThenElse discrim tag alt_code dc
391 [(tag1@(MachInt i1), alt_code1),
392 (tag2@(MachInt i2), alt_code2)]
393 | deflt_is_empty && i1 == 0 && i2 == 1
394 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
395 | deflt_is_empty && i1 == 1 && i2 == 0
396 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
398 -- If the @discrim@ is simple, then this unfolding is safe.
399 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
401 -- Otherwise, we need to do a bit of work.
402 other -> getUniqueUs `thenUs` \ u ->
404 (CAssign (CTemp u pk) discrim)
405 (CSwitch (CTemp u pk) alts deflt))
408 maybe_empty_deflt = nonemptyAbsC deflt
409 deflt_is_empty = case maybe_empty_deflt of
413 pk = getAmodeRep discrim
415 simple_discrim = case discrim of
423 Finally, all of the disgusting AbstractC macros.
427 gencode (CMacroStmt macro args) = macroCode macro (map amodeToStix args)
429 gencode (CCallProfCtrMacro macro _)
430 = returnUs (\xs -> StComment macro : xs)
432 gencode (CCallProfCCMacro macro _)
433 = returnUs (\xs -> StComment macro : xs)
435 gencode CCallTypedef{} = returnUs id
438 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
440 nonVoid = filter ((/= VoidRep) . getAmodeRep)
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 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
484 && highTag - lowTag < toInteger (2 * choices)
486 mkJumpTable am' sortedAlts lowTag highTag udlbl
488 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
490 `thenUs` \ alt_code ->
491 gencode absC `thenUs` \ dflt_code ->
493 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
496 floating = isFloatingRep (getAmodeRep am)
497 choices = length alts
499 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
500 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
501 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
502 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
506 We use jump tables when doing an integer switch on a relatively dense
507 list of alternatives. We expect to be given a list of alternatives,
508 sorted by tag, and a range of values for which we are to generate a
509 table. Of course, the tags of the alternatives should lie within the
510 indicated range. The alternatives need not cover the range; a default
511 target is provided for the missing alternatives.
513 If a join is necessary after the switch, the alternatives should
514 already finish with a jump to the join point.
519 :: StixTree -- discriminant
520 -> [(Literal, AbstractC)] -- alternatives
521 -> Integer -- low tag
522 -> Integer -- high tag
523 -> CLabel -- default label
524 -> UniqSM StixTreeList
527 mkJumpTable am alts lowTag highTag dflt
528 = getUniqLabelNCG `thenUs` \ utlbl ->
529 mapUs genLabel alts `thenUs` \ branches ->
530 let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
531 cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
533 offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
534 dsts = DestInfo (dflt : map fst branches)
536 jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
538 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
540 mapUs mkBranch branches `thenUs` \ alts ->
542 returnUs (\xs -> cjmpLo : cjmpHi : jump :
543 StSegment DataSegment : tlbl : table :
544 StSegment TextSegment : foldr1 (.) alts xs)
547 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
549 mkBranch (lbl,(_,alt)) =
550 gencode alt `thenUs` \ alt_code ->
551 returnUs (\xs -> StLabel lbl : alt_code xs)
553 mkTable _ [] tbl = reverse tbl
554 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
555 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
556 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
557 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
561 We generate binary comparison trees when a jump table is inappropriate.
562 We expect to be given a list of alternatives, sorted by tag, and for
563 convenience, the length of the alternative list. We recursively break
564 the list in half and do a comparison on the first tag of the second half
565 of the list. (Odd lists are broken so that the second half of the list
566 is longer.) We can handle either integer or floating kind alternatives,
567 so long as they are not mixed. (We assume that the type of the discriminant
568 determines the type of the alternatives.)
570 As with the jump table approach, if a join is necessary after the switch, the
571 alternatives should already finish with a jump to the join point.
576 :: StixTree -- discriminant
577 -> Bool -- floating point?
578 -> [(Literal, AbstractC)] -- alternatives
579 -> Int -- number of choices
580 -> Literal -- low tag
581 -> Literal -- high tag
582 -> CLabel -- default code label
583 -> UniqSM StixTreeList
586 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
587 | rangeOfOne = gencode alt
589 = let tag' = a2stix (CLit tag)
590 cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
591 test = StMachOp cmpOp [am, tag']
592 cjmp = StCondJump udlbl test
594 gencode alt `thenUs` \ alt_code ->
595 returnUs (\xs -> cjmp : alt_code xs)
598 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
599 -- When there is only one possible tag left in range, we skip the comparison
601 mkBinaryTree am floating alts choices lowTag highTag udlbl
602 = getUniqLabelNCG `thenUs` \ uhlbl ->
603 let tag' = a2stix (CLit splitTag)
604 cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
605 test = StMachOp cmpOp [am, tag']
606 cjmp = StCondJump uhlbl test
608 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
609 `thenUs` \ lo_code ->
610 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
611 `thenUs` \ hi_code ->
613 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
616 half = choices `div` 2
617 (alts_lo, alts_hi) = splitAt half alts
618 splitTag = fst (head alts_hi)
625 :: CAddrMode -- discriminant
627 -> AbstractC -- if-part
628 -> AbstractC -- else-part
629 -> UniqSM StixTreeList
632 mkIfThenElse discrim tag alt deflt
633 = getUniqLabelNCG `thenUs` \ ujlbl ->
634 getUniqLabelNCG `thenUs` \ utlbl ->
635 let discrim' = a2stix discrim
636 tag' = a2stix (CLit tag)
637 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
638 test = StMachOp cmpOp [discrim', tag']
639 cjmp = StCondJump utlbl test
643 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
644 gencode deflt `thenUs` \ dflt_code ->
645 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
648 mkJoin :: AbstractC -> CLabel -> AbstractC
650 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
654 %---------------------------------------------------------------------------
656 This answers the question: Can the code fall through to the next
657 line(s) of code? This errs towards saying True if it can't choose,
658 because it is used for eliminating needless jumps. In other words, if
659 you might possibly {\em not} jump, then say yes to falling through.
662 mightFallThrough :: AbstractC -> Bool
664 mightFallThrough absC = ft absC True
666 ft AbsCNop if_empty = if_empty
668 ft (CJump _) if_empty = False
669 ft (CReturn _ _) if_empty = False
670 ft (CSwitch _ alts deflt) if_empty
671 = ft deflt if_empty ||
672 or [ft alt if_empty | (_,alt) <- alts]
674 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
675 ft _ if_empty = if_empty
677 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
678 fallThroughAbsC (AbsCStmts c1 c2)
679 = case nonemptyAbsC c2 of
680 Nothing -> fallThroughAbsC c1
681 Just x -> fallThroughAbsC x
682 fallThroughAbsC (CJump _) = False
683 fallThroughAbsC (CReturn _ _) = False
684 fallThroughAbsC (CSwitch _ choices deflt)
685 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
686 || or (map (fallThroughAbsC . snd) choices)
687 fallThroughAbsC other = True
689 isEmptyAbsC :: AbstractC -> Bool
690 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
691 ================= End of old, quadratic, algorithm -}