Merge branch 'master' of http://darcs.haskell.org/ghc

7 files changed, 123 insertions, 83 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 2352518f09..c8e5ab69e0 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -28,14 +28,13 @@ module MkId (
         voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
         coercionTokenId,
 
-        -- integer-gmp only Id:
-        integerGmpSId,
         -- integer-simple only Id's:
         integerSimpleNaughtId,
         integerSimplePositiveId,
         integerSimpleNegativeId,
         digitsNoneId,
         digitsSomeId,
+
         -- Common Integer Id's:
         shiftLIntegerId,
         negateIntegerId,
@@ -1059,11 +1058,6 @@ coercionTokenId -- Used to replace Coercion terms when we go to STG
                  (mkTyConApp eqPrimTyCon [unitTy, unitTy])
                  noCafIdInfo
 
--- integer-gmp only Id:
-integerGmpSId :: Id
-integerGmpSId = mkVanillaGlobal integerGmpSDataConName
-                                (mkFunTy intPrimTy integerTy)
-
 -- integer-simple only Id's:
 integerSimpleNaughtId, integerSimplePositiveId, integerSimpleNegativeId,
     digitsNoneId, digitsSomeId :: Id
@@ -1080,18 +1074,21 @@ digitsSomeId = mkVanillaGlobal digitsSomeDataConName
                                         (mkFunTy digitsTy digitsTy))
 
 shiftLIntegerId :: Id
-shiftLIntegerId = mkVanillaGlobal shiftLIntegerName
-                                  (mkFunTy integerTy
-                                           (mkFunTy intPrimTy integerTy))
+shiftLIntegerId = mkVanillaGlobalWithInfo shiftLIntegerName
+                     (mkFunTy integerTy (mkFunTy intPrimTy integerTy))
+	             noCafIdInfo
+-- ToDo: we should not really be relying on noCafInfo here.
+-- What if it's wrong?!
 
 negateIntegerId :: Id
-negateIntegerId = mkVanillaGlobal negateIntegerName
-                                  (mkFunTy integerTy integerTy)
+negateIntegerId = mkVanillaGlobalWithInfo negateIntegerName
+                     (mkFunTy integerTy integerTy)
+                     noCafIdInfo
 
 orIntegerId :: Id
-orIntegerId = mkVanillaGlobal orIntegerName
-                              (mkFunTy integerTy
-                                       (mkFunTy integerTy integerTy))
+orIntegerId = mkVanillaGlobalWithInfo orIntegerName
+                     (mkFunTy integerTy (mkFunTy integerTy integerTy))
+                     noCafIdInfo
 \end{code}
 
 
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index b480c6bcef..3b21e5f021 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -30,6 +30,7 @@ import VarEnv
 import Id
 import IdInfo
 import MkId
+import TysWiredIn
 import DataCon
 import PrimOp
 import BasicTypes
@@ -449,11 +450,11 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- For example
 --	f (g x)	  ===>   ([v = g x], f v)
 
-cpeRhsE _env expr@(Type {})     = return (emptyFloats, expr)
-cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
-cpeRhsE env (Lit (LitInteger i)) = cpeInteger env i
-cpeRhsE _env expr@(Lit {})      = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {})       = cpeApp env expr
+cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)
+cpeRhsE env (Lit (LitInteger i)) = cpeRhsE env (cvtLitInteger i)
+cpeRhsE _env expr@(Lit {})       = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})        = cpeApp env expr
 
 cpeRhsE env (Var f `App` _ `App` arg)
   | f `hasKey` lazyIdKey  	  -- Replace (lazy a) by a
@@ -501,40 +502,45 @@ cpeRhsE env (Case scrut bndr ty alts)
             ; rhs' <- cpeBodyNF env2 rhs
             ; return (con, bs', rhs') }
 
