From: simonm <unknown>
Date: Mon, 11 May 1998 11:21:46 +0000 (+0000)
Subject: [project @ 1998-05-11 11:21:46 by simonm]
X-Git-Tag: Approx_2487_patches~713
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=672a54bb7c5c10cb2e18a975c717e4b2892b45b5;p=ghc-hetmet.git

[project @ 1998-05-11 11:21:46 by simonm]
Generate proper floating point literals when we know the type is
either Float or Double.
---

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 8582f65..fdef8c9 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -62,8 +62,10 @@ import Type	( Type, ThetaType, instantiateTy, instantiateThetaTy,
 		  mkSynTy
 		)
 import TyVar	( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets )
-import TysPrim	  ( intPrimTy )
-import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
+import TysPrim	  ( intPrimTy, floatPrimTy, doublePrimTy )
+import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange,
+		    floatDataCon, isFloatTy, 
+		    doubleDataCon, isDoubleTy )
 import Unique	( fromRationalClassOpKey, rationalTyConKey,
 		  fromIntClassOpKey, fromIntegerClassOpKey, Unique
 		)
@@ -337,7 +339,14 @@ newMethodAtLoc orig loc real_id tys	-- Local function, similar to newMethod but
 	meth_inst    = Method new_uniq (RealId real_id) tys theta tau orig loc
     in
     returnNF_Tc (meth_inst, instToId meth_inst)
+\end{code}
+
+In newOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want.  This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
 
+\begin{code}
 newOverloadedLit :: InstOrigin s
 		 -> OverloadedLit
 		 -> TcType s
@@ -353,7 +362,7 @@ newOverloadedLit orig (OverloadedIntegral i) ty
     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
     integer_lit    = HsLitOut (HsInt i) integerTy
     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
-
+ 
 newOverloadedLit orig lit ty		-- The general case
   = tcGetSrcLoc			`thenNF_Tc` \ loc ->
     tcGetUnique			`thenNF_Tc` \ new_uniq ->
@@ -524,8 +533,16 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
     integer_lit    = HsLitOut (HsInt i) integerTy
     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
 
+-- 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).
+
 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
-  = tcLookupGlobalValueByKey fromRationalClassOpKey	`thenNF_Tc` \ from_rational ->
+  | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
+  | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
+
+  | otherwise 
+	  = tcLookupGlobalValueByKey fromRationalClassOpKey	`thenNF_Tc` \ from_rational ->
 
 	-- The type Rational isn't wired in so we have to conjure it up
     tcLookupTyConByKey rationalTyConKey	`thenNF_Tc` \ rational_tycon ->
@@ -535,6 +552,13 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
     in
     newMethodAtLoc orig loc from_rational [ty]		`thenNF_Tc` \ (method_inst, method_id) ->
     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
+
+  where
+    floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
+    float_lit      = HsApp (HsVar (RealId floatDataCon)) floatprim_lit
+    doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
+    double_lit     = HsApp (HsVar (RealId doubleDataCon)) doubleprim_lit
+
 \end{code}
 
 There is a second, simpler interface, when you want an instance of a