AbsCStixGen.lhs 22.3 KB
Newer Older
1
%
2
% (c) The AQUA Project, Glasgow University, 1993-1998
3
4
5
%

\begin{code}
6
module AbsCStixGen ( genCodeAbstractC ) where
7

8
9
10
#include "HsVersions.h"

import Ratio	( Rational )
11
12

import AbsCSyn
13
14
15
16
import Stix
import MachMisc

import AbsCUtils	( getAmodeRep, mixedTypeLocn,
17
			  nonemptyAbsC, mkAbsCStmts
18
			)
19
import PprAbsC          ( dumpRealC )
20
21
22
23
import SMRep		( fixedItblSize, 
			  rET_SMALL, rET_BIG, 
			  rET_VEC_SMALL, rET_VEC_BIG 
			)
24
import Constants   	( mIN_UPD_SIZE )
25
import CLabel           ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
26
                          mkClosureTblLabel, mkClosureLabel,
27
			  labelDynamic, mkSplitMarkerLabel )
28
import ClosureInfo	( infoTableLabelFromCI, entryLabelFromCI,
29
30
			  fastLabelFromCI, closureUpdReqd,
			  staticClosureNeedsLink
31
			)
32
import Literal		( Literal(..), word2IntLit )
33
import Maybes	    	( maybeToBool )
34
import StgSyn		( StgOp(..) )
35
36
import PrimOp		( primOpNeedsWrapper, PrimOp(..) )
import PrimRep	    	( isFloatingRep, PrimRep(..) )
ken's avatar
ken committed
37
38
import StixInfo	    	( genCodeInfoTable, genBitmapInfoTable,
			  livenessIsSmall, bitmapToIntegers )
39
import StixMacro	( macroCode, checkCode )
40
import StixPrim		( primCode, foreignCallCode, amodeToStix, amodeToStix' )
41
import Outputable       ( pprPanic, ppr )
42
import UniqSupply	( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
43
44
import Util		( naturalMergeSortLe )
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 )
50
51
\end{code}

52
53
54
55
For each independent chunk of AbstractC code, we generate a list of
@StixTree@s, where each tree corresponds to a single Stix instruction.
We leave the chunks separated so that register allocation can be
performed locally within the chunk.
56
57

\begin{code}
58
genCodeAbstractC :: AbstractC -> UniqSM [StixTree]
59

60
genCodeAbstractC absC
61
  = gentopcode absC
62
 where
63
64
65
66
67
68
 a2stix      = amodeToStix
 a2stix'     = amodeToStix'
 volsaves    = volatileSaves
 volrestores = volatileRestores
 p2stix      = primCode
 macro_code  = macroCode
69
 -- real code follows... ---------
70
71
72
73
74
75
\end{code}

Here we handle top-level things, like @CCodeBlock@s and
@CClosureInfoTable@s.

\begin{code}
76
 {-
77
 genCodeTopAbsC
78
    :: AbstractC
79
    -> UniqSM [StixTree]
80
 -}
81

82
 gentopcode (CCodeBlock lbl absC)
83
  = gencode absC				`thenUs` \ code ->
84
    returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])
85

86
 gentopcode stmt@(CStaticClosure lbl _ _ _)
87
  = genCodeStaticClosure stmt			`thenUs` \ code ->
88
89
90
91
92
93
94
95
    returnUs (
       if   opt_Static
       then StSegment DataSegment 
            : StLabel lbl : code []
       else StSegment DataSegment 
            : StData PtrRep [StInt 0] -- DLLised world, need extra zero word
            : StLabel lbl : code []
    )
96

97
 gentopcode stmt@(CRetVector lbl _ _ _)
98
  = genCodeVecTbl stmt				`thenUs` \ code ->
