- -> Unique
- -> AbstractC -- Restore-cost-centre instruction
- -> Bool -- True <=> branches must be labelled
- -> Type -- From the case statement
- -> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
- -> StgCaseDefault -- The default
- -> Bool -- Context switch at alts?
- -> FCode ([(ConTag, AbstractC)], -- The branches
- AbstractC -- The default case
- )
-\end{code}
-
-The case with a default which has a binder is different. We need to
-pick all the constructors which aren't handled explicitly by an
-alternative, and which return their results in registers, allocate
-them explicitly in the heap, and jump to a join point for the default
-case.
-
-OLD: All of this only works if a heap-check is required anyway, because
-otherwise it isn't safe to allocate.
-
-NEW (July 94): now false! It should work regardless of gc_flag,
-because of the extra_branches argument now added to forkAlts.
-
-We put a heap-check at the join point, for the benefit of constructors
-which don't need to do allocation. This means that ones which do need
-to allocate may end up doing two heap-checks; but that's just too bad.
-(We'd need two join labels otherwise. ToDo.)
-
-It's all pretty turgid anyway.
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc semi_tagging
- ty alts deflt@(StgBindDefault binder True{-used-} _)
- emit_yield{-should a yield macro be emitted?-}
- = let
- extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map mk_extra_branch default_cons)
-
- must_label_default = semi_tagging || not (null extra_branches)
- in
- forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
- extra_branches
- (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
- where
-
- default_join_lbl = mkDefaultLabel uniq
- jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
-
- (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
-
- alt_cons = [ con | (con,_,_,_) <- alts ]
-
- default_cons = [ spec_con | spec_con <- spec_cons, -- In this type
- spec_con `not_elem` alt_cons ] -- Not handled explicitly
- where
- not_elem = isn'tIn "cgAlgAlts"
-
- -- (mk_extra_branch con) returns the a maybe for the extra branch for con.
- -- The "maybe" is because con may return in heap, in which case there is
- -- nothing to do. Otherwise, we have a special case for a nullary constructor,
- -- but in the general case we do an allocation and heap-check.
-
- mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
-
- mk_extra_branch con
- = ASSERT(isDataCon con)
- case dataReturnConvAlg con of
- ReturnInHeap -> Nothing
- ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
- returnFC (tag, abs_c)
- )
- where
- lf_info = mkConLFInfo con
- tag = dataConTag con
-
- -- alloc_code generates code to allocate constructor con, whose args are
- -- in the arguments to alloc_code, assigning the result to Node.
- alloc_code :: [MagicId] -> Code
-
- alloc_code regs
- = possibleHeapCheck gc_flag regs False (
- buildDynCon binder useCurrentCostCentre con
- (map CReg regs) (all zero_size regs)
- `thenFC` \ idinfo ->
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
-
- absC (CAssign (CReg node) amode) `thenC`
- absC jump_instruction
- )
- where
- zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
-\end{code}
-
-Now comes the general case
-
-\begin{code}
-cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
- {- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
- emit_yield{-should a yield macro be emitted?-}
-
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
- [{- No "extra branches" -}]
- (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
-\end{code}
-
-\begin{code}
-cgAlgDefault :: GCFlag
- -> Unique -> AbstractC -> Bool -- turgid state...
- -> StgCaseDefault -- input
- -> Bool
- -> FCode AbstractC -- output
-
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault _
- = returnFC AbsCNop
-
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault _ False{-binder not used-} rhs)
- emit_yield{-should a yield macro be emitted?-}
-
- = getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield [] False
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
- let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
-
-cgAlgDefault gc_flag uniq restore_cc must_label_branch
- (StgBindDefault binder True{-binder used-} rhs)
- emit_yield{-should a yield macro be emitted?-}
-
- = -- We have arranged that Node points to the thing, even
- -- even if we return in registers
- bindNewToReg binder node mkLFArgument `thenC`
- getAbsC (absC restore_cc `thenC`
- let
- emit_gran_macros = opt_GranMacros
- in
- (if emit_gran_macros && emit_yield
- then yield [node] False
- else absC AbsCNop) `thenC`
- -- liveness same as in possibleHeapCheck below
- possibleHeapCheck gc_flag [node] False (cgExpr rhs)
- -- Node is live, but doesn't need to point at the thing itself;
- -- it's ok for Node to point to an indirection or FETCH_ME
- -- Hence no need to re-enter Node.
- ) `thenFC` \ abs_c ->
-
- let
- final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
--- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
projects / ghc-hetmet.git / blobdiff