-cpeInteger :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)
-cpeInteger env i
-    = let expr = case cIntegerLibraryType of
-                  IntegerGMP ->
-                      let mkSmallInteger x = App (Var integerGmpSId)
-                                                 (Lit (mkMachInt x))
-                          negateInteger x = App (Var negateIntegerId) x
-                          f x = let low  = x .&. mask
-                                    high = x `shiftR` bits
-                                    highExpr = mkApps (Var shiftLIntegerId)
-                                                      [f high,
-                                                       Lit (mkMachInt (fromIntegral bits))]
-                                in if high == 0 then mkSmallInteger x
-                                   else if low == 0 then highExpr
-                                   else mkApps (Var orIntegerId)
-                                               [mkSmallInteger low, highExpr]
-                          bits = bitSize (undefined :: Int) - 2
-                          mask = 2 ^ bits - 1
-                      in if inIntRange i then mkSmallInteger i
-                         else if i < 0 then negateInteger (f (negate i))
-                         else f i
-                  IntegerSimple ->
-                      let bits = bitSize (undefined :: Word)
-                          mask = 2 ^ bits - 1
-                          f 0 = Var digitsNoneId
-                          f x = let low  = x .&. mask
-                                    high = x `shiftR` bits
-                                in mkApps (Var digitsSomeId)
-                                          [Lit (mkMachWord low), f high]
-                      in case i `compare` 0 of
-                         EQ -> Var integerSimpleNaughtId
-                         GT -> App (Var integerSimplePositiveId) (f i)
-                         LT -> App (Var integerSimpleNegativeId) (f (negate i))
-      in cpeRhsE env expr
+cvtLitInteger :: Integer -> CoreExpr
+-- Here we convert a literal Integer to the low-level
+-- represenation. Exactly how we do this depends on the
+-- library that implements Integer.  If it's GMP we 
+-- use the S# data constructor for small literals.  
+cvtLitInteger i
+  = case cIntegerLibraryType of
+      IntegerGMP 
+        | inIntRange i -> mkSmallInteger i
+        | i < 0        -> negateInteger (f (negate i))
+        | otherwise    -> f i
+        where
+          mkSmallInteger x = mkConApp integerGmpSDataCon [Lit (mkMachInt x)]
+          negateInteger x = App (Var negateIntegerId) x
+          f x = let low  = x .&. mask
+                    high = x `shiftR` bits
+                    highExpr = mkApps (Var shiftLIntegerId)
+                                      [f high,
+                                       Lit (mkMachInt (fromIntegral bits))]
+                in if high == 0 then mkSmallInteger x
+                   else if low == 0 then highExpr
+                   else mkApps (Var orIntegerId)
+                               [mkSmallInteger low, highExpr]
+          bits = bitSize (undefined :: Int) - 2
+          mask = 2 ^ bits - 1
+
+      IntegerSimple
+        -> case i `compare` 0 of
+             EQ -> Var integerSimpleNaughtId
+             GT -> App (Var integerSimplePositiveId) (f i)
+             LT -> App (Var integerSimpleNegativeId) (f (negate i))
+        where
+          bits = bitSize (undefined :: Word)
+          mask = 2 ^ bits - 1
+          f 0 = Var digitsNoneId
+          f x = let low  = x .&. mask
+                    high = x `shiftR` bits
+                in mkApps (Var digitsSomeId)
+                          [Lit (mkMachWord low), f high]
 
 -- ---------------------------------------------------------------------------
 --		CpeBody: produces a result satisfying CpeBody
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index 3cafd9814d..1835430f13 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -223,7 +223,7 @@ haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
 haskellish_src_suffixes      = haskellish_user_src_suffixes ++
                                [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ]
 haskellish_suffixes          = haskellish_src_suffixes ++ ["hc", "raw_s"]