99
100
101
102
103
104
105
106
107
108
109
    returnUs (StSegment TextSegment 
              : code [StLabel lbl, vtbl_post_label_word])
    where
       -- We put a dummy word after the vtbl label so as to ensure the label
       -- is in the same (Text) section as the vtbl it labels.  This is critical
       -- for ensuring the GC works correctly, although GC crashes due to
       -- misclassification are much more likely to show up in the interactive 
       -- system than in compile code.  For details see comment near line 1164 
       -- of ghc/driver/mangler/ghc-asm.lprl, which contains an analogous fix for 
       -- the mangled via-C route.
       vtbl_post_label_word = StData PtrRep [StInt 0]
110

111
112
113
114
115
116
117
118
 gentopcode stmt@(CRetDirect uniq absC srt liveness)
  = gencode absC				       `thenUs` \ code ->
    genBitmapInfoTable liveness srt closure_type False `thenUs` \ itbl ->
    returnUs (StSegment TextSegment : 
              itbl (StLabel lbl_info : StLabel lbl_ret : code []))
  where 
	lbl_info = mkReturnInfoLabel uniq
	lbl_ret  = mkReturnPtLabel uniq
ken's avatar
ken committed
119
 	closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
120

121
 gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
122
123

  | slow_is_empty
124
  = genCodeInfoTable stmt		`thenUs` \ itbl ->
125
    returnUs (StSegment TextSegment : itbl [])
126
127

  | otherwise
128
129
  = genCodeInfoTable stmt		`thenUs` \ itbl ->
    gencode slow			`thenUs` \ slow_code ->
130
131
    returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
	      slow_code [StFunEnd slow_lbl]))
132
133
134
135
  where
    slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
    slow_lbl = entryLabelFromCI cl_info

136
 gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) =
137
 -- ToDo: what if this is empty? ------------------------^^^^
138
139
140
    genCodeInfoTable stmt		`thenUs` \ itbl ->
    gencode slow			`thenUs` \ slow_code ->
    gencode fast			`thenUs` \ fast_code ->
141
142
143
    returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
	      slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
	      fast_code [StFunEnd fast_lbl])))
144
145
146
147
  where
    slow_lbl = entryLabelFromCI cl_info
    fast_lbl = fastLabelFromCI cl_info

148
149
150
 gentopcode stmt@(CSRT lbl closures)
  = returnUs [ StSegment TextSegment 
	     , StLabel lbl 
151
	     , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
152
	     ]
153
154
155
156
    where
       mk_StCLbl_for_SRT :: CLabel -> StixTree
       mk_StCLbl_for_SRT label
          | labelDynamic label
157
          = StIndex Int8Rep (StCLbl label) (StInt 1)
158
159
          | otherwise
          = StCLbl label
160
161

 gentopcode stmt@(CBitmap lbl mask)
ken's avatar
ken committed
162
163
164
165
166
167
168
  = returnUs $ case bitmapToIntegers mask of
	       mask'@(_:_:_) ->
		 [ StSegment TextSegment 
		 , StLabel lbl 
		 , StData WordRep (map StInt (toInteger (length mask') : mask'))
		 ]
	       _ -> []
169

170
171
172
 gentopcode stmt@(CClosureTbl tycon)
  = returnUs [ StSegment TextSegment
             , StLabel (mkClosureTblLabel tycon)
173
             , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId) 
174
175
176
                                      (tyConDataCons tycon) )
             ]

177
178
179
 gentopcode stmt@(CModuleInitBlock lbl absC)
  = gencode absC			`thenUs` \ code ->
    getUniqLabelNCG 	    	    	`thenUs` \ tmp_lbl ->
180
    getUniqLabelNCG 	    	    	`thenUs` \ flag_lbl ->
181
    returnUs ( StSegment DataSegment
182
	     : StLabel flag_lbl
183
184
185
	     : StData IntRep [StInt 0]
	     : StSegment TextSegment
	     : StLabel lbl
186
	     : StCondJump tmp_lbl (StPrim IntNeOp 	
187
				     [StInd IntRep (StCLbl flag_lbl),
188
				      StInt 0])
189
	     : StAssign IntRep (StInd IntRep (StCLbl flag_lbl)) (StInt 1)
190
191
	     : code 
	     [ StLabel tmp_lbl
192
193
	     , StAssign PtrRep stgSp
                        (StIndex PtrRep stgSp (StInt (-1)))
194
	     , StJump NoDestInfo (StInd WordRep stgSp)
195
196
	     ])

