X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fspecialise%2FSpecConstr.lhs;h=055f794d2e1f867cbc9b138971c38a1583e142eb;hb=a0a541a8d342d6189d5e76ba65a8e914251d1d84;hp=c9b5998627024ec8602ccb11023fa61ca79f5055;hpb=e5adcaf845207c73da65cb44cff4ef83b76dd4a9;p=ghc-hetmet.git

diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index c9b5998..055f794 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -498,9 +498,9 @@ data ScEnv = SCE { sc_size  :: Maybe Int,	-- Size threshold
 
 ---------------------
 -- As we go, we apply a substitution (sc_subst) to the current term
-type InExpr = CoreExpr		-- *Before* applying the subst
+type InExpr = CoreExpr		-- _Before_ applying the subst
 
-type OutExpr = CoreExpr		-- *After* applying the subst
+type OutExpr = CoreExpr		-- _After_ applying the subst
 type OutId   = Id
 type OutVar  = Var
 
@@ -509,12 +509,12 @@ type HowBoundEnv = VarEnv HowBound	-- Domain is OutVars
 
 ---------------------
 type ValueEnv = IdEnv Value		-- Domain is OutIds
-data Value    = ConVal AltCon [CoreArg]	-- *Saturated* constructors
+data Value    = ConVal AltCon [CoreArg]	-- _Saturated_ constructors
 	      | LambdaVal		-- Inlinable lambdas or PAPs
 
 instance Outputable Value where
    ppr (ConVal con args) = ppr con <+> interpp'SP args
-   ppr LambdaVal	 = ptext SLIT("<Lambda>")
+   ppr LambdaVal	 = ptext (sLit "<Lambda>")
 
 ---------------------
 initScEnv :: DynFlags -> ScEnv
@@ -685,10 +685,10 @@ A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
 -}
 
 instance Outputable ArgOcc where
-  ppr (ScrutOcc xs) = ptext SLIT("scrut-occ") <> ppr xs
-  ppr UnkOcc 	    = ptext SLIT("unk-occ")
-  ppr BothOcc 	    = ptext SLIT("both-occ")
-  ppr NoOcc    	    = ptext SLIT("no-occ")
+  ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs
+  ppr UnkOcc 	    = ptext (sLit "unk-occ")
+  ppr BothOcc 	    = ptext (sLit "both-occ")
+  ppr NoOcc    	    = ptext (sLit "no-occ")
 
 -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
 -- that if the thing is scrutinised anywhere then we get to see that
@@ -707,7 +707,7 @@ combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
 combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
 
 setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
--- *Overwrite* the occurrence info for the scrutinee, if the scrutinee 
+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
 -- is a variable, and an interesting variable
 setScrutOcc env usg (Cast e _) occ = setScrutOcc env usg e occ
 setScrutOcc env usg (Note _ e) occ = setScrutOcc env usg e occ
@@ -796,7 +796,7 @@ scExpr' env (Case scrut b ty alts)
 	   ; let (usg', arg_occs) = lookupOccs usg bs'
 		 scrut_occ = case con of
 				DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
-				_ofther	   -> ScrutOcc emptyUFM
+				_      	   -> ScrutOcc emptyUFM
 	   ; return (usg', scrut_occ, (con,bs',rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
@@ -1024,13 +1024,13 @@ specialise env bind_calls (fn, arg_bndrs, body, arg_occs)
 	; case sc_count env of
 	    Just max | spec_count' > max
 		-> pprTrace "SpecConstr: too many specialisations for one function (see -fspec-constr-count):" 
-			 (vcat [ptext SLIT("Function:") <+> ppr fn,
-				ptext SLIT("Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
+			 (vcat [ptext (sLit "Function:") <+> ppr fn,
+				ptext (sLit "Specialisations:") <+> ppr (pats ++ [p | OS p _ _ _ <- specs])])
 			 return (nullUsage, spec_info)
 
-	    _normal_case -> do
-				
-	{ (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
+	    _normal_case -> do {
+
+	  (spec_usgs, new_specs) <- mapAndUnzipM (spec_one env fn arg_bndrs body)
 					         (pats `zip` [spec_count..])
 
 	; let spec_usg = combineUsages spec_usgs
@@ -1218,7 +1218,7 @@ argToPat in_scope val_env (Cast arg co) arg_occ
 	  else do
 	{ -- Make a wild-card pattern for the coercion
 	  uniq <- getUniqueUs
-	; let co_name = mkSysTvName uniq FSLIT("sg")
+	; let co_name = mkSysTvName uniq (fsLit "sg")
 	      co_var = mkCoVar co_name (mkCoKind ty1 ty2)
 	; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
 
@@ -1288,7 +1288,7 @@ argToPat _in_scope _val_env arg _arg_occ
 
 wildCardPat :: Type -> UniqSM (Bool, CoreArg)
 wildCardPat ty = do { uniq <- getUniqueUs
-		    ; let id = mkSysLocal FSLIT("sc") uniq ty
+		    ; let id = mkSysLocal (fsLit "sc") uniq ty
 		    ; return (False, Var id) }
 
 argsToPats :: InScopeSet -> ValueEnv
@@ -1320,7 +1320,9 @@ isValue env (Var v)
 	-- as well, for let-bound constructors!
 
 isValue env (Lam b e)
-  | isTyVar b = isValue env e
+  | isTyVar b = case isValue env e of
+		  Just _  -> Just LambdaVal
+		  Nothing -> Nothing
   | otherwise = Just LambdaVal
 
 isValue _env expr	-- Maybe it's a constructor application