[project @ 1998-04-07 16:40:08 by simonpj]

Specialiser really nearly working!

ghc/compiler/basicTypes/Id.lhs

@@ -251,10 +251,10 @@ instantiated before use.
 \begin{code}
 mkTemplateLocals :: [Type] -> [Id]
 mkTemplateLocals tys
-  = zipWith mk (getBuiltinUniques (length tys)) tys
+  = zipWith3 mk (getBuiltinUniques (length tys)) tys [1..]
   where
-    mk uniq ty = mkVanillaId (mkSysLocalName uniq SLIT("tpl") mkBuiltinSrcLoc)
-			     ty noIdInfo
+    mk uniq ty n = mkVanillaId (mkSysLocalName uniq (_PK_ ("x"++show n)) mkBuiltinSrcLoc)
+			       ty noIdInfo
 \end{code}
 
 

ghc/compiler/coreSyn/CoreUnfold.lhs

@@ -53,6 +53,7 @@ import Id		( Id, idType, getIdArity,  isBottomingId, isDataCon,
 			  IdSet )
 import PrimOp		( fragilePrimOp, primOpCanTriggerGC )
 import IdInfo		( ArityInfo(..), InlinePragInfo(..) )
+import Name		( isExported )
 import Literal		( isNoRepLit )
 import TyCon		( tyConFamilySize )
 import Type		( splitAlgTyConApp_maybe )
@@ -513,7 +514,9 @@ rule this out.  Since ManyOcc doesn't record FunOcc/ArgOcc
 inlineUnconditionally :: (Id,BinderInfo) -> Bool
 
 inlineUnconditionally (id, occ_info)
-  |  idMustNotBeINLINEd id = False
+  |  idMustNotBeINLINEd id 
+  || isExported id
+  =  False
 
   |  isOneSameSCCFunOcc occ_info
   && idWantsToBeINLINEd id = True

ghc/compiler/main/MkIface.lhs

@@ -315,10 +315,12 @@ ifaceId get_idinfo needed_ids is_rec id rhs
     ------------  Specialisations --------------
     spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
     pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