197
198
 gentopcode absC
  = gencode absC				`thenUs` \ code ->
199
    returnUs (StSegment TextSegment : code [])
200
201
202
\end{code}

\begin{code}
203
 {-
204
 genCodeVecTbl
205
    :: AbstractC
206
    -> UniqSM StixTreeList
207
 -}
208
 genCodeVecTbl (CRetVector lbl amodes srt liveness)
209
210
  = genBitmapInfoTable liveness srt closure_type True `thenUs` \itbl ->
    returnUs (\xs -> vectbl : itbl xs)
211
  where
212
    vectbl = StData PtrRep (reverse (map a2stix amodes))
ken's avatar
ken committed
213
    closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
214
215
216
217
218

\end{code}

\begin{code}
 {-
219
 genCodeStaticClosure
220
    :: AbstractC
221
    -> UniqSM StixTreeList
222
 -}
223
 genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
224
  = returnUs (\xs -> table ++ xs)
225
  where
226
    table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] : 
227
	    map do_one_amode amodes ++
228
	    [StData PtrRep (padding_wds ++ static_link)]
229

230
231
232
233
    do_one_amode amode 
       = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]

    -- We need to promote any item smaller than a word to a word
234
235
236
    promote_to_word pk 
       | sizeOf pk >= sizeOf IntRep  = pk
       | otherwise                   = IntRep
237

238
239
240
241
242
243
244
245
    upd_reqd = closureUpdReqd cl_info

    padding_wds
	| upd_reqd  = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
	| otherwise = []

    static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0]
	        | otherwise                                  = []
246
247
248

    zeros = StInt 0 : zeros

249
    {- needed??? --SDM
250
    	-- Watch out for VoidKinds...cf. PprAbsC
251
252
    amodeZeroVoid item
      | getAmodeRep item == VoidRep = StInt 0
253
      | otherwise = a2stix item
254
    -}
255
256
257
258

\end{code}

Now the individual AbstractC statements.
259

260
261
262
\begin{code}
 {-
 gencode
263
    :: AbstractC
264
    -> UniqSM StixTreeList
265
 -}
266
267
268
269
270
271
\end{code}

@AbsCNop@s just disappear.

\begin{code}

272
 gencode AbsCNop = returnUs id
273
274
275

\end{code}

276
277
Split markers just insert a __stg_split_marker, which is caught by the
split-mangler later on and used to split the assembly into chunks.
278
279
280

\begin{code}

281
282
283
 gencode CSplitMarker
   | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
   | otherwise             = returnUs id
284
285
286
287
288
289
290
291

\end{code}

AbstractC instruction sequences are handled individually, and the
resulting StixTreeLists are joined together.

\begin{code}

292
293
 gencode (AbsCStmts c1 c2)
  = gencode c1				`thenUs` \ b1 ->
294
295
    gencode c2				`thenUs` \ b2 ->
    returnUs (b1 . b2)
296
297
298
299
300
301
302
303
304
305
306

\end{code}

Initialising closure headers in the heap...a fairly complex ordeal if
done properly.	For now, we just set the info pointer, but we should
really take a peek at the flags to determine whether or not there are
other things to be done (setting cost centres, age headers, global
addresses, etc.)

\begin{code}

307
 gencode (CInitHdr cl_info reg_rel _)
308
  = let
309
	lhs = a2stix reg_rel
310
311
    	lbl = infoTableLabelFromCI cl_info
    in
312
	returnUs (\xs -> StAssign PtrRep (StInd PtrRep lhs) (StCLbl lbl) : xs)
313
314
315

\end{code}

316
317
318
319
320
321
322
323
324
325
Heap/Stack Checks.

