diff options
| author | simonpj <unknown> | 2004-04-05 10:51:23 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2004-04-05 10:51:23 +0000 |
| commit | c7c01b0d35e816c4e85177d22d82be22261684a1 (patch) | |
| tree | ef9a476fe921a557f870fadbcad44721edbb53e9 /ghc | |
| parent | 4a436b3d19d0e5496a4ff74af50492dddbd43179 (diff) | |
| download | haskell-c7c01b0d35e816c4e85177d22d82be22261684a1.tar.gz | |
[project @ 2004-04-05 10:51:23 by simonpj]
Remove redundant case-analysis for single-constructor case of gunfold
Diffstat (limited to 'ghc')
| -rw-r--r-- | ghc/compiler/typecheck/TcGenDeriv.lhs | 26 |
1 files changed, 15 insertions, 11 deletions
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 706ee3da95..67cb7ee4d1 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -1062,10 +1062,11 @@ gen_Data_binds fix_env tycon -- Auxiliary definitions: the data type and constructors datatype_bind `consBag` listToBag (map mk_con_bind data_cons)) where - tycon_loc = getSrcSpan tycon + tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon - data_cons = tyConDataCons tycon - n_cons = length data_cons + data_cons = tyConDataCons tycon + n_cons = length data_cons + one_constr = n_cons == 1 ------------ gfoldl gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) @@ -1080,17 +1081,20 @@ gen_Data_binds fix_env tycon ------------ gunfold gunfold_bind = mk_FunBind tycon_loc gunfold_RDR - [([k_Pat,z_Pat,c_Pat], gunfold_rhs)] + [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], + gunfold_rhs)] - gunfold_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) - (map gunfold_alt data_cons) + gunfold_rhs + | one_constr = mk_unfold_rhs (head data_cons) -- No need for case + | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map gunfold_alt data_cons) - gunfold_alt dc - = mkSimpleHsAlt (mk_tag_pat dc) - (foldr nlHsApp + gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) + mk_unfold_rhs dc = foldr nlHsApp (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) - (replicate (dataConSourceArity dc) (nlHsVar k_RDR))) - mk_tag_pat dc -- Last one is a wild-pat, to avoid + (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) + + mk_unfold_pat dc -- Last one is a wild-pat, to avoid -- redundant test, and annoying warning | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))] |