-\begin{code}
-mkRetVecTarget :: Id -- Just for its unique
- -> [(AltCon, AbstractC)] -- Branch codes
- -> SRT -- Continuation's SRT
- -> CtrlReturnConvention
- -> FCode CAddrMode
-
-mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
- = ASSERT( null other_alts )
- mkRetDirectTarget bndr deflt_absC srt
- where
- ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
-
-mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
- = mkRetDirectTarget bndr switch_absC srt
- where
- -- Find the tag explicitly rather than using tag_reg for now.
- -- on architectures with lots of regs the tag will be loaded
- -- into tag_reg by the code doing the returning.
- tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
- switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
-
-
-mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
- = buildContLivenessMask bndr `thenFC` \ liveness ->
- getSRTInfo name srt `thenFC` \ srt_info ->
- let
- ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
- in
- absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC`
- -- Alts come first, because we don't want to declare all the symbols
-
- return (CLbl vtbl_lbl DataPtrRep)
- where
- tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
- vector_table = map mk_vector_entry tags
- alts_absCs = map snd (sortBy cmp tagged_alt_absCs)
- -- The sort is unnecessary; just there for now
- -- to make the new order the same as the old
- (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
- (DEFAULT,_) `cmp` _ = GT
- (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
- (DataAlt d1,_) `cmp` (DEFAULT, _) = LT
- -- Others impossible
-
- name = idName bndr
- uniq = getUnique name
- vtbl_lbl = mkVecTblLabel uniq
-
- deflt_lbl :: CAddrMode
- deflt_lbl = case tagged_alt_absCs of
- (DEFAULT, abs_c) : _ -> get_block_label abs_c
- other -> mkIntCLit 0
- -- 'other' case: the simplifier might have eliminated a case
- -- so we may have e.g. case xs of
- -- [] -> e
- -- In that situation the default should never be taken,
- -- so we just use '0' (=> seg fault if used)
-
- mk_vector_entry :: ConTag -> CAddrMode
- mk_vector_entry tag
- = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
- -- The comprehension neatly, and correctly, ignores the DEFAULT
- [] -> deflt_lbl
- [abs_c] -> get_block_label abs_c
- _ -> panic "mkReturnVector: too many"
-
- get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
-\end{code}