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 Constants ( wORD_SIZE, bITMAP_BITS_SHIFT )
38 import DataCon ( dataConWrapId )
39 import Name ( NamedThing(..) )
40 import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
41 import Outputable ( assertPanic )
42 import BitSet ( BitSet, intBS )
45 --import TRACE ( trace )
46 --import Outputable ( showSDoc )
47 --import MachOp ( pprMachOp )
49 #include "nativeGen/NCG.h"
52 For each independent chunk of AbstractC code, we generate a list of
53 @StixTree@s, where each tree corresponds to a single Stix instruction.
54 We leave the chunks separated so that register allocation can be
55 performed locally within the chunk.
58 genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]
64 a2stix' = amodeToStix'
65 volsaves = volatileSaves
66 volrestores = volatileRestores
67 macro_code = macroCode
68 -- real code follows... ---------
71 Here we handle top-level things, like @CCodeBlock@s and
81 gentopcode (CCodeBlock lbl absC)
82 = gencode absC `thenUs` \ code ->
83 returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
85 gentopcode stmt@(CStaticClosure lbl closure_info _ _)
86 = genCodeStaticClosure stmt `thenUs` \ code ->
89 then StSegment DataSegment
90 : StLabel lbl : code []
91 else StSegment DataSegment
92 : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
93 : StLabel lbl : code []
96 gentopcode stmt@(CRetVector lbl amodes srt liveness)
97 = returnUs ( StSegment TextSegment
103 table = map amodeToStix (mkVecInfoTable amodes srt liveness)
105 gentopcode stmt@(CRetDirect uniq absC srt liveness)
106 = gencode absC `thenUs` \ code ->
107 returnUs ( StSegment TextSegment
108 : StData PtrRep table
113 info_lbl = mkReturnInfoLabel uniq
114 ret_lbl = mkReturnPtLabel uniq
115 table = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
117 gentopcode stmt@(CClosureInfoAndCode cl_info entry)
118 = gencode entry `thenUs` \ slow_code ->
119 returnUs ( StSegment TextSegment
120 : StData PtrRep table
122 : StFunBegin entry_lbl
123 : slow_code [StFunEnd entry_lbl])
125 entry_lbl = entryLabelFromCI cl_info
126 info_lbl = infoTableLabelFromCI cl_info
127 table = map amodeToStix (mkInfoTable cl_info)
129 gentopcode stmt@(CSRT lbl closures)
130 = returnUs [ StSegment TextSegment
132 , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
135 mk_StCLbl_for_SRT :: CLabel -> StixExpr
136 mk_StCLbl_for_SRT label
138 = StIndex Int8Rep (StCLbl label) (StInt 1)
142 gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
145 [ StSegment TextSegment
147 , StData WordRep (map StInt (toInteger size : bitmapToIntegers mask))
152 -- ToDo: translate out bitmaps earlier, like info tables
153 isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
154 mAX_SMALL_BITMAP_SIZE = (wORD_SIZE * 8) - bITMAP_BITS_SHIFT
156 gentopcode stmt@(CClosureTbl tycon)
157 = returnUs [ StSegment TextSegment
158 , StLabel (mkClosureTblLabel tycon)
159 , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
160 (tyConDataCons tycon) )
163 gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
164 = gencode absC `thenUs` \ code ->
165 getUniqLabelNCG `thenUs` \ tmp_lbl ->
166 getUniqLabelNCG `thenUs` \ flag_lbl ->
167 returnUs ( StSegment DataSegment
169 : StData IntRep [StInt 0]
170 : StSegment TextSegment
172 : StJump NoDestInfo (StCLbl lbl)
174 : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
175 [StInd IntRep (StCLbl flag_lbl),
177 : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
180 , StAssignReg PtrRep stgSp
181 (StIndex PtrRep (StReg stgSp) (StInt (-1)))
182 , StJump NoDestInfo (StInd WordRep (StReg stgSp))
186 = gencode absC `thenUs` \ code ->
187 returnUs (StSegment TextSegment : code [])
194 -> UniqSM StixTreeList
196 genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
197 = returnUs (\xs -> table ++ xs)
199 table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] :
200 foldr do_one_amode [] amodes
202 do_one_amode amode rest
203 | rep == VoidRep = rest
204 | otherwise = StData (promote_to_word rep) [a2stix amode] : rest
206 rep = getAmodeRep amode
208 -- We need to promote any item smaller than a word to a word
210 | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep = pk
214 Now the individual AbstractC statements.
220 -> UniqSM StixTreeList
224 @AbsCNop@s just disappear.
228 gencode AbsCNop = returnUs id
232 Split markers just insert a __stg_split_marker, which is caught by the
233 split-mangler later on and used to split the assembly into chunks.
238 | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
239 | otherwise = returnUs id
243 AbstractC instruction sequences are handled individually, and the
244 resulting StixTreeLists are joined together.
248 gencode (AbsCStmts c1 c2)
249 = gencode c1 `thenUs` \ b1 ->
250 gencode c2 `thenUs` \ b2 ->
253 gencode (CSequential stuff)
257 foo (s:ss) = gencode s `thenUs` \ stix ->
258 foo ss `thenUs` \ stixes ->
259 returnUs (stix . stixes)
263 Initialising closure headers in the heap...a fairly complex ordeal if
264 done properly. For now, we just set the info pointer, but we should
265 really take a peek at the flags to determine whether or not there are
266 other things to be done (setting cost centres, age headers, global
271 gencode (CInitHdr cl_info reg_rel _ _)
274 lbl = infoTableLabelFromCI cl_info
276 returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
284 gencode (CCheck macro args assts)
285 = gencode assts `thenUs` \assts_stix ->
286 checkCode macro args assts_stix
290 Assignment, the curse of von Neumann, is the center of the code we
291 produce. In most cases, the type of the assignment is determined
292 by the type of the destination. However, when the destination can
293 have mixed types, the type of the assignment is ``StgWord'' (we use
294 PtrRep for lack of anything better). Think: do we also want a cast
295 of the source? Be careful about floats/doubles.
299 gencode (CAssign lhs rhs)
303 = let -- This is a Hack. Should be cleaned up.
305 pk' | ncg_target_is_32bit && is64BitRep lhs_rep
308 = if mixedTypeLocn lhs && not (isFloatingRep lhs_rep)
314 returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
316 lhs_rep = getAmodeRep lhs
320 Unconditional jumps, including the special ``enter closure'' operation.
321 Note that the new entry convention requires that we load the InfoPtr (R2)
322 with the address of the info table before jumping to the entry code for Node.
324 For a vectored return, we must subtract the size of the info table to
325 get at the return vector. This depends on the size of the info table,
326 which varies depending on whether we're profiling etc.
331 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
333 gencode (CFallThrough (CLbl lbl _))
334 = returnUs (\xs -> StFallThrough lbl : xs)
336 gencode (CReturn dest DirectReturn)
337 = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
339 gencode (CReturn table (StaticVectoredReturn n))
340 = returnUs (\xs -> StJump NoDestInfo dest : xs)
342 dest = StInd PtrRep (StIndex PtrRep (a2stix table)
343 (StInt (toInteger (-n-retItblSize-1))))
345 gencode (CReturn table (DynamicVectoredReturn am))
346 = returnUs (\xs -> StJump NoDestInfo dest : xs)
348 dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
349 dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am],
350 StInt (toInteger (retItblSize+1))]
354 Now the PrimOps, some of which may need caller-saves register wrappers.
357 gencode (COpStmt results (StgFCallOp fcall _) args vols)
358 = ASSERT( null vols )
359 foreignCallCode (nonVoid results) fcall (nonVoid args)
361 gencode (COpStmt results (StgPrimOp op) args vols)
362 = panic "AbsCStixGen.gencode: un-translated PrimOp"
364 gencode (CMachOpStmt res mop args vols)
365 = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res)
366 (StMachOp mop (map a2stix args))
371 Now the dreaded conditional jump.
373 Now the if statement. Almost *all* flow of control are of this form.
375 if (am==lit) { absC } else { absCdef }
389 gencode (CSwitch discrim alts deflt)
393 [(tag,alt_code)] -> case maybe_empty_deflt of
394 Nothing -> gencode alt_code
395 Just dc -> mkIfThenElse discrim tag alt_code dc
397 [(tag1@(MachInt i1), alt_code1),
398 (tag2@(MachInt i2), alt_code2)]
399 | deflt_is_empty && i1 == 0 && i2 == 1
400 -> mkIfThenElse discrim tag1 alt_code1 alt_code2
401 | deflt_is_empty && i1 == 1 && i2 == 0
402 -> mkIfThenElse discrim tag2 alt_code2 alt_code1
404 -- If the @discrim@ is simple, then this unfolding is safe.
405 other | simple_discrim -> mkSimpleSwitches discrim alts deflt
407 -- Otherwise, we need to do a bit of work.
408 other -> getUniqueUs `thenUs` \ u ->
410 (CAssign (CTemp u pk) discrim)
411 (CSwitch (CTemp u pk) alts deflt))
414 maybe_empty_deflt = nonemptyAbsC deflt
415 deflt_is_empty = case maybe_empty_deflt of
419 pk = getAmodeRep discrim
421 simple_discrim = case discrim of
429 Finally, all of the disgusting AbstractC macros.
433 gencode (CMacroStmt macro args) = macro_code macro args
435 gencode (CCallProfCtrMacro macro _)
436 = returnUs (\xs -> StComment macro : xs)
438 gencode (CCallProfCCMacro macro _)
439 = returnUs (\xs -> StComment macro : xs)
441 gencode CCallTypedef{} = returnUs id
444 = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
446 nonVoid = filter ((/= VoidRep) . getAmodeRep)
449 Here, we generate a jump table if there are more than four (integer)
450 alternatives and the jump table occupancy is greater than 50%.
451 Otherwise, we generate a binary comparison tree. (Perhaps this could
456 intTag :: Literal -> Integer
457 intTag (MachChar c) = toInteger c
458 intTag (MachInt i) = i
459 intTag (MachWord w) = intTag (word2IntLit (MachWord w))
460 intTag _ = panic "intTag"
462 fltTag :: Literal -> Rational
464 fltTag (MachFloat f) = f
465 fltTag (MachDouble d) = d
466 fltTag x = pprPanic "fltTag" (ppr x)
470 :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
471 -> UniqSM StixTreeList
473 mkSimpleSwitches am alts absC
474 = getUniqLabelNCG `thenUs` \ udlbl ->
475 getUniqLabelNCG `thenUs` \ ujlbl ->
477 joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
478 sortedAlts = naturalMergeSortLe leAlt joinedAlts
479 -- naturalMergeSortLe, because we often get sorted alts to begin with
481 lowTag = intTag (fst (head sortedAlts))
482 highTag = intTag (fst (last sortedAlts))
484 -- lowest and highest possible values the discriminant could take
485 lowest = if floating then targetMinDouble else targetMinInt
486 highest = if floating then targetMaxDouble else targetMaxInt
489 if not floating && choices > 4
490 && highTag - lowTag < toInteger (2 * choices)
492 mkJumpTable am' sortedAlts lowTag highTag udlbl
494 mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
496 `thenUs` \ alt_code ->
497 gencode absC `thenUs` \ dflt_code ->
499 returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
502 floating = isFloatingRep (getAmodeRep am)
503 choices = length alts
505 (x@(MachChar _),_) `leAlt` (y,_) = intTag x <= intTag y
506 (x@(MachInt _), _) `leAlt` (y,_) = intTag x <= intTag y
507 (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
508 (x,_) `leAlt` (y,_) = fltTag x <= fltTag y
512 We use jump tables when doing an integer switch on a relatively dense
513 list of alternatives. We expect to be given a list of alternatives,
514 sorted by tag, and a range of values for which we are to generate a
515 table. Of course, the tags of the alternatives should lie within the
516 indicated range. The alternatives need not cover the range; a default
517 target is provided for the missing alternatives.
519 If a join is necessary after the switch, the alternatives should
520 already finish with a jump to the join point.
525 :: StixTree -- discriminant
526 -> [(Literal, AbstractC)] -- alternatives
527 -> Integer -- low tag
528 -> Integer -- high tag
529 -> CLabel -- default label
530 -> UniqSM StixTreeList
533 mkJumpTable am alts lowTag highTag dflt
534 = getUniqLabelNCG `thenUs` \ utlbl ->
535 mapUs genLabel alts `thenUs` \ branches ->
536 let cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
537 cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])
539 offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
540 dsts = DestInfo (dflt : map fst branches)
542 jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
544 table = StData PtrRep (mkTable branches [lowTag..highTag] [])
546 mapUs mkBranch branches `thenUs` \ alts ->
548 returnUs (\xs -> cjmpLo : cjmpHi : jump :
549 StSegment DataSegment : tlbl : table :
550 StSegment TextSegment : foldr1 (.) alts xs)
553 genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
555 mkBranch (lbl,(_,alt)) =
556 gencode alt `thenUs` \ alt_code ->
557 returnUs (\xs -> StLabel lbl : alt_code xs)
559 mkTable _ [] tbl = reverse tbl
560 mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
561 mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
562 | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
563 | otherwise = mkTable alts xs (StCLbl dflt : tbl)
567 We generate binary comparison trees when a jump table is inappropriate.
568 We expect to be given a list of alternatives, sorted by tag, and for
569 convenience, the length of the alternative list. We recursively break
570 the list in half and do a comparison on the first tag of the second half
571 of the list. (Odd lists are broken so that the second half of the list
572 is longer.) We can handle either integer or floating kind alternatives,
573 so long as they are not mixed. (We assume that the type of the discriminant
574 determines the type of the alternatives.)
576 As with the jump table approach, if a join is necessary after the switch, the
577 alternatives should already finish with a jump to the join point.
582 :: StixTree -- discriminant
583 -> Bool -- floating point?
584 -> [(Literal, AbstractC)] -- alternatives
585 -> Int -- number of choices
586 -> Literal -- low tag
587 -> Literal -- high tag
588 -> CLabel -- default code label
589 -> UniqSM StixTreeList
592 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
593 | rangeOfOne = gencode alt
595 = let tag' = a2stix (CLit tag)
596 cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
597 test = StMachOp cmpOp [am, tag']
598 cjmp = StCondJump udlbl test
600 gencode alt `thenUs` \ alt_code ->
601 returnUs (\xs -> cjmp : alt_code xs)
604 rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
605 -- When there is only one possible tag left in range, we skip the comparison
607 mkBinaryTree am floating alts choices lowTag highTag udlbl
608 = getUniqLabelNCG `thenUs` \ uhlbl ->
609 let tag' = a2stix (CLit splitTag)
610 cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
611 test = StMachOp cmpOp [am, tag']
612 cjmp = StCondJump uhlbl test
614 mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
615 `thenUs` \ lo_code ->
616 mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
617 `thenUs` \ hi_code ->
619 returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
622 half = choices `div` 2
623 (alts_lo, alts_hi) = splitAt half alts
624 splitTag = fst (head alts_hi)
631 :: CAddrMode -- discriminant
633 -> AbstractC -- if-part
634 -> AbstractC -- else-part
635 -> UniqSM StixTreeList
638 mkIfThenElse discrim tag alt deflt
639 = getUniqLabelNCG `thenUs` \ ujlbl ->
640 getUniqLabelNCG `thenUs` \ utlbl ->
641 let discrim' = a2stix discrim
642 tag' = a2stix (CLit tag)
643 cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
644 test = StMachOp cmpOp [discrim', tag']
645 cjmp = StCondJump utlbl test
649 gencode (mkJoin alt ujlbl) `thenUs` \ alt_code ->
650 gencode deflt `thenUs` \ dflt_code ->
651 returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
654 mkJoin :: AbstractC -> CLabel -> AbstractC
656 | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
660 %---------------------------------------------------------------------------
663 bitmapToIntegers :: [BitSet] -> [Integer]
664 bitmapToIntegers = bundle . map (toInteger . intBS)
666 #if BYTES_PER_WORD == 4
670 bundle is = case splitAt (BYTES_PER_WORD/4) is of
672 ( foldr1 (\x y -> x + 4294967296 * y)
673 [x `mod` 4294967296 | x <- these]
679 %---------------------------------------------------------------------------
681 This answers the question: Can the code fall through to the next
682 line(s) of code? This errs towards saying True if it can't choose,
683 because it is used for eliminating needless jumps. In other words, if
684 you might possibly {\em not} jump, then say yes to falling through.
687 mightFallThrough :: AbstractC -> Bool
689 mightFallThrough absC = ft absC True
691 ft AbsCNop if_empty = if_empty
693 ft (CJump _) if_empty = False
694 ft (CReturn _ _) if_empty = False
695 ft (CSwitch _ alts deflt) if_empty
696 = ft deflt if_empty ||
697 or [ft alt if_empty | (_,alt) <- alts]
699 ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
700 ft _ if_empty = if_empty
702 {- Old algorithm, which called nonemptyAbsC for every subexpression! =========
703 fallThroughAbsC (AbsCStmts c1 c2)
704 = case nonemptyAbsC c2 of
705 Nothing -> fallThroughAbsC c1
706 Just x -> fallThroughAbsC x
707 fallThroughAbsC (CJump _) = False
708 fallThroughAbsC (CReturn _ _) = False
709 fallThroughAbsC (CSwitch _ choices deflt)
710 = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
711 || or (map (fallThroughAbsC . snd) choices)
712 fallThroughAbsC other = True
714 isEmptyAbsC :: AbstractC -> Bool
715 isEmptyAbsC = not . maybeToBool . nonemptyAbsC
716 ================= End of old, quadratic, algorithm -}