\begin{code}

 gencode (CCheck macro args assts)
  = gencode assts `thenUs` \assts_stix ->
    checkCode macro args assts_stix

\end{code}

326
327
328
329
Assignment, the curse of von Neumann, is the center of the code we
produce.  In most cases, the type of the assignment is determined
by the type of the destination.  However, when the destination can
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
332
333
334
of the source?  Be careful about floats/doubles.

\begin{code}

335
 gencode (CAssign lhs rhs)
336
  | getAmodeRep lhs == VoidRep = returnUs id
337
338
  | otherwise
  = let pk = getAmodeRep lhs
339
    	pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
340
341
    	lhs' = a2stix lhs
    	rhs' = a2stix' rhs
342
    in
343
	returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
344
345
346
347
348
349
350

\end{code}

Unconditional jumps, including the special ``enter closure'' operation.
Note that the new entry convention requires that we load the InfoPtr (R2)
with the address of the info table before jumping to the entry code for Node.

351
352
353
354
For a vectored return, we must subtract the size of the info table to
get at the return vector.  This depends on the size of the info table,
which varies depending on whether we're profiling etc.

355
356
\begin{code}

357
 gencode (CJump dest)
358
  = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
359

360
361
 gencode (CFallThrough (CLbl lbl _))
  = returnUs (\xs -> StFallThrough lbl : xs)
362

363
 gencode (CReturn dest DirectReturn)
364
  = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
365

366
 gencode (CReturn table (StaticVectoredReturn n))
367
  = returnUs (\xs -> StJump NoDestInfo dest : xs)
368
369
  where
    dest = StInd PtrRep (StIndex PtrRep (a2stix table)
370
    	    	      	    	  (StInt (toInteger (-n-fixedItblSize-1))))
371

372
 gencode (CReturn table (DynamicVectoredReturn am))
373
  = returnUs (\xs -> StJump NoDestInfo dest : xs)
374
375
  where
    dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
376
377
    dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], 
			       StInt (toInteger (fixedItblSize+1))]
378
379
380
381
382
383

\end{code}

Now the PrimOps, some of which may need caller-saves register wrappers.

\begin{code}
384
385
386
 gencode (COpStmt results (StgFCallOp fcall _) args vols)
  = ASSERT( null vols )
    foreignCallCode (nonVoid results) fcall (nonVoid args)
387

388
 gencode (COpStmt results (StgPrimOp op) args vols)
389
  -- ToDo (ADR?): use that liveness mask
390
391
  | primOpNeedsWrapper op
  = let
392
	saves    = volsaves vols
393
    	restores = volrestores vols
394
    in
395
    	p2stix (nonVoid results) op (nonVoid args)
396
397
    	    	    	    		    	      	`thenUs` \ code ->
    	returnUs (\xs -> saves ++ code (restores ++ xs))
398

399
  | otherwise = p2stix (nonVoid results) op (nonVoid args)
400
401
402
403
404
405
406
\end{code}

Now the dreaded conditional jump.

Now the if statement.  Almost *all* flow of control are of this form.
@
	if (am==lit) { absC } else { absCdef }
407
@
408
409
410
	=>
@
	IF am = lit GOTO l1:
411
	absC
412
413
414
415
416
417
418
419
	jump l2:
   l1:
	absCdef
   l2:
@

\begin{code}

420
 gencode (CSwitch discrim alts deflt)
421
  = case alts of
422
      [] -> gencode deflt
423
424

      [(tag,alt_code)] -> case maybe_empty_deflt of
425
				Nothing -> gencode alt_code
426
				Just dc -> mkIfThenElse discrim tag alt_code dc
427

428
429
      [(tag1@(MachInt i1), alt_code1),
       (tag2@(MachInt i2), alt_code2)]
430
	| deflt_is_empty && i1 == 0 && i2 == 1
431
	-> mkIfThenElse discrim tag1 alt_code1 alt_code2
432
	| deflt_is_empty && i1 == 1 && i2 == 0
433
	-> mkIfThenElse discrim tag2 alt_code2 alt_code1