-cish_suffixes                = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "m", "M", "mm" ]
+cish_suffixes                = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ]
 extcoreish_suffixes          = [ "hcr" ]
 -- Will not be deleted as temp files:
 haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 8ab7ba478b..0fdc66839b 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -26,8 +26,10 @@ module TysWiredIn (
 
         -- * Integer
         integerTy, integerTyConName,
+
         -- integer-gmp only:
-        integerGmpSDataConName,
+        integerGmpSDataCon,
+
         -- integer-simple only:
         integerSimpleNaughtDataConName,
         integerSimplePositiveDataConName, integerSimpleNegativeDataConName,
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index c5166c3b10..1d07a4430b 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -819,7 +819,7 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
     		 	dataConInstOrigArgTys data_con all_rep_tc_args,
           not (isUnLiftedType arg_ty) ]
     		-- No constraints for unlifted types
-    		-- Where they are legal we generate specilised function calls
+    		-- See Note [Deriving and unboxed types]
 
     		-- For functor-like classes, two things are different
     		-- (a) We recurse over argument types to generate constraints
@@ -860,7 +860,24 @@ inferConstraints _ cls inst_tys rep_tc rep_tc_args
       = [mkClassPred cls [ty] | ty <- rep_tc_args]
       | otherwise 
       = []
+\end{code}
+
+Note [Deriving and unboxed types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have some special hacks to support things like
+   data T = MkT Int# deriving( Ord, Show )
+
+Specifically
+  * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
+    (which we know how to show)
+
+  * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
+    on some primitive types
+
+It's all a bit ad hoc.
 
+
+\begin{code}
 ------------------------------------------------------------------
 -- Check side conditions that dis-allow derivability for particular classes
 -- This is *apart* from the newtype-deriving mechanism
@@ -894,15 +911,15 @@ nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
 
 sideConditions :: DerivContext -> Class -> Maybe Condition
 sideConditions mtheta cls
-  | cls_key == eqClassKey      	   = Just cond_std
-  | cls_key == ordClassKey     	   = Just cond_std
-  | cls_key == showClassKey    	   = Just cond_std
-  | cls_key == readClassKey    	   = Just (cond_std `andCond` cond_noUnliftedArgs)
+  | cls_key == eqClassKey      	   = Just (cond_std `andCond` cond_args cls)
+  | cls_key == ordClassKey     	   = Just (cond_std `andCond` cond_args cls)
+  | cls_key == showClassKey    	   = Just (cond_std `andCond` cond_args cls)
+  | cls_key == readClassKey    	   = Just (cond_std `andCond` cond_args cls)
   | cls_key == enumClassKey    	   = Just (cond_std `andCond` cond_isEnumeration)
-  | cls_key == ixClassKey      	   = Just (cond_std `andCond` cond_enumOrProduct)
-  | cls_key == boundedClassKey 	   = Just (cond_std `andCond` cond_enumOrProduct)
+  | cls_key == ixClassKey      	   = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == boundedClassKey 	   = Just (cond_std `andCond` cond_enumOrProduct cls)
   | cls_key == dataClassKey    	   = Just (checkFlag Opt_DeriveDataTypeable `andCond` 
-                                           cond_std `andCond` cond_noUnliftedArgs)
+                                           cond_std `andCond` cond_args cls)
   | cls_key == functorClassKey 	   = Just (checkFlag Opt_DeriveFunctor `andCond`
     	                                   cond_functorOK True)	 -- NB: no cond_std!
   | cls_key == foldableClassKey	   = Just (checkFlag Opt_DeriveFoldable `andCond`
@@ -964,20 +981,34 @@ no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
 cond_RepresentableOk :: Condition
 cond_RepresentableOk (_,t) = canDoGenerics t
 
-cond_enumOrProduct :: Condition
-cond_enumOrProduct = cond_isEnumeration `orCond` 
-		       (cond_isProduct `andCond` cond_noUnliftedArgs)
+cond_enumOrProduct :: Class -> Condition
+cond_enumOrProduct cls = cond_isEnumeration `orCond` 
+		         (cond_isProduct `andCond` cond_args cls)
 
-cond_noUnliftedArgs :: Condition
+cond_args :: Class -> Condition
 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 -- by generating specilaised code.  For others (eg Data) we don't.
-cond_noUnliftedArgs (_, tc)
-  | null bad_cons = Nothing
-  | otherwise     = Just why
+cond_args cls (_, tc)
+  = case bad_args of 
+      []      -> Nothing
+      (ty:_) -> Just (hang (ptext (sLit "Don't know how to derive") <+> quotes (ppr cls))
+                         2 (ptext (sLit "for type") <+> quotes (ppr ty)))
   where
-    bad_cons = [ con | con <- tyConDataCons tc
-		     , any isUnLiftedType (dataConOrigArgTys con) ]
-    why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
+    bad_args = [ arg_ty | con <- tyConDataCons tc
+		        , arg_ty <- dataConOrigArgTys con
+			, isUnLiftedType arg_ty 
+                     	, not (ok_ty arg_ty) ]
+
+    cls_key = classKey cls
+    ok_ty arg_ty
+     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
+     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
+     | cls_key == showClassKey = check_in arg_ty boxConTbl
+     | otherwise               = False    -- Read, Ix etc
+
+    check_in :: Type -> [(Type,a)] -> Bool
+    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
+
 
 cond_isEnumeration :: Condition
 cond_isEnumeration (_, rep_tc)
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 12df4b5f92..ad06d6e749 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -28,7 +28,8 @@ module TcGenDeriv (
 	deepSubtypesContaining, foldDataConArgs,
 	gen_Foldable_binds,
 	gen_Traversable_binds,
-	genAuxBind
+	genAuxBind,
+        ordOpTbl, boxConTbl
     ) where
 
 #include "HsVersions.h"
@@ -1821,21 +1822,23 @@ box_if_necy :: String		-- The class involved
 	    -> LHsExpr RdrName	-- The argument
 	    -> Type		-- The argument type
 	    -> LHsExpr RdrName	-- Boxed version of the arg
+-- See Note [Deriving and unboxed types]
 box_if_necy cls_str tycon arg arg_ty
   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
   | otherwise		  = arg
   where
-    box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
+    box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
 
 ---------------------
 primOrdOps :: String	-- The class involved
 	   -> TyCon	-- The tycon involved
 	   -> Type	-- The type
 	   -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)	-- (lt,le,eq,ge,gt)
-primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
+-- See Note [Deriving and unboxed types]
+primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
 
-ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
-ord_op_tbl
+ordOpTbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
+ordOpTbl
  =  [(charPrimTy,	(CharLtOp,   CharLeOp,   CharEqOp,   CharGeOp,	 CharGtOp))
     ,(intPrimTy,	(IntLtOp,    IntLeOp,    IntEqOp,    IntGeOp,	 IntGtOp))
     ,(wordPrimTy,	(WordLtOp,   WordLeOp,   WordEqOp,   WordGeOp,	 WordGtOp))
@@ -1843,9 +1846,9 @@ ord_op_tbl
     ,(floatPrimTy,	(FloatLtOp,  FloatLeOp,  FloatEqOp,  FloatGeOp,  FloatGtOp))
     ,(doublePrimTy,	(DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
 
-box_con_tbl :: [(Type, RdrName)]
-box_con_tbl =
-    [(charPrimTy,	getRdrName charDataCon)
+boxConTbl :: [(Type, RdrName)]
+boxConTbl
+  = [(charPrimTy,	getRdrName charDataCon)
     ,(intPrimTy,	getRdrName intDataCon)
     ,(wordPrimTy,	wordDataCon_RDR)
     ,(floatPrimTy,	getRdrName floatDataCon)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 561411630b..c938001da6 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1265,7 +1265,8 @@ mkRecSelBind (tycon, sel_name)
   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
   where
     loc    	= getSrcSpan tycon    
-    sel_id 	= Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo
+    sel_id 	= Var.mkExportedLocalVar rec_details sel_name 
+                                         sel_ty vanillaIdInfo
     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1