X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=eecf43bdd2f5f147140458ff40178eba7a7c0fac;hb=79011516105291b58324ce71a87f6bb26a131090;hp=2c1ce9e9eea4f42b665a5fb0cb7657f080ec1048;hpb=b113ebfade3ef28964a98966a4e6888e562c76e2;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2c1ce9e..eecf43b 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -305,6 +305,10 @@ JJQC-30-Nov-1997 gen_Ord_binds :: TyCon -> (LHsBinds RdrName, DerivAuxBinds) gen_Ord_binds tycon + | Just (con, prim_tc) <- primWrapperType_maybe tycon + = gen_PrimOrd_binds con prim_tc + + | otherwise = (unitBag compare, aux_binds) -- `AndMonoBinds` compare -- The default declaration in PrelBase handles this @@ -375,7 +379,58 @@ gen_Ord_binds tycon in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length +\end{code} + +Note [Comparision of primitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The general plan does not work well for data types like + data T = MkT Int# deriving( Ord ) +The general plan defines the 'compare' method, gets (<) etc from it. But +that means we get silly code like: + instance Ord T where + (>) (I# x) (I# y) = case <# x y of + True -> False + False -> case ==# x y of + True -> False + False -> True +We would prefer to use the (>#) primop. See also Trac #2130 + +\begin{code} +gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +-- See Note [Comparison of primitive types] +gen_PrimOrd_binds data_con prim_tc + = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op, + mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], []) + where + mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR + [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)] + con_RDR = getRdrName data_con + apat = nlConVarPat con_RDR [a_RDR] + bpat = nlConVarPat con_RDR [b_RDR] + + (lt_op, le_op, ge_op, gt_op) + | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp) + | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp) + | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp) + | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp) + | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp) + | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp) + | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc) + + +primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon) +-- True of data types that are wrappers around prmitive types +-- data T = MkT Word# +-- For these we want to generate all the (<), (<=) etc operations individually +primWrapperType_maybe tc + | [con] <- tyConDataCons tc + , [ty] <- dataConOrigArgTys con + , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty + , isPrimTyCon prim_tc + = Just (con, prim_tc) + | otherwise + = Nothing \end{code} %************************************************************************ @@ -675,7 +730,11 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] - (mk_index (zip3 as_needed bs_needed cs_needed)) + -- We need to reverse the order we consider the components in + -- so that + -- range (l,u) !! index (l,u) i == i -- when i is in range + -- (from http://haskell.org/onlinereport/ix.html) holds. + (mk_index (reverse $ zip3 as_needed bs_needed cs_needed)) where -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) mk_index [] = nlHsIntLit 0 @@ -1178,15 +1237,15 @@ gen_Data_binds fix_env tycon fixity | is_infix = infix_RDR | otherwise = prefix_RDR -gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl") -gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold") -toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf") -mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr") -mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType") -conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex") -prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix") -infix_RDR = dataQual_RDR gENERICS FSLIT("Infix") +gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") +gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") +toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf") +mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr") +mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType") +conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex") +prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix") +infix_RDR = dataQual_RDR gENERICS (fsLit "Infix") \end{code} %************************************************************************ @@ -1300,9 +1359,10 @@ careful_compare_Case tycon ty eq a b | not (isUnLiftedType ty) = compare_gen_Case eq a b | otherwise -- We have to do something special for primitive things... - = nlHsIf (genOpApp a relevant_eq_op b) - eq - (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr) + = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter + ltTag_Expr -- is true less often, so putting it first would + -- mean more tests (dynamically) + (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr) where relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty) relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty) @@ -1451,17 +1511,17 @@ genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} -a_RDR = mkVarUnqual FSLIT("a") -b_RDR = mkVarUnqual FSLIT("b") -c_RDR = mkVarUnqual FSLIT("c") -d_RDR = mkVarUnqual FSLIT("d") -k_RDR = mkVarUnqual FSLIT("k") -z_RDR = mkVarUnqual FSLIT("z") -ah_RDR = mkVarUnqual FSLIT("a#") -bh_RDR = mkVarUnqual FSLIT("b#") -ch_RDR = mkVarUnqual FSLIT("c#") -dh_RDR = mkVarUnqual FSLIT("d#") -cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq") +a_RDR = mkVarUnqual (fsLit "a") +b_RDR = mkVarUnqual (fsLit "b") +c_RDR = mkVarUnqual (fsLit "c") +d_RDR = mkVarUnqual (fsLit "d") +k_RDR = mkVarUnqual (fsLit "k") +z_RDR = mkVarUnqual (fsLit "z") +ah_RDR = mkVarUnqual (fsLit "a#") +bh_RDR = mkVarUnqual (fsLit "b#") +ch_RDR = mkVarUnqual (fsLit "c#") +dh_RDR = mkVarUnqual (fsLit "d#") +cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq") as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]