434

435
	-- If the @discrim@ is simple, then this unfolding is safe.
436
      other | simple_discrim -> mkSimpleSwitches discrim alts deflt
437
438

	-- Otherwise, we need to do a bit of work.
439
      other ->  getUniqueUs		      	  `thenUs` \ u ->
440
		gencode (AbsCStmts
441
442
		(CAssign (CTemp u pk) discrim)
		(CSwitch (CTemp u pk) alts deflt))
443
444
445
446
447
448
449

  where
    maybe_empty_deflt = nonemptyAbsC deflt
    deflt_is_empty = case maybe_empty_deflt of
			Nothing -> True
			Just _  -> False

450
    pk = getAmodeRep discrim
451
452
453
454
455
456
457
458
459
460
461
462
463

    simple_discrim = case discrim of
			CReg _    -> True
			CTemp _ _ -> True
			other	  -> False
\end{code}



Finally, all of the disgusting AbstractC macros.

\begin{code}

464
 gencode (CMacroStmt macro args) = macro_code macro args
465

466
467
 gencode (CCallProfCtrMacro macro _)
  = returnUs (\xs -> StComment macro : xs)
468

469
470
 gencode (CCallProfCCMacro macro _)
  = returnUs (\xs -> StComment macro : xs)
471

sof's avatar
sof committed
472
473
 gencode CCallTypedef{} = returnUs id

474
475
 gencode other
  = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
476
477

 nonVoid = filter ((/= VoidRep) . getAmodeRep)
478
479
\end{code}

480
481
482
483
Here, we generate a jump table if there are more than four (integer)
alternatives and the jump table occupancy is greater than 50%.
Otherwise, we generate a binary comparison tree.  (Perhaps this could
be tuned.)
484
485
486

\begin{code}

487
 intTag :: Literal -> Integer
488
 intTag (MachChar c)  = toInteger c
489
490
491
 intTag (MachInt i)   = i
 intTag (MachWord w)  = intTag (word2IntLit (MachWord w))
 intTag _             = panic "intTag"
492

493
 fltTag :: Literal -> Rational
494

495
 fltTag (MachFloat f)  = f
496
 fltTag (MachDouble d) = d
497
 fltTag x              = pprPanic "fltTag" (ppr x)
498

499
 {-
500
 mkSimpleSwitches
501
    :: CAddrMode -> [(Literal,AbstractC)] -> AbstractC
502
    -> UniqSM StixTreeList
503
 -}
504
505
 mkSimpleSwitches am alts absC
  = getUniqLabelNCG 	    	    	    	    	`thenUs` \ udlbl ->
506
    getUniqLabelNCG 	    	    	    	    	`thenUs` \ ujlbl ->
507
    let am' = a2stix am
508
509
510
511
512
513
514
515
516
517
518
519
    	joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
    	sortedAlts = naturalMergeSortLe leAlt joinedAlts
    	    	     -- naturalMergeSortLe, because we often get sorted alts to begin with

    	lowTag = intTag (fst (head sortedAlts))
    	highTag = intTag (fst (last sortedAlts))

    	-- lowest and highest possible values the discriminant could take
    	lowest = if floating then targetMinDouble else targetMinInt
    	highest = if floating then targetMaxDouble else targetMaxInt
    in
    	(
520
521
522
    	if  not floating && choices > 4 
            && highTag - lowTag < toInteger (2 * choices)
        then
523
    	    mkJumpTable am' sortedAlts lowTag highTag udlbl
524
    	else
525
    	    mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
526
    	)
527
    	    	    	    	    	    	`thenUs` \ alt_code ->
528
	gencode absC				`thenUs` \ dflt_code ->
529

530
    	returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
531
532

    where
533
    	floating = isFloatingRep (getAmodeRep am)
534
535
    	choices = length alts

