X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcGenDeriv.lhs;h=f2486745865a5370216c87346ebcd577507b504f;hb=993ce43d3f3fb6bdb04cbc6d82babdd23355f7d7;hp=d67ffc0aba0850c6c62df141c77b5bcfbe2a9897;hpb=25f84fa7e4b84c3db5ba745a7881c009b778e0b1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index d67ffc0..f248674 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
@@ -1006,7 +1065,10 @@ appPrecedence = fromIntegral maxPrecedence + 1
 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}
 
 
@@ -1297,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)