X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fspecialise%2FSpecEnv.lhs;h=6efc6af98dc881ac3a7c1c83c0ceb26808aafed1;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=374b4c0139da43486596c0e22fb4a3cd864ca198;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git

diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs
index 374b4c0..6efc6af 100644
--- a/ghc/compiler/specialise/SpecEnv.lhs
+++ b/ghc/compiler/specialise/SpecEnv.lhs
@@ -7,25 +7,41 @@
 #include "HsVersions.h"
 
 module SpecEnv (
-	SpecEnv(..), MatchEnv,
+	SYN_IE(SpecEnv), MatchEnv,
 	nullSpecEnv, isNullSpecEnv,
-	addOneToSpecEnv, lookupSpecEnv,
-	specEnvToList
+	addOneToSpecEnv, lookupSpecEnv
     ) where
 
-import Ubiq
+IMP_Ubiq()
 
 import MatchEnv
 import Type		( matchTys, isTyVarTy )
-import Usage		( UVar(..) )
+import Usage		( SYN_IE(UVar) )
+import OccurAnal	( occurAnalyseGlobalExpr )
+import CoreSyn		( SYN_IE(CoreExpr), SYN_IE(SimplifiableCoreExpr) )
+import Maybes		( MaybeErr(..) )
+--import PprStyle--ToDo:rm
+--import Util(pprTrace)--ToDo:rm
+--import Outputable--ToDo:rm
+--import PprType--ToDo:rm
+--import Pretty--ToDo:rm
+--import PprCore--ToDo:rm
+--import Id--ToDo:rm
+--import TyVar--ToDo:rm
+--import Unique--ToDo:rm
+--import IdInfo--ToDo:rm
+--import PprEnv--ToDo:rm
 \end{code}
 
 
-A @SpecEnv@ holds details of an @Id@'s specialisations:
+A @SpecEnv@ holds details of an @Id@'s specialisations.  It should be
+a newtype (ToDo), but for 1.2 compatibility we make it a data type.
+It can't be a synonym because there's an IdInfo instance of it
+that doesn't work if it's (MatchEnv a b).
+Furthermore, making it a data type makes it easier to break the IdInfo loop.
 
 \begin{code}
-type CoreExpr = GenCoreExpr Id Id TyVar Unique
-type SpecEnv = MatchEnv [Type] CoreExpr
+data SpecEnv = SpecEnv (MatchEnv [Type] SimplifiableCoreExpr)
 \end{code}
 
 For example, if \tr{f}'s @SpecEnv@ contains the mapping:
@@ -36,218 +52,40 @@ then
 \begin{verbatim}
 	f (List Int) Bool d  ===>  f' Int Bool
 \end{verbatim}
+All the stuff about how many dictionaries to discard, and what types
+to apply the specialised function to, are handled by the fact that the
+SpecEnv contains a template for the result of the specialisation.
 
-\begin{code}
-nullSpecEnv :: SpecEnv
-nullSpecEnv = nullMEnv
-
-isNullSpecEnv :: SpecEnv -> Bool
-isNullSpecEnv env = null (mEnvToList env)
+There is one more exciting case, which is dealt with in exactly the same
+way.  If the specialised value is unboxed then it is lifted at its
+definition site and unlifted at its uses.  For example:
 
-specEnvToList :: SpecEnv -> [([Type],CoreExpr)]
-specEnvToList env = mEnvToList env
-	
-addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], CoreExpr)
-addOneToSpecEnv env tys rhs = insertMEnv matchTys env tys rhs
+	pi :: forall a. Num a => a
 
-lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (CoreExpr, [(TyVar,Type)])
-lookupSpecEnv env tys 
-  | all isTyVarTy tys = Nothing	-- Short cut: no specialisation for simple tyvars
-  | otherwise	      = lookupMEnv matchTys env tys
-\end{code}
+might have a specialisation
 
+	[Int#] ===>  (case pi' of Lift pi# -> pi#)
 
+where pi' :: Lift Int# is the specialised version of pi.
 
-=================================================================
-	BELOW HERE SCHEDULED FOR DELETION!
 
+\begin{code}
+nullSpecEnv :: SpecEnv
+nullSpecEnv = SpecEnv nullMEnv
 
-The details of one specialisation, held in an @Id@'s
-@SpecEnv@ are as follows:
-\begin{pseudocode}
-data SpecInfo
-  = SpecInfo	[Maybe Type] -- Instance types; no free type variables in here
-	    	Int		-- No. of dictionaries to eat
-		Id		-- Specialised version
-\end{pseudocode}
+isNullSpecEnv :: SpecEnv -> Bool
+isNullSpecEnv (SpecEnv env) = null (mEnvToList env)
 
-For example, if \tr{f} has this @SpecInfo@:
-\begin{verbatim}
-	SpecInfo [Just t1, Nothing, Just t3] 2 f'
-\end{verbatim}
-then
-\begin{verbatim}
-	f t1 t2 t3 d1 d2  ===>  f t2
-\end{verbatim}
-The \tr{Nothings} identify type arguments in which the specialised
-version is polymorphic.
-
-\begin{pseudocode}
-data SpecEnv = SpecEnv [SpecInfo]
-
-mkSpecEnv = SpecEnv
-nullSpecEnv = SpecEnv []
-addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs)
-
-
-lookupConstMethodId :: Id -> Type -> Maybe Id
-    -- slight variant on "lookupSpecEnv" below
-
-lookupConstMethodId sel_id spec_ty
-  = case (getInfo (getIdInfo sel_id)) of
-      SpecEnv spec_infos -> firstJust (map try spec_infos)
-  where
-    try (SpecInfo (Just ty:nothings) _ const_meth_id)
-      = ASSERT(all nothing_is_nothing nothings)
-	case (cmpType True{-properly-} ty spec_ty) of
-	  EQ_ -> Just const_meth_id
-	  _   -> Nothing
-
-    nothing_is_nothing Nothing = True  -- debugging only
-    nothing_is_nothing _ = panic "nothing_is_nothing!"
-
-lookupSpecId :: Id		-- *un*specialised Id
-	     -> [Maybe Type]	-- types to which it is to be specialised
-	     -> Id		-- specialised Id
-
-lookupSpecId unspec_id ty_maybes
-  = case (getInfo (getIdInfo unspec_id))  of { SpecEnv spec_infos ->
-
-    case (firstJust (map try spec_infos)) of
-      Just id -> id
-      Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id)))
-    }
-  where
-    try (SpecInfo template_maybes _ id)
-	| and (zipWith same template_maybes ty_maybes)
-	&& length template_maybes == length ty_maybes = Just id
-	| otherwise 				      = Nothing
-
-    same Nothing    Nothing    = True
-    same (Just ty1) (Just ty2) = ty1 == ty2
-    same _	    _	       = False
-
-lookupSpecEnv :: SpecEnv
-	      -> [Type]
-	      -> Maybe (Id,
-			[Type],
-			Int)
-
-lookupSpecEnv (SpecEnv []) _ = Nothing 	-- rather common case
-
-lookupSpecEnv spec_env [] = Nothing	-- another common case
-
-	-- This can happen even if there is a non-empty spec_env, because
-	-- of eta reduction.  For example, we might have a defn
-	--
-	--	f = /\a -> \d -> g a d
-	-- which gets transformed to
-	--	f = g
-	--
-	-- Now g isn't applied to any arguments
-
-lookupSpecEnv se@(SpecEnv spec_infos) spec_tys
-  = select_match spec_infos
-  where
-    select_match []		-- no matching spec_infos
-      = Nothing
-    select_match (SpecInfo ty_maybes toss spec_id : rest)
-      = case (match ty_maybes spec_tys) of
-	  Nothing       -> select_match rest
-	  Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest
-
-	-- Ambiguity can only arise as a result of specialisations with
-	-- an explicit spec_id. The best match is deemed to be the match
-	-- with least polymorphism i.e. has the least number of tys left.
-	-- This is a non-critical approximation. The only type arguments
-	-- where there may be some discretion is for non-overloaded boxed
-	-- types. Unboxed types must be matched and we insist that we
-	-- always specialise on overloaded types (and discard all the dicts).
-
-    select_next best _ toss []
-      =	case best of
-	    [match] -> Just match	-- Unique best match
-	    ambig   -> pprPanic "Ambiguous Specialisation:\n"
-				(ppAboves [ppStr "(check specialisations with explicit spec ids)",
-					   ppCat (ppStr "between spec ids:" :
-						  map (ppr PprDebug) [id | (id, _, _) <- ambig]),
-					   pp_stuff])
-
-    select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest)
-      = ASSERT(dnum == toss)
-	case (match ty_maybes spec_tys) of
-	  Nothing       -> select_next best tnum dnum rest
-	  Just tys_left ->
-	     let tys_len = length tys_left in
-	     case _tagCmp tnum tys_len of
-	       _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest	-- better match
-	       _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest	-- equivalent match
-	       _GT -> select_next best tnum dnum rest				-- worse match
-
-
-    match [{-out of templates-}] [] = Just []
-
-    match (Nothing:ty_maybes) (spec_ty:spec_tys)
-      = case (isUnboxedDataType spec_ty) of
-	  True  -> Nothing	-- Can only match boxed type against
-				-- type argument which has not been
-				-- specialised on
-	  False -> case match ty_maybes spec_tys of
-		     Nothing  -> Nothing
-		     Just tys -> Just (spec_ty:tys)
-
-    match (Just ty:ty_maybes) (spec_ty:spec_tys)
-      = case (cmpType True{-properly-} ty spec_ty) of
-	  EQ_   -> match ty_maybes spec_tys
-	  other -> Nothing
-
-    match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff
-		 -- This is a Real Problem
-
-    match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff
-		 -- Partial eta abstraction might make this happen;
-		 -- meanwhile let's leave in the check
-
-    pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys)
-\end{pseudocode}
-
-
-\begin{pseudocode}
-instance OptIdInfo SpecEnv where
-    noInfo = nullSpecEnv
-
-    getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
-
-    addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec)
-	= IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j
-	-- We *add* the new specialisation info rather than just replacing it
-	-- so that we don't lose old specialisation details.
-
-    ppInfo sty better_id_fn spec_env
-      = pp_specs sty True better_id_fn nullIdEnv spec_env
-
-pp_specs sty _ _ _ (SpecEnv [])  = pp_NONE
-pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs)
-  = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [
-       ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack,
-	      ppInt numds,
-	      let
-		 better_spec_id = better_id_fn spec_id
-		 spec_id_info = getIdInfo better_spec_id
-	      in
-	      if not print_spec_ids || boringIdInfo spec_id_info then
-		 ppNil
-	      else
-		 ppCat [ppChar '{',
-			ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info,
-			ppChar '}']
-	     ]
-       | (SpecInfo ty_maybes numds spec_id) <- specs ])
-  where
-    pp_the_list [p]    = p
-    pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps]
-
-    pp_maybe Nothing  = ifPprInterface sty pp_NONE
-    pp_maybe (Just t) = pprParendType sty t
-\end{pseudocode}
+addOneToSpecEnv :: SpecEnv -> [Type] -> CoreExpr -> MaybeErr SpecEnv ([Type], SimplifiableCoreExpr)
+addOneToSpecEnv (SpecEnv env) tys rhs 
+  = --pprTrace "addOneToSpecEnv" (ppAbove (ppr PprDebug tys) (ppr PprDebug rhs)) $
+    case (insertMEnv matchTys env tys (occurAnalyseGlobalExpr rhs)) of
+	Succeeded menv -> Succeeded (SpecEnv menv)
+	Failed err     -> Failed err
 
+lookupSpecEnv :: SpecEnv -> [Type] -> Maybe (SimplifiableCoreExpr, ([(TyVar,Type)], [Type]))
+lookupSpecEnv (SpecEnv env) tys 
+  | all isTyVarTy tys = Nothing	-- Short cut: no specialisation for simple tyvars
+  | otherwise	      = --pprTrace "lookupSpecEnv" (ppr PprDebug tys) $
+			lookupMEnv matchTys env tys
+\end{code}