536
537
538
539
    	(x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
    	(x@(MachInt _), _)  `leAlt` (y,_) = intTag x <= intTag y
    	(x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y
    	(x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
540
541
542

\end{code}

543
544
545
546
547
548
We use jump tables when doing an integer switch on a relatively dense
list of alternatives.  We expect to be given a list of alternatives,
sorted by tag, and a range of values for which we are to generate a
table.  Of course, the tags of the alternatives should lie within the
indicated range.  The alternatives need not cover the range; a default
target is provided for the missing alternatives.
549

550
551
If a join is necessary after the switch, the alternatives should
already finish with a jump to the join point.
552
553

\begin{code}
554
555
 {-
 mkJumpTable
556
    :: StixTree  	    	-- discriminant
557
    -> [(Literal, AbstractC)] 	-- alternatives
558
559
560
    -> Integer 	    	    	-- low tag
    -> Integer 	    	    	-- high tag
    -> CLabel	    	    	-- default label
561
    -> UniqSM StixTreeList
562
 -}
563

564
565
 mkJumpTable am alts lowTag highTag dflt
  = getUniqLabelNCG 	    	    	    	    	`thenUs` \ utlbl ->
566
    mapUs genLabel alts 	  	    	    	`thenUs` \ branches ->
sof's avatar
sof committed
567
568
    let	cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt (toInteger lowTag)])
    	cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
569
570

    	offset = StPrim IntSubOp [am, StInt lowTag]
571
        dsts   = DestInfo (dflt : map fst branches)
572

573
    	jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
574
    	tlbl = StLabel utlbl
575
576
577
    	table = StData PtrRep (mkTable branches [lowTag..highTag] [])
    in
    	mapUs mkBranch branches       	    	    	`thenUs` \ alts ->
578

579
580
581
	returnUs (\xs -> cjmpLo : cjmpHi : jump :
			 StSegment DataSegment : tlbl : table :
			 StSegment TextSegment : foldr1 (.) alts xs)
582
583

    where
584
    	genLabel x = getUniqLabelNCG `thenUs` \ lbl -> returnUs (lbl, x)
585
586

    	mkBranch (lbl,(_,alt)) =
587
588
	    gencode alt  	    		`thenUs` \ alt_code ->
    	    returnUs (\xs -> StLabel lbl : alt_code xs)
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606

    	mkTable _  []     tbl = reverse tbl
    	mkTable [] (x:xs) tbl = mkTable [] xs (StCLbl dflt : tbl)
    	mkTable alts@((lbl,(tag,_)):rest) (x:xs) tbl
    	  | intTag tag == x = mkTable rest xs (StCLbl lbl : tbl)
    	  | otherwise = mkTable alts xs (StCLbl dflt : tbl)

\end{code}

We generate binary comparison trees when a jump table is inappropriate.
We expect to be given a list of alternatives, sorted by tag, and for
convenience, the length of the alternative list.  We recursively break
the list in half and do a comparison on the first tag of the second half
of the list.  (Odd lists are broken so that the second half of the list
is longer.)  We can handle either integer or floating kind alternatives,
so long as they are not mixed.  (We assume that the type of the discriminant
determines the type of the alternatives.)

607
As with the jump table approach, if a join is necessary after the switch, the
608
609
610
alternatives should already finish with a jump to the join point.

\begin{code}
611
 {-
612
 mkBinaryTree
613
    :: StixTree  	    	-- discriminant
614
    -> Bool 	    	    	-- floating point?
615
    -> [(Literal, AbstractC)] 	-- alternatives
616
    -> Int  	    	    	-- number of choices
617
618
    -> Literal     	    	-- low tag
    -> Literal     	    	-- high tag
619
    -> CLabel	    	    	-- default code label
620
    -> UniqSM StixTreeList
621
 -}
622

623
 mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
624
  | rangeOfOne = gencode alt
625
626
  | otherwise
  = let	tag' = a2stix (CLit tag)
627
628
629
630
    	cmpOp = if floating then DoubleNeOp else IntNeOp
    	test = StPrim cmpOp [am, tag']
    	cjmp = StCondJump udlbl test
    in
631
632
    	gencode alt 	    	    	    	`thenUs` \ alt_code ->
	returnUs (\xs -> cjmp : alt_code xs)
633

634
    where
635
636
637
    	rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
    	-- When there is only one possible tag left in range, we skip the comparison

638
639
 mkBinaryTree am floating alts choices lowTag highTag udlbl
  = getUniqLabelNCG					`thenUs` \ uhlbl ->
640
    let tag' = a2stix (CLit splitTag)
641
642
643
644
    	cmpOp = if floating then DoubleGeOp else IntGeOp
    	test = StPrim cmpOp [am, tag']
    	cjmp = StCondJump uhlbl test
    in
645
    	mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
646
    	    	    	    	    	    	  	`thenUs` \ lo_code ->
647
    	mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
648
    	    	    	    	    		    	`thenUs` \ hi_code ->
649

650
	returnUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
651
652
653
654
655
656
657
658
659

    where
    	half = choices `div` 2
    	(alts_lo, alts_hi) = splitAt half alts
    	splitTag = fst (head alts_hi)

\end{code}

\begin{code}
660
 {-
661
 mkIfThenElse
662
    :: CAddrMode    	    -- discriminant
663
    -> Literal     	    -- tag
664
665
    -> AbstractC    	    -- if-part
    -> AbstractC    	    -- else-part
666
    -> UniqSM StixTreeList
667
 -}
668

669
670
 mkIfThenElse discrim tag alt deflt
  = getUniqLabelNCG					`thenUs` \ ujlbl ->
671
    getUniqLabelNCG					`thenUs` \ utlbl ->
672
673
    let discrim' = a2stix discrim
    	tag' = a2stix (CLit tag)
674
    	cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
675
676
677
678
679
    	test = StPrim cmpOp [discrim', tag']
    	cjmp = StCondJump utlbl test
    	dest = StLabel utlbl
    	join = StLabel ujlbl
    in
680
681
682
	gencode (mkJoin alt ujlbl)		`thenUs` \ alt_code ->
	gencode deflt				`thenUs` \ dflt_code ->
	returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
683
684
685

mkJoin :: AbstractC -> CLabel -> AbstractC

686
687
mkJoin code lbl
  | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
  | otherwise = code
\end{code}

%---------------------------------------------------------------------------

This answers the question: Can the code fall through to the next
line(s) of code?  This errs towards saying True if it can't choose,
because it is used for eliminating needless jumps.  In other words, if
you might possibly {\em not} jump, then say yes to falling through.

\begin{code}
mightFallThrough :: AbstractC -> Bool

mightFallThrough absC = ft absC True
 where
  ft AbsCNop	   if_empty = if_empty

  ft (CJump _)       if_empty = False
  ft (CReturn _ _)   if_empty = False
707
  ft (CSwitch _ alts deflt) if_empty
708
709
710
711
712
713
714
	= ft deflt if_empty ||
	  or [ft alt if_empty | (_,alt) <- alts]

  ft (AbsCStmts c1 c2) if_empty = ft c2 (ft c1 if_empty)
  ft _ if_empty = if_empty

{- Old algorithm, which called nonemptyAbsC for every subexpression! =========
715
716
fallThroughAbsC (AbsCStmts c1 c2)
  = case nonemptyAbsC c2 of
717
718
719
720
721
722
723
724
725
726
727
728
729
	Nothing -> fallThroughAbsC c1
	Just x -> fallThroughAbsC x
fallThroughAbsC (CJump _)	 = False
fallThroughAbsC (CReturn _ _)	 = False
fallThroughAbsC (CSwitch _ choices deflt)
  = (not (isEmptyAbsC deflt) && fallThroughAbsC deflt)
    || or (map (fallThroughAbsC . snd) choices)
fallThroughAbsC other		 = True

isEmptyAbsC :: AbstractC -> Bool
isEmptyAbsC = not . maybeToBool . nonemptyAbsC
================= End of old, quadratic, algorithm -}
\end{code}