From aae28e686a041eb1d1f88a2dd7863216caad68af Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Mon, 28 Jun 1999 10:04:18 +0000
Subject: [PATCH] [project @ 1999-06-28 10:04:18 by simonmar] Jump to the join
point when returning a new constructor to a bind default. Fixes: recent
panic in mkStaticAlgReturnCode.
---
ghc/compiler/codeGen/CgCon.lhs | 49 +++++++++++++++++++---------------
1 file changed, 27 insertions(+), 22 deletions(-)
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 84f6808be5f8..5ab41b1cea14 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -290,7 +290,7 @@ cgReturnDataCon con amodes all_zero_size_args
case sequel of
- CaseAlts _ (Just (alts, Just (Nothing, (_,deflt_lbl))))
+ CaseAlts _ (Just (alts, Just (maybe_deflt, (_,deflt_lbl))))
| not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
@@ -304,7 +304,9 @@ cgReturnDataCon con amodes all_zero_size_args
-- if the default is a non-bind-default (ie does not use y),
-- then we should simply jump to the default join point;
- performReturn AbsCNop {- No reg assts -} jump_to_join_point
+ case maybe_deflt of
+ Nothing -> performReturn AbsCNop {- No reg assts -} jump_to_join_point
+ Just _ -> build_it_then jump_to_join_point
where
is_elem = isIn "cgReturnDataCon"
jump_to_join_point sequel = absC (CJump (CLbl deflt_lbl CodePtrRep))
@@ -372,30 +374,33 @@ cgReturnDataCon con amodes all_zero_size_args
False {-node doesn't point-}
| otherwise ->
- -- BUILD THE OBJECT IN THE HEAP
- -- The first "con" says that the name bound to this
- -- closure is "con", which is a bit of a fudge, but it only
- -- affects profiling
-
- -- This Id is also used to get a unique for a
- -- temporary variable, if the closure is a CHARLIKE.
- -- funilly enough, this makes the unique always come
- -- out as '54' :-)
- buildDynCon (mkDataConId con) currentCCS
- con amodes all_zero_size_args
- `thenFC` \ idinfo ->
- idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
-
-
- -- RETURN
- profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
- -- could use doTailCall here.
- performReturn (move_to_reg amode node)
- (mkStaticAlgReturnCode con)
+ build_it_then (mkStaticAlgReturnCode con)
where
con_name = dataConName con
move_to_reg :: CAddrMode -> MagicId -> AbstractC
move_to_reg src_amode dest_reg = CAssign (CReg dest_reg) src_amode
+
+ build_it_then return =
+ -- BUILD THE OBJECT IN THE HEAP
+ -- The first "con" says that the name bound to this
+ -- closure is "con", which is a bit of a fudge, but it only
+ -- affects profiling
+
+ -- This Id is also used to get a unique for a
+ -- temporary variable, if the closure is a CHARLIKE.
+ -- funilly enough, this makes the unique always come
+ -- out as '54' :-)
+ buildDynCon (mkDataConId con) currentCCS
+ con amodes all_zero_size_args
+ `thenFC` \ idinfo ->
+ idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
+
+
+ -- RETURN
+ profCtrC SLIT("TICK_RET_NEW") [mkIntCLit (length amodes)] `thenC`
+ -- could use doTailCall here.
+ performReturn (move_to_reg amode node) return
+
\end{code}
--
GitLab