+-- Given a bunch of alts code and their discrs, do the donkey work
+-- of making a multiway branch using a switch tree.
+-- What a load of hassle!
+mkMultiBranch :: [(Discr, BCInstrList)] -> BcM BCInstrList
+mkMultiBranch raw_ways
+ = let d_way = filter (isNoDiscr.fst) raw_ways
+ notd_ways = naturalMergeSortLe
+ (\w1 w2 -> leAlt (fst w1) (fst w2))
+ (filter (not.isNoDiscr.fst) raw_ways)
+
+ mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
+ mkTree [] range_lo range_hi = returnBc the_default
+
+ mkTree [val] range_lo range_hi
+ | range_lo `eqAlt` range_hi
+ = returnBc (snd val)
+ | otherwise
+ = getLabelBc `thenBc` \ label_neq ->
+ returnBc (mkTestEQ (fst val) label_neq
+ `consOL` (snd val
+ `appOL` unitOL (LABEL label_neq)
+ `appOL` the_default))
+
+ mkTree vals range_lo range_hi
+ = let n = length vals `div` 2
+ vals_lo = take n vals
+ vals_hi = drop n vals
+ v_mid = fst (head vals_hi)
+ in
+ getLabelBc `thenBc` \ label_geq ->
+ mkTree vals_lo range_lo (dec v_mid) `thenBc` \ code_lo ->
+ mkTree vals_hi v_mid range_hi `thenBc` \ code_hi ->
+ returnBc (mkTestLT v_mid label_geq
+ `consOL` (code_lo
+ `appOL` unitOL (LABEL label_geq)
+ `appOL` code_hi))
+
+ the_default
+ = case d_way of [] -> unitOL CASEFAIL
+ [(_, def)] -> def
+
+ -- None of these will be needed if there are no non-default alts
+ (mkTestLT, mkTestEQ, init_lo, init_hi)
+ | null notd_ways
+ = panic "mkMultiBranch: awesome foursome"
+ | otherwise
+ = case fst (head notd_ways) of {
+ DiscrI _ -> ( \(DiscrI i) fail_label -> TESTLT_I i fail_label,
+ \(DiscrI i) fail_label -> TESTEQ_I i fail_label,
+ DiscrI minBound,
+ DiscrI maxBound );
+ DiscrF _ -> ( \(DiscrF f) fail_label -> TESTLT_F f fail_label,
+ \(DiscrF f) fail_label -> TESTEQ_F f fail_label,
+ DiscrF minF,
+ DiscrF maxF );
+ DiscrD _ -> ( \(DiscrD d) fail_label -> TESTLT_D d fail_label,
+ \(DiscrD d) fail_label -> TESTEQ_D d fail_label,
+ DiscrD minD,
+ DiscrD maxD );
+ DiscrP _ -> ( \(DiscrP i) fail_label -> TESTLT_P i fail_label,
+ \(DiscrP i) fail_label -> TESTEQ_P i fail_label,
+ DiscrP minBound,
+ DiscrP maxBound )
+ }
+
+ (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
+ (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
+ (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
+ (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
+ NoDiscr `eqAlt` NoDiscr = True
+ _ `eqAlt` _ = False
+
+ (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
+ (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
+ (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
+ (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
+ NoDiscr `leAlt` NoDiscr = True
+ _ `leAlt` _ = False
+
+ isNoDiscr NoDiscr = True
+ isNoDiscr _ = False
+
+ dec (DiscrI i) = DiscrI (i-1)
+ dec (DiscrP i) = DiscrP (i-1)
+ dec other = other -- not really right, but if you
+ -- do cases on floating values, you'll get what you deserve
+
+ -- same snotty comment applies to the following
+ minF, maxF :: Float
+ minD, maxD :: Double
+ minF = -1.0e37
+ maxF = 1.0e37
+ minD = -1.0e308
+ maxD = 1.0e308
+ in
+ mkTree notd_ways init_lo init_hi
+
+