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
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}
%************************************************************************
= 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
getPrecedence :: FixityEnv -> Name -> Integer
getPrecedence get_fixity nm
= case lookupFixity get_fixity nm of
- Fixity x _ -> fromIntegral x
+ Fixity x _assoc -> fromIntegral x
+ -- NB: the Report says that associativity is not taken
+ -- into account for either Read or Show; hence we
+ -- ignore associativity here
\end{code}
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}
%************************************************************************
| 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)
\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) .. ] ]