-				       brackets (interpp'SP tyvars),
+				       if null tyvars then ptext SLIT("[ ]")
+						      else brackets (interpp'SP tyvars),
+					-- The lexer interprets "[]" as a CONID.  Sigh.
 				       hsep (map pprParendType tys),
 				       ptext SLIT("="),
-				       ppr rhs
+				       pprIfaceUnfolding rhs
 				 ]					
     
     ------------  Extra free Ids  --------------

ghc/compiler/rename/ParseIface.y

@@ -486,8 +486,13 @@ id_info_item	: ARITY_PART arity_info			{ HsArity $2 }
 		| strict_info				{ HsStrictness $1 }
 		| BOTTOM 				{ HsStrictness HsBottom }
 		| UNFOLD_PART core_expr			{ HsUnfold $1 $2 }
-                | SPECIALISE OBRACK tv_bndrs CBRACK 
-                     atypes EQUAL core_expr             { HsSpecialise $3 $5 $7 }
+                | SPECIALISE spec_tvs
+                     atypes EQUAL core_expr             { HsSpecialise $2 $3 $5 }
+
+
+spec_tvs	:: { [HsTyVar RdrName] }
+spec_tvs	: OBRACK tv_bndrs CBRACK 		{ $2 }
+	
 
 arity_info	:: { ArityInfo }
 arity_info	: INTEGER					{ exactArity (fromInteger $1) }

ghc/compiler/rename/RnBinds.lhs

@@ -25,7 +25,7 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnExpr		( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
-import RnEnv		( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, 
+import RnEnv		( bindLocatedLocalsRn, lookupBndrRn, lookupOccRn, lookupGlobalOccRn,
 			  newLocalNames, isUnboundName, warnUnusedBinds
 			)
 import CmdLineOpts	( opt_SigsRequired )
@@ -341,23 +341,21 @@ rnMethodBinds (AndMonoBinds mb1 mb2)
   = andRn AndMonoBinds (rnMethodBinds mb1)
 		       (rnMethodBinds mb2)
 
-rnMethodBinds (FunMonoBind occname inf matches locn)
+rnMethodBinds (FunMonoBind name inf matches locn)
   = pushSrcLocRn locn				   $
-    mapRn (checkPrecMatch inf occname) matches	`thenRn_`
+    mapRn (checkPrecMatch inf name) matches	`thenRn_`
 
-    newLocalNames [(occname, locn)]		`thenRn` \ [op_name] ->
-	-- Make a fresh local for the bound variable; it must be different
-	-- to occurrences of the same thing on the LHS, which refer to the global
-	-- selectors.
+    lookupGlobalOccRn name			`thenRn` \ sel_name -> 
+	-- We use the selector name as the binder
 
     mapAndUnzipRn rnMatch matches		`thenRn` \ (new_matches, _) ->
-    returnRn (FunMonoBind op_name inf new_matches locn)
+    returnRn (FunMonoBind sel_name inf new_matches locn)
 
-rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
+rnMethodBinds (PatMonoBind (VarPatIn name) grhss_and_binds locn)
   = pushSrcLocRn locn			$
-    newLocalNames [(occname, locn)]	`thenRn` \ [op_name] ->
+    lookupGlobalOccRn name			`thenRn` \ sel_name -> 
     rnGRHSsAndBinds grhss_and_binds	`thenRn` \ (grhss_and_binds', _) ->
-    returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+    returnRn (PatMonoBind (VarPatIn sel_name) grhss_and_binds' locn)
 
 -- Can't handle method pattern-bindings which bind multiple methods.
 rnMethodBinds mbind@(PatMonoBind other_pat _ locn)

ghc/compiler/rename/RnEnv.lhs

@@ -276,37 +276,61 @@ ifaceFlavour name = case getNameProvenance name of
 Looking up a name in the RnEnv.
 
 \begin{code}
-lookupRn :: NameEnv -> RdrName -> RnMS s Name
-lookupRn name_env rdr_name
-  = case lookupFM name_env rdr_name of
-
-	-- Found it!
-	Just name -> returnRn name
-
-	-- Not found
-	Nothing -> getModeRn	`thenRn` \ mode ->
-		   case mode of 
-			-- Not found when processing source code; so fail
-			SourceMode    -> failWithRn (mkUnboundName rdr_name)
-					            (unknownNameErr rdr_name)
+checkUnboundRn :: RdrName -> Maybe Name -> RnMS s Name
+checkUnboundRn rdr_name (Just name) 
+  = 	-- Found it!
+     returnRn name
+
+checkUnboundRn rdr_name Nothing
+  =	-- Not found by lookup
+    getModeRn	`thenRn` \ mode ->
+    case mode of 
+	-- Not found when processing source code; so fail
+	SourceMode    -> failWithRn (mkUnboundName rdr_name)
+			            (unknownNameErr rdr_name)
 		
-			-- Not found when processing an imported declaration,
-			-- so we create a new name for the purpose
-			InterfaceMode _ -> 
-			    case rdr_name of
+	-- Not found when processing an imported declaration,
+	-- so we create a new name for the purpose
+	InterfaceMode _ _ -> 
+	    case rdr_name of
+		Qual mod_name occ hif -> newImportedGlobalName mod_name occ hif
 
-				Qual mod_name occ hif -> newGlobalName mod_name occ hif
-
-				-- An Unqual is allowed; interface files contain 
-				-- unqualified names for locally-defined things, such as
-				-- constructors of a data type.
-				Unqual occ -> getModuleRn 	`thenRn ` \ mod_name ->
-					      newGlobalName mod_name occ HiFile
+		-- An Unqual is allowed; interface files contain 
+		-- unqualified names for locally-defined things, such as
+		-- constructors of a data type.
+		Unqual occ -> getModuleRn 	`thenRn ` \ mod_name ->
+			      newImportedGlobalName mod_name occ HiFile
 
 
 lookupBndrRn rdr_name
-  = getNameEnv 			`thenRn` \ name_env ->
-    lookupRn name_env rdr_name
+  = lookupNameRn rdr_name		`thenRn` \ maybe_name ->
+    checkUnboundRn rdr_name maybe_name	`thenRn` \ name ->
+
+    if isLocalName name then
+	returnRn name
+    else
+
+	----------------------------------------------------
+	-- OK, so we're at the binding site of a top-level defn
+	-- Check to see whether its an imported decl
+    getModeRn		`thenRn` \ mode ->
+    case mode of {
+	  SourceMode -> returnRn name ;
+
+	  InterfaceMode _ print_unqual_fn -> 
+
+	----------------------------------------------------
+	-- OK, the binding site of an *imported* defn
+	-- so we can make the provenance more informative
+    getSrcLocRn		`thenRn` \ src_loc ->
+    let
+	name' = case getNameProvenance name of
+		    NonLocalDef _ hif _ -> setNameProvenance name 
+						(NonLocalDef src_loc hif (print_unqual_fn name'))
+		    other		-> name
+    in
+    returnRn name'
+    }
 
 -- Just like lookupRn except that we record the occurrence too
 -- Perhaps surprisingly, even wired-in names are recorded.
@@ -314,17 +338,25 @@ lookupBndrRn rdr_name
 -- deciding which instance declarations to import.
 lookupOccRn :: RdrName -> RnMS s Name
 lookupOccRn rdr_name
-  = getNameEnv 			`thenRn` \ name_env ->
-    lookupRn name_env rdr_name	`thenRn` \ name ->
-    addOccurrenceName name
+  = lookupNameRn rdr_name		`thenRn` \ maybe_name ->
+    checkUnboundRn rdr_name maybe_name	`thenRn` \ name ->
+    let
+	name' = mungePrintUnqual rdr_name name
+    in
+    addOccurrenceName name'
 
 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global 
--- environment.  It's used for record field names only.
+-- environment.  It's used only for
+--	record field names
+--	class op names in class and instance decls
 lookupGlobalOccRn :: RdrName -> RnMS s Name
 lookupGlobalOccRn rdr_name
-  = getGlobalNameEnv		`thenRn` \ name_env ->
-    lookupRn name_env rdr_name	`thenRn` \ name ->
-    addOccurrenceName name
+  = lookupGlobalNameRn rdr_name		`thenRn` \ maybe_name ->
+    checkUnboundRn rdr_name maybe_name	`thenRn` \ name ->
+    let
+	name' = mungePrintUnqual rdr_name name
+    in
+    addOccurrenceName name'
 
 
 -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified

ghc/compiler/rename/RnExpr.lhs

@@ -39,6 +39,7 @@ import TysPrim		( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
 import Name
 import UniqFM		( isNullUFM )
 import UniqSet		( emptyUniqSet, unionManyUniqSets, UniqSet )
+import Unique		( assertIdKey )
 import Util		( removeDups )
 import Outputable
 \end{code}
@@ -249,23 +250,15 @@ rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 
 rnExpr (HsVar v)
   = lookupOccRn v	`thenRn` \ name ->
-    case res of
-      Left (nm,err) 
-        | opt_GlasgowExts && v == assertRdrName -> 
-            -- if `assert' is not in scope,
-	    -- we expand it to (GHCerr.assert__ location)
-           mkAssertExpr  `thenRn` \ (expr, assert_name) ->
-	   returnRn (expr, unitNameSet assert_name)
-
-        | otherwise -> -- a failure after all.
-	   failWithRn nm err `thenRn_`
-           returnRn (HsVar nm, if isLocallyDefined nm
-			       then unitNameSet nm
-			       else emptyUniqSet)
-      Right vname -> 
-       returnRn (HsVar vname, if isLocallyDefined vname
-			      then unitNameSet vname
-			      else emptyUniqSet)
+    if nameUnique name == assertIdKey then
+	-- We expand it to (GHCerr.assert__ location)
+        mkAssertExpr  `thenRn` \ expr ->
+	returnRn (expr, emptyUniqSet)
+    else
+        -- The normal case
+       returnRn (HsVar name, if isLocallyDefined name
+			     then unitNameSet name
+			     else emptyUniqSet)
 
 rnExpr (HsLit lit) 
   = litOccurrence lit		`thenRn_`
@@ -732,7 +725,7 @@ litOccurrence (HsLitLit _)
 %************************************************************************
 
 \begin{code}
-mkAssertExpr :: RnMS s (RenamedHsExpr, Name)
+mkAssertExpr :: RnMS s RenamedHsExpr
 mkAssertExpr =
   newImportedGlobalName mod occ HiFile `thenRn` \ name ->
   addOccurrenceName name	       `thenRn_`
@@ -741,7 +734,7 @@ mkAssertExpr =
    expr = HsApp (HsVar name)
 	        (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
   in
-  returnRn (expr, name)
+  returnRn expr
 
   where
    mod = rdrNameModule assertErr_RDR

ghc/compiler/simplCore/SimplCore.lhs

@@ -34,7 +34,7 @@ import FloatIn		( floatInwards )
 import FloatOut		( floatOutwards )
 import FoldrBuildWW	( mkFoldrBuildWW )
 import MkId		( mkSysLocal, mkUserId )
-import Id		( setIdVisibility, 
+import Id		( setIdVisibility, getIdSpecialisation, setIdSpecialisation,
                           getIdDemandInfo, idType,
 			  nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
  			  lookupIdEnv, IdEnv, 
@@ -62,8 +62,9 @@ import SAT		( doStaticArgs )
 import SimplMonad	( zeroSimplCount, showSimplCount, SimplCount )
 import SimplPgm		( simplifyPgm )
 import Specialise
+import SpecEnv		( substSpecEnv, isEmptySpecEnv )
 import StrictAnal	( saWwTopBinds )
-import TyVar		( TyVar, nameTyVar )
+import TyVar		( TyVar, nameTyVar, emptyTyVarEnv )
 import Unique		( Unique{-instance Eq-}, Uniquable(..),
 			  integerTyConKey, ratioTyConKey,
 			  mkUnique, incrUnique,
@@ -72,7 +73,7 @@ import Unique		( Unique{-instance Eq-}, Uniquable(..),
 import UniqSupply	( UniqSupply, mkSplitUniqSupply, 
                           splitUniqSupply, getUnique
 		        )
-import UniqFM           ( UniqFM, lookupUFM, addToUFM )
+import UniqFM           ( UniqFM, lookupUFM, addToUFM, delFromUFM )
 import Util		( mapAccumL )
 import SrcLoc		( noSrcLoc )
 import Constants	( tARGET_MIN_INT, tARGET_MAX_INT )
@@ -608,19 +609,49 @@ mapTM f (x:xs) = f x	`thenTM` \ r ->
 
 \begin{code}
 -- Need to extend the environment when we munge a binder, so that occurrences
--- of the binder will print the correct way (i.e. as a global not a local)
+-- of the binder will print the correct way (e.g. as a global not a local)
 mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
 mungeTopBinder id thing_inside mod env us
   =  	-- Give it a new print-name unless it's an exported thing
 	-- setNameVisibility also does the local/global thing
     let
-	(id', us')  | isExported id = (id, us)
+	(id1, us')  | isExported id = (id, us)
 		    | otherwise
 		    = (setIdVisibility (Just mod) us id, 
 		       incrUnique us)
-	new_env    = addToUFM env id (ValBinder id')
+
+	-- Tidy the Id's SpecEnv
+	spec_env   = getIdSpecialisation id
+	id2 | isEmptySpecEnv spec_env = id1
+	    | otherwise		      = setIdSpecialisation id1 (tidySpecEnv env spec_env)
+
+	new_env    = addToUFM env id (ValBinder id2)
     in
-    thing_inside id' mod new_env us'
+    thing_inside id2 mod new_env us'
+
+tidySpecEnv env spec_env
+  = substSpecEnv 
+	emptyTyVarEnv		-- Top level only
+	(tidy_spec_rhs env)
+	spec_env
+  where
+	-- tidy_spec_rhs is another horrid little hacked-up function for
+	-- the RHS of specialisation templates.
+	-- It assumes there is no type substitution.
+	--
+	-- See also SimplVar.substSpecEnvRhs Urgh
+    tidy_spec_rhs env (Var v) = case lookupUFM env v of
+				  Just (ValBinder v') -> Var v'
+				  Nothing	      -> Var v
+    tidy_spec_rhs env (App f (VarArg v)) = App (tidy_spec_rhs env f) (case lookupUFM env v of
+								        Just (ValBinder v') -> VarArg v'
+								        Nothing	            -> VarArg v)
+    tidy_spec_rhs env (App f arg) = App (tidy_spec_rhs env f) arg
+    tidy_spec_rhs env (Lam b e)   = Lam b (tidy_spec_rhs env' e)
+				  where
+				    env' = case b of
+					     ValBinder id -> delFromUFM env id
+					     TyBinder _   -> env
 
 mungeTopBinders []     k = k []
 mungeTopBinders (b:bs) k = mungeTopBinder b	$ \ b' ->

ghc/compiler/simplCore/SimplVar.lhs

@@ -198,7 +198,7 @@ simplBinder env (id, occ_info)
 
        -- id2 has its SpecEnv zapped
        id2 | isEmptySpecEnv spec_env = id1
-           | otherwise               = setIdSpecialisation id spec_env'
+           | otherwise               = setIdSpecialisation id1 spec_env'
     in
     if not_in_scope then
 	-- No need to clone, but we *must* zap any current substitution

ghc/compiler/specialise/Specialise.lhs

@@ -12,7 +12,7 @@ module Specialise (
 #include "HsVersions.h"
 
 import MkId		( mkUserLocal )
-import Id		( Id, DictVar, idType, 
+import Id		( Id, DictVar, idType, mkTemplateLocals,
 
 			  getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
 
@@ -26,7 +26,7 @@ import Type		( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy,
 			  tyVarsOfType, tyVarsOfTypes, applyTys, mkForAllTys
 			)
 import TyCon		( TyCon )
-import TyVar		( TyVar,
+import TyVar		( TyVar, alphaTyVars,
 			  TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets,
 			   	    elementOfTyVarSet, unionTyVarSets, emptyTyVarSet,
 			  TyVarEnv, mkTyVarEnv, delFromTyVarEnv
@@ -710,7 +710,7 @@ specBind (NonRec bndr rhs) body_uds
 
   | isSpecPragmaId bndr
   = specExpr rhs				`thenSM` \ (rhs', rhs_uds) ->
-    returnSM ([], rhs_uds)
+    returnSM ([], rhs_uds `plusUDs` body_uds)
 
   | otherwise
   =   -- Deal with the RHS, specialising it according
@@ -779,7 +779,7 @@ specDefn calls (fn, rhs)
     (tyvars, theta, tau) = splitSigmaTy fn_type
     n_tyvars		 = length tyvars
     n_dicts		 = length theta
-    mk_spec_tys call_ts  = zipWith mk_spec_ty call_ts tyvars
+    mk_spec_tys call_ts  = zipWith mk_spec_ty call_ts alphaTyVars
                          where
                            mk_spec_ty (Just ty) _     = ty
                            mk_spec_ty Nothing   tyvar = mkTyVarTy tyvar
@@ -794,11 +794,6 @@ specDefn calls (fn, rhs)
 			Nothing -> []
 			Just cs -> fmToList cs
 
-    -- Filter out calls for which we already have a specialisation
-    calls_to_spec        = filter spec_me calls_for_me
-    spec_me (call_ts, _) = not (maybeToBool (lookupSpecEnv id_spec_env (mk_spec_tys call_ts)))
-    id_spec_env          = getIdSpecialisation fn
-
     ----------------------------------------------------------
 	-- Specialise to one particular call pattern
     spec_call :: ProtoUsageDetails          -- From the original body, captured by
@@ -817,13 +812,14 @@ specDefn calls (fn, rhs)
 		-- 	f1 = /\ b d -> (..rhs of f..) t1 b t3 d d1 d2
 		-- and the type of this binder
         let
-           spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts]
+           spec_tyvars = [tyvar | (tyvar, Nothing) <- alphaTyVars `zip` call_ts]
 	   spec_tys    = mk_spec_tys call_ts
 	   spec_rhs    = mkTyLam spec_tyvars $
                          mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds)
   	   spec_id_ty  = mkForAllTys spec_tyvars (instantiateTy ty_env tau)
 	   ty_env      = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys)
 	in
+
 	newIdSM fn spec_id_ty		`thenSM` \ spec_f ->
 
 
@@ -833,8 +829,11 @@ specDefn calls (fn, rhs)
 		-- dictionaries, so it's tidier to make new local variables
 		-- for the lambdas in the RHS, rather than lambda-bind the
 		-- dictionaries themselves.
-	mapSM (\d -> newIdSM d (idType d)) call_ds	`thenSM` \ arg_ds ->
+		--
+		-- In fact we use the standard template locals, so that the
+		-- they don't need to be "tidied" before putting in interface files
 	let
+	   arg_ds	 = mkTemplateLocals (map idType call_ds)
 	   spec_env_rhs  = mkValLam arg_ds $
 			   mkTyApp (Var spec_f) $
 			   map mkTyVarTy spec_tyvars
@@ -1074,6 +1073,7 @@ dictRhsFVs e
   = go e
   where
     go (App e1 (VarArg a)) = go e1 `addOneToIdSet` a
+    go (App e1 (LitArg l)) = go e1
     go (App e1 (TyArg t))  = go e1
     go (Var v)	           = unitIdSet v
     go (Lit l)	           = emptyIdSet

ghc/compiler/stranal/WorkWrap.lhs

@@ -15,7 +15,7 @@ import CmdLineOpts	( opt_UnfoldingCreationThreshold )
 import CoreUtils	( coreExprType )
 import MkId		( mkWorkerId )
 import Id		( getInlinePragma, getIdStrictness,
-			  addIdStrictness, addInlinePragma,
+			  addIdStrictness, addInlinePragma, idWantsToBeINLINEd,
 			  IdSet, emptyIdSet, addOneToIdSet,
 			  GenId, Id
 			)
@@ -179,9 +179,10 @@ tryWW	:: Id				-- The fn binder
 					-- if two, then a worker and a
 					-- wrapper.
 tryWW fn_id rhs
-  | (certainlySmallEnoughToInline fn_id $
-     calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
-    )
+  |  idWantsToBeINLINEd fn_id 
+  || (certainlySmallEnoughToInline fn_id $
+      calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
+     )
 	    -- No point in worker/wrappering something that is going to be
 	    -- INLINEd wholesale anyway.  If the strictness analyser is run
 	    -- twice, this test also prevents wrappers (which are INLINEd)

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -40,7 +40,7 @@ import MkId		( mkDataCon, mkSuperDictSelId,
 			  mkMethodSelId, mkDefaultMethodId
 			)