[project @ 2002-02-28 12:17:19 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / Inst.lhs
index c0c5f78..3805b9b 100644 (file)
@@ -9,19 +9,20 @@ module Inst (
        plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
 
        Inst, 
-       pprInst, pprInsts, pprInstsInFull, tidyInsts,
+       pprInst, pprInsts, pprInstsInFull, tidyInsts, tidyMoreInsts,
 
-       newDictsFromOld, newDicts, 
-       newMethod, newMethodWithGivenTy, newOverloadedLit,
-       newIPDict, tcInstId,
+       newDictsFromOld, newDicts, cloneDict,
+       newMethod, newMethodWithGivenTy, newMethodAtLoc,
+       newOverloadedLit, newIPDict, tcInstCall,
 
-       tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
-       getIPs,
-       predsOfInsts, predsOfInst,
+       tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
+       ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
+       instLoc, getDictClassTys, dictPred,
 
        lookupInst, lookupSimpleInst, LookupInstResult(..),
 
-       isDict, isClassDict, isMethod, instMentionsIPs,
+       isDict, isClassDict, isMethod, 
+       isLinearInst, linearInstType,
        isTyVarDict, isStdClassTyVarDict, isMethodFor, 
        instBindingRequired, instCanBeGeneralised,
 
@@ -33,48 +34,45 @@ module Inst (
 
 #include "HsVersions.h"
 
-import CmdLineOpts ( opt_NoMethodSharing )
 import HsSyn   ( HsLit(..), HsOverLit(..), HsExpr(..) )
-import TcHsSyn ( TcExpr, TcId, 
+import TcHsSyn ( TcExpr, TcId, TypecheckedHsExpr,
                  mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
                )
 import TcMonad
-import TcEnv   ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId )
+import TcEnv   ( TcIdSet, tcGetInstEnv, tcLookupId )
 import InstEnv ( InstLookupResult(..), lookupInstEnv )
-import TcType  ( TcThetaType,
-                 TcType, TcTauType, TcTyVarSet,
-                 zonkTcType, zonkTcTypes, zonkTcPredType,
-                 zonkTcThetaType, tcInstTyVar, tcInstType
+import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
+                 zonkTcThetaType, tcInstTyVar, tcInstType,
+               )
+import TcType  ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
+                 SourceType(..), PredType, ThetaType,
+                 tcSplitForAllTys, tcSplitForAllTys, 
+                 tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy,
+                 isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
+                 tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
+                 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
+                 isClassPred, isTyVarClassPred, isLinearPred,
+                 getClassPredTys, getClassPredTys_maybe, mkPredName,
+                 tidyType, tidyTypes, tidyFreeTyVars,
+                 tcCmpType, tcCmpTypes, tcCmpPred
                )
 import CoreFVs ( idFreeTyVars )
 import Class   ( Class )
-import Id      ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
+import Id      ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
 import PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )
 import Name    ( Name, mkMethodOcc, getOccName )
-import NameSet ( NameSet )
-import PprType ( pprPred )     
-import Type    ( Type, PredType(..), ThetaType,
-                 isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
-                 splitForAllTys, splitSigmaTy, funArgTy,
-                 splitMethodTy, splitRhoTy,
-                 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
-                 predMentionsIPs, isClassPred, isTyVarClassPred, 
-                 getClassPredTys, getClassPredTys_maybe, mkPredName,
-                 tidyType, tidyTypes, tidyFreeTyVars
-               )
+import PprType ( pprPred, pprParendType )      
 import Subst   ( emptyInScopeSet, mkSubst, 
-                 substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
+                 substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
                )
 import Literal ( inIntRange )
 import VarEnv  ( TidyEnv, lookupSubstEnv, SubstResult(..) )
 import VarSet  ( elemVarSet, emptyVarSet, unionVarSet )
-import TysWiredIn ( isIntTy,
-                   floatDataCon, isFloatTy,
-                   doubleDataCon, isDoubleTy,
-                   isIntegerTy
-                 ) 
+import TysWiredIn ( floatDataCon, doubleDataCon )
 import PrelNames( fromIntegerName, fromRationalName )
-import Util    ( thenCmp, zipWithEqual )
+import Util    ( thenCmp, equalLength )
+import BasicTypes( IPName(..), mapIPName, ipNameName )
+
 import Bag
 import Outputable
 \end{code}
@@ -102,7 +100,7 @@ zonkLIE :: LIE -> NF_TcM LIE
 zonkLIE lie = mapBagNF_Tc zonkInst lie
 
 pprInsts :: [Inst] -> SDoc
-pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
+pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 
 
 pprInstsInFull insts
@@ -178,14 +176,14 @@ instance Eq Inst where
                 EQ    -> True
                 other -> False
 
-cmpInst (Dict _ pred1 _)         (Dict _ pred2 _)          = (pred1 `compare` pred2)
+cmpInst (Dict _ pred1 _)         (Dict _ pred2 _)          = pred1 `tcCmpPred` pred2
 cmpInst (Dict _ _ _)             other                     = LT
 
 cmpInst (Method _ _ _ _ _ _)     (Dict _ _ _)              = GT
-cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
+cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
 cmpInst (Method _ _ _ _ _ _)      other                            = LT
 
-cmpInst (LitInst _ lit1 ty1 _)   (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
+cmpInst (LitInst _ lit1 ty1 _)   (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
 cmpInst (LitInst _ _ _ _)        other                     = GT
 
 -- and they can only have HsInt or HsFracs in them.
@@ -207,6 +205,9 @@ instLoc (Dict _ _         loc) = loc
 instLoc (Method _ _ _ _ _ loc) = loc
 instLoc (LitInst _ _ _    loc) = loc
 
+dictPred (Dict _ pred _ ) = pred
+dictPred inst            = pprPanic "dictPred" (ppr inst)
+
 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 
 predsOfInsts :: [Inst] -> [PredType]
@@ -220,9 +221,16 @@ predsOfInst (LitInst _ _ _ _)           = []
        -- But Num and Fractional have only one parameter and no functional
        -- dependencies, so I think no caller of predsOfInst will care.
 
-ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
+ipNamesOfInsts :: [Inst] -> [Name]
+ipNamesOfInst  :: Inst   -> [Name]
+-- Get the implicit parameters mentioned by these Insts
+-- NB: ?x and %x get different Names
+
+ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 
-getIPs inst = ipsOfPreds (predsOfInst inst)
+ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
+ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
+ipNamesOfInst other                   = []
 
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
@@ -258,15 +266,20 @@ isMethodFor :: TcIdSet -> Inst -> Bool
 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 isMethodFor ids inst                        = False
 
-instMentionsIPs :: Inst -> NameSet -> Bool
-  -- True if the Inst mentions any of the implicit
-  -- parameters in the supplied set of names
-instMentionsIPs (Dict _ pred _)          ip_names = pred `predMentionsIPs` ip_names
-instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
-instMentionsIPs other                   ip_names = False
+isLinearInst :: Inst -> Bool
+isLinearInst (Dict _ pred _) = isLinearPred pred
+isLinearInst other          = False
+       -- We never build Method Insts that have
+       -- linear implicit paramters in them.
+       -- Hence no need to look for Methods
+       -- See TcExpr.tcId 
+
+linearInstType :: Inst -> TcType       -- %x::t  -->  t
+linearInstType (Dict _ (IParam _ ty) _) = ty
+
 
 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
-                                       Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty
+                                       Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
                                        other             -> False
 \end{code}
 
@@ -278,7 +291,6 @@ must be witnessed by an actual binding; the second tells whether an
 \begin{code}
 instBindingRequired :: Inst -> Bool
 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
-instBindingRequired (Dict _ (IParam _ _) _)    = False
 instBindingRequired other                     = True
 
 instCanBeGeneralised :: Inst -> Bool
@@ -301,6 +313,10 @@ newDicts orig theta
   = tcGetInstLoc orig          `thenNF_Tc` \ loc ->
     newDictsAtLoc loc theta
 
+cloneDict :: Inst -> NF_TcM Inst
+cloneDict (Dict id ty loc) = tcGetUnique       `thenNF_Tc` \ uniq ->
+                            returnNF_Tc (Dict (setIdUnique id uniq) ty loc)
+
 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 
@@ -310,17 +326,25 @@ newDictsAtLoc :: InstLoc
              -> TcThetaType
              -> NF_TcM [Inst]
 newDictsAtLoc inst_loc@(_,loc,_) theta
-  = tcGetUniques (length theta)                `thenNF_Tc` \ new_uniqs ->
-    returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
+  = tcGetUniques                       `thenNF_Tc` \ new_uniqs ->
+    returnNF_Tc (zipWith mk_dict new_uniqs theta)
   where
     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 
--- For implicit parameters, since there is only one in scope
--- at any time, we use the name of the implicit parameter itself
-newIPDict orig name ty
-  = tcGetInstLoc orig                  `thenNF_Tc` \ inst_loc ->
-    returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
-  where pred = IParam name ty
+-- For vanilla implicit parameters, there is only one in scope
+-- at any time, so we used to use the name of the implicit parameter itself
+-- But with splittable implicit parameters there may be many in 
+-- scope, so we make up a new name.
+newIPDict :: InstOrigin -> IPName Name -> Type 
+         -> NF_TcM (IPName Id, Inst)
+newIPDict orig ip_name ty
+  = tcGetInstLoc orig                  `thenNF_Tc` \ inst_loc@(_,loc,_) ->
+    tcGetUnique                                `thenNF_Tc` \ uniq ->
+    let
+       pred = IParam ip_name ty
+       id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
+    in
+    returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 \end{code}
 
 
@@ -330,61 +354,16 @@ newIPDict orig name ty
 %*                                                                     *
 %************************************************************************
 
-tcInstId instantiates an occurrence of an Id.
-The instantiate_it loop runs round instantiating the Id.
-It has to be a loop because we are now prepared to entertain
-types like
-       f:: forall a. Eq a => forall b. Baz b => tau
-We want to instantiate this to
-       f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
-
-The -fno-method-sharing flag controls what happens so far as the LIE
-is concerned.  The default case is that for an overloaded function we 
-generate a "method" Id, and add the Method Inst to the LIE.  So you get
-something like
-       f :: Num a => a -> a
-       f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
-If you specify -fno-method-sharing, the dictionary application 
-isn't shared, so we get
-       f :: Num a => a -> a
-       f = /\a (d:Num a) (x:a) -> (+) a d x x
-This gets a bit less sharing, but
-       a) it's better for RULEs involving overloaded functions
-       b) perhaps fewer separated lambdas
-
 
 \begin{code}
-tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
-tcInstId fun
-  | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
-  | otherwise           = loop_share fun
-  where
-    orig = OccurrenceOf fun
-    loop_noshare fun fun_ty
-      = tcInstType fun_ty              `thenNF_Tc` \ (tyvars, theta, tau) ->
-       let 
-           ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
-       in
-        if null theta then             -- Is it overloaded?
-           returnNF_Tc (ty_app, emptyLIE, tau)
-       else
-           newDicts orig theta                                         `thenNF_Tc` \ dicts ->
-           loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
-           returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
-
-    loop_share fun
-      = tcInstType (idType fun)                `thenNF_Tc` \ (tyvars, theta, tau) ->
-       let 
-           arg_tys = mkTyVarTys tyvars
-       in
-        if null theta then             -- Is it overloaded?
-           returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
-       else
-               -- Yes, it's overloaded
-           newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
-           loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
-           returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
-
+tcInstCall :: InstOrigin  -> TcType -> NF_TcM (TypecheckedHsExpr -> TypecheckedHsExpr, LIE, TcType)
+tcInstCall orig fun_ty -- fun_ty is usually a sigma-type
+  = tcInstType fun_ty          `thenNF_Tc` \ (tyvars, theta, tau) ->
+    newDicts orig theta                `thenNF_Tc` \ dicts ->
+    let
+       inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
+    in
+    returnNF_Tc (inst_fn, mkLIE dicts, tau)
 
 newMethod :: InstOrigin
          -> TcId
@@ -393,9 +372,9 @@ newMethod :: InstOrigin
 newMethod orig id tys
   =    -- Get the Id type and instantiate it at the specified types
     let
-       (tyvars, rho) = splitForAllTys (idType id)
-       rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
-       (pred, tau)   = splitMethodTy rho_ty
+       (tyvars, rho) = tcSplitForAllTys (idType id)
+       rho_ty        = substTyWith tyvars tys rho
+       (pred, tau)   = tcSplitMethodTy rho_ty
     in
     newMethodWithGivenTy orig id tys [pred] tau
 
@@ -417,10 +396,10 @@ newMethodAtLoc inst_loc real_id tys
        -- This actually builds the Inst
   =    -- Get the Id type and instantiate it at the specified types
     let
-       (tyvars,rho) = splitForAllTys (idType real_id)
-       rho_ty        = ASSERT( length tyvars == length tys )
+       (tyvars,rho)  = tcSplitForAllTys (idType real_id)
+       rho_ty        = ASSERT( equalLength tyvars tys )
                        substTy (mkTopTyVarSubst tyvars tys) rho
-       (theta, tau)  = splitRhoTy rho_ty
+       (theta, tau)  = tcSplitRhoTy rho_ty
     in
     newMethodWith inst_loc real_id tys theta tau       `thenNF_Tc` \ meth_inst ->
     returnNF_Tc (meth_inst, instToId meth_inst)
@@ -436,18 +415,11 @@ newOverloadedLit :: InstOrigin
                 -> HsOverLit
                 -> TcType
                 -> NF_TcM (TcExpr, LIE)
-newOverloadedLit orig (HsIntegral i) ty
-  | isIntTy ty && inIntRange i         -- Short cut for Int
-  = returnNF_Tc (int_lit, emptyLIE)
-
-  | isIntegerTy ty                     -- Short cut for Integer
-  = returnNF_Tc (integer_lit, emptyLIE)
-
-  where
-    int_lit     = HsLit (HsInt i)
-    integer_lit = HsLit (HsInteger i)
+newOverloadedLit orig lit ty
+  | Just expr <- shortCutLit lit ty
+  = returnNF_Tc (expr, emptyLIE)
 
-newOverloadedLit orig lit ty           -- The general case
+  | otherwise
   = tcGetInstLoc orig          `thenNF_Tc` \ loc ->
     tcGetUnique                        `thenNF_Tc` \ new_uniq ->
     let
@@ -455,6 +427,22 @@ newOverloadedLit orig lit ty               -- The general case
        lit_id   = mkSysLocal SLIT("lit") new_uniq ty
     in
     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
+
+shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
+shortCutLit (HsIntegral i fi) ty
+  | isIntTy ty && inIntRange i && fi == fromIntegerName                -- Short cut for Int
+  = Just (HsLit (HsInt i))
+  | isIntegerTy ty && fi == fromIntegerName                    -- Short cut for Integer
+  = Just (HsLit (HsInteger i))
+
+shortCutLit (HsFractional f fr) ty
+  | isFloatTy ty  && fr == fromRationalName 
+  = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
+  | isDoubleTy ty && fr == fromRationalName 
+  = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
+
+shortCutLit lit ty
+  = Nothing
 \end{code}
 
 
@@ -513,7 +501,7 @@ pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 
 pprInst m@(Method u id tys theta tau loc)
   = hsep [ppr id, ptext SLIT("at"), 
-         brackets (interppSP tys) {- ,
+         brackets (sep (map pprParendType tys)) {- ,
          ptext SLIT("theta"), ppr theta,
          ptext SLIT("tau"), ppr tau
          show_uniq u,
@@ -526,13 +514,16 @@ tidyInst env (LitInst u lit ty loc)            = LitInst u lit (tidyType env ty) loc
 tidyInst env (Dict u pred loc)              = Dict u (tidyPred env pred) loc
 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 
-tidyInsts :: [Inst] -> (TidyEnv, [Inst])
+tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 -- This function doesn't assume that the tyvars are in scope
 -- so it works like tidyOpenType, returning a TidyEnv
-tidyInsts insts 
-  = (env, map (tidyInst env) insts)
+tidyMoreInsts env insts
+  = (env', map (tidyInst env') insts)
   where
-    env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
+    env' = tidyFreeTyVars env (tyVarsOfInsts insts)
+
+tidyInsts :: [Inst] -> (TidyEnv, [Inst])
+tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 \end{code}
 
 
@@ -554,23 +545,28 @@ lookupInst :: Inst
 -- Dictionaries
 
 lookupInst dict@(Dict _ (ClassP clas tys) loc)
-  = tcGetInstEnv               `thenNF_Tc` \ inst_env ->
-    case lookupInstEnv inst_env clas tys of
+  = getDOptsTc                 `thenNF_Tc` \ dflags ->
+    tcGetInstEnv               `thenNF_Tc` \ inst_env ->
+    case lookupInstEnv dflags inst_env clas tys of
 
       FoundInst tenv dfun_id
        -> let
-               (tyvars, rho) = splitForAllTys (idType dfun_id)
+               (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
                mk_ty_arg tv  = case lookupSubstEnv tenv tv of
                                   Just (DoneTy ty) -> returnNF_Tc ty
                                   Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
                                                       returnTc (mkTyVarTy tc_tv)
           in
+               -- It's possible that not all the tyvars are in
+               -- the substitution, tenv. For example:
+               --      instance C X a => D X where ...
+               -- (presumably there's a functional dependency in class C)
+               -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.        
           mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
           let
-               subst         = mkTyVarSubst tyvars ty_args
-               dfun_rho      = substTy subst rho
-               (theta, _)    = splitRhoTy dfun_rho
-               ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
+               dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
+               (theta, _) = tcSplitRhoTy dfun_rho
+               ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
           in
           if null theta then
                returnNF_Tc (SimpleInst ty_app)
@@ -593,45 +589,32 @@ lookupInst inst@(Method _ id tys theta _ loc)
 
 -- Literals
 
-lookupInst inst@(LitInst u (HsIntegral i) ty loc)
-  | isIntTy ty && in_int_range                 -- Short cut for Int
-  = returnNF_Tc (GenInst [] int_lit)
-       -- GenInst, not SimpleInst, because int_lit is actually a constructor application
+-- Look for short cuts first: if the literal is *definitely* a 
+-- int, integer, float or a double, generate the real thing here.
+-- This is essential  (see nofib/spectral/nucleic).
+-- [Same shortcut as in newOverloadedLit, but we
+--  may have done some unification by now]             
 
-  | isIntegerTy ty                             -- Short cut for Integer
-  = returnNF_Tc (GenInst [] integer_lit)
+lookupInst inst@(LitInst u lit ty loc)
+  | Just expr <- shortCutLit lit ty
+  = returnNF_Tc (GenInst [] expr)      -- GenInst, not SimpleInst, because 
+                                       -- expr may be a constructor application
 
-  | otherwise                                  -- Alas, it is overloaded and a big literal!
-  = tcLookupSyntaxId fromIntegerName           `thenNF_Tc` \ from_integer ->
+lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
+  = tcLookupId from_integer_name               `thenNF_Tc` \ from_integer ->
     newMethodAtLoc loc from_integer [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
-    returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
-  where
-    in_int_range   = inIntRange i
-    integer_lit    = HsLit (HsInteger i)
-    int_lit        = HsLit (HsInt i)
-
--- similar idea for overloaded floating point literals: if the literal is
--- *definitely* a float or a double, generate the real thing here.
--- This is essential  (see nofib/spectral/nucleic).
+    returnNF_Tc (GenInst [method_inst] 
+                        (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 
-lookupInst inst@(LitInst u (HsFractional f) ty loc)
-  | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
-  | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 
-  | otherwise 
-  = tcLookupSyntaxId fromRationalName          `thenNF_Tc` \ from_rational ->
+lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
+  = tcLookupId from_rat_name                   `thenNF_Tc` \ from_rational ->
     newMethodAtLoc loc from_rational [ty]      `thenNF_Tc` \ (method_inst, method_id) ->
     let
-       rational_ty  = funArgTy (idType method_id)
+       rational_ty  = tcFunArgTy (idType method_id)
        rational_lit = HsLit (HsRat f rational_ty)
     in
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
-
-  where
-    floatprim_lit  = HsLit (HsFloatPrim f)
-    float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
-    doubleprim_lit = HsLit (HsDoublePrim f)
-    double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 \end{code}
 
 There is a second, simpler interface, when you want an instance of a
@@ -641,18 +624,18 @@ ambiguous dictionaries.
 
 \begin{code}
 lookupSimpleInst :: Class
-                -> [Type]                              -- Look up (c,t)
+                -> [Type]                      -- Look up (c,t)
                 -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 
 lookupSimpleInst clas tys
-  = tcGetInstEnv               `thenNF_Tc` \ inst_env -> 
-    case lookupInstEnv inst_env clas tys of
+  = getDOptsTc                 `thenNF_Tc` \ dflags ->
+    tcGetInstEnv               `thenNF_Tc` \ inst_env -> 
+    case lookupInstEnv dflags inst_env clas tys of
       FoundInst tenv dfun
        -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
         where
-          (_, theta, _) = splitSigmaTy (idType dfun)
+          (_, rho)  = tcSplitForAllTys (idType dfun)
+          (theta,_) = tcSplitRhoTy rho
 
       other  -> returnNF_Tc Nothing
 \end{code}
-
-