From: simonpj Date: Tue, 1 Oct 2002 09:55:38 +0000 (+0000) Subject: [project @ 2002-10-01 09:55:38 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1600 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0c9c303faa01623df27c4ecab339527034425cb0;p=ghc-hetmet.git [project @ 2002-10-01 09:55:38 by simonpj] Better derived Ord code --- diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 41ba931..4c07ff5 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -319,55 +319,39 @@ gen_Ord_binds tycon tycon_loc = getSrcLoc tycon -------------------------------------------------------------------- compare = mk_easy_FunMonoBind tycon_loc compare_RDR - [a_Pat, b_Pat] - [cmp_eq] - (if maybeToBool (maybeTyConSingleCon tycon) then - --- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr --- Weird. Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT } - - cmp_eq_Expr a_Expr b_Expr - else - untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] + [a_Pat, b_Pat] [cmp_eq] compare_rhs + compare_rhs + | single_con_type = cmp_eq_Expr a_Expr b_Expr + | otherwise + = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR - -- True case; they are equal - -- If an enumeration type we are done; else - -- recursively compare their components - (if isEnumerationTyCon tycon then - eqTag_Expr - else --- cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr --- Ditto - cmp_eq_Expr a_Expr b_Expr - ) + (cmp_eq_Expr a_Expr b_Expr) -- True case -- False case; they aren't equal -- So we need to do a less-than comparison on the tags - (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))) + (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)) tycon_data_cons = tyConDataCons tycon + single_con_type = isSingleton tycon_data_cons (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullaryDataCon tycon_data_cons - cmp_eq = - mk_FunMonoBind tycon_loc - cmp_eq_RDR - (if null nonnullary_cons && isSingleton nullary_cons then - -- catch this specially to avoid warnings - -- about overlapping patterns from the desugarer. - let - data_con = head nullary_cons - data_con_RDR = getRdrName data_con - pat = mkNullaryConPat data_con_RDR - in - [([pat,pat], eqTag_Expr)] - else - map pats_etc nonnullary_cons ++ - -- leave out wildcards to silence desugarer. - (if isSingleton tycon_data_cons then - [] - else - [([wildPat, wildPat], default_rhs)])) + cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match + cmp_eq_match + | isEnumerationTyCon tycon + -- We know the tags are equal, so if it's an enumeration TyCon, + -- then there is nothing left to do + -- Catch this specially to avoid warnings + -- about overlapping patterns from the desugarer, + -- and to avoid unnecessary pattern-matching + = [([wildPat,wildPat], eqTag_Expr)] + | otherwise + = map pats_etc nonnullary_cons ++ + (if single_con_type then -- Omit wildcards when there's just one + [] -- constructor, to silence desugarer + else + [([wildPat, wildPat], default_rhs)]) + where pats_etc data_con = ([con1_pat, con2_pat], @@ -383,11 +367,11 @@ gen_Ord_binds tycon tys_needed = dataConOrigArgTys data_con nested_compare_expr [ty] [a] [b] - = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b) + = careful_compare_Case ty eqTag_Expr (HsVar a) (HsVar b) nested_compare_expr (ty:tys) (a:as) (b:bs) = let eq_expr = nested_compare_expr tys as bs - in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b) + in careful_compare_Case ty eq_expr (HsVar a) (HsVar b) default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about -- inexhaustive patterns @@ -1145,34 +1129,35 @@ ToDo: Better SrcLocs. \begin{code} compare_gen_Case :: - RdrName - -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr + RdrNameHsExpr -- What to do for equality -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr careful_compare_Case :: -- checks for primitive types... Type - -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr + -> RdrNameHsExpr -- What to do for equality -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR -compare_gen_Case fun lt eq gt a b - = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} - [mkSimpleMatch [mkNullaryConPat ltTag_RDR] lt placeHolderType generatedSrcLoc, +compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR + = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case +compare_gen_Case eq a b -- General case + = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-} + [mkSimpleMatch [mkNullaryConPat ltTag_RDR] ltTag_Expr placeHolderType generatedSrcLoc, mkSimpleMatch [mkNullaryConPat eqTag_RDR] eq placeHolderType generatedSrcLoc, - mkSimpleMatch [mkNullaryConPat gtTag_RDR] gt placeHolderType generatedSrcLoc] + mkSimpleMatch [mkNullaryConPat gtTag_RDR] gtTag_Expr placeHolderType generatedSrcLoc] generatedSrcLoc -careful_compare_Case ty lt eq gt a b +careful_compare_Case ty eq a b | not (isUnLiftedType ty) = - compare_gen_Case compare_RDR lt eq gt a b + compare_gen_Case eq a b | otherwise = -- we have to do something special for primitive things... HsIf (genOpApp a relevant_eq_op b) eq - (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc) + (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc) generatedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty