X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=815c0d1cfb2222319b65e8e49b185cedd4b1ba26;hb=bf902b277afa1feff586f7d96178b59be2cfcfe2;hp=48fad92d5e5922cf88962616e92517c711e820ed;hpb=2454d08942e0422ae90445fa2edbef8927a512d7;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 48fad92..815c0d1 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-		 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
+                 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
 		 DsEvBind(..), AutoScc(..)
   ) where
 
@@ -56,7 +56,6 @@ import OrdList
 import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString
--- import StaticFlags	( opt_DsMultiTyVar )
 import Util
 
 import MonadUtils
@@ -90,7 +89,7 @@ dsLHsBind auto_scc (L loc bind)
 dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
 
 dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
-  = do	{ core_expr <- dsLExpr expr
+  = do  { core_expr <- dsLExpr expr
 
 	        -- Dictionary bindings are always VarBinds,
 	        -- so we only need do this here
@@ -98,7 +97,7 @@ dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardle
 	; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
 	      	   | otherwise         = var
 
-	; return (unitOL (var', core_expr')) }
+	; return (unitOL (makeCorePair var' False 0 core_expr')) }
 
 dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches
 		    , fun_co_fn = co_fn, fun_tick = tick 
@@ -261,8 +260,8 @@ dsEvGroup (CyclicSCC bs)
     ds_pair (EvBind v r) = (v, dsEvTerm r)
 
 dsEvTerm :: EvTerm -> CoreExpr
-dsEvTerm (EvId v)      		 = Var v
-dsEvTerm (EvCast v co) 		 = Cast (Var v) co 
+dsEvTerm (EvId v)                = Var v
+dsEvTerm (EvCast v co)           = Cast (Var v) co
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
 dsEvTerm (EvCoercion co)         = Type co
 dsEvTerm (EvSuperClass d n)
@@ -527,41 +526,28 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
   where
     is_local_id = isJust mb_poly_rhs
     poly_rhs | Just rhs <-  mb_poly_rhs
-             = rhs
-             | Just unfolding <- maybeUnfoldingTemplate (idUnfolding poly_id)
-             = unfolding
+             = rhs  	    -- Local Id; this is its rhs
+             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+             = unfolding    -- Imported Id; this is its unfolding
+	       		    -- Use realIdUnfolding so we get the unfolding 
+			    -- even when it is a loop breaker. 
+			    -- We want to specialise recursive functions!
              | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
-	-- In the Nothing case the specialisation is for an imported Id
-	-- whose unfolding gives the RHS to be specialised
-        -- The type checker has checked that it has an unfolding
+	                    -- The type checker has checked that it *has* an unfolding
 
 specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
               -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
+{-   [Dec 10: TEMPORARILY commented out, until we can straighten out how to
+              generate unfoldings for specialised DFuns
+
 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
        ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
+-}
 specUnfolding _ _ _
   = return (noUnfolding, nilOL)
 
-{-
-mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
--- If any of the tyvars is missing from any of the lists in 
--- the second arg, return a binding in the result
-mkArbitraryTypeEnv tyvars exports
-  = go emptyVarEnv exports
-  where
-    go env [] = env
-    go env ((ltvs, _, _, _) : exports)
-	= go env' exports
-        where
-          env' = foldl extend env [tv | tv <- tyvars
-			              , not (tv `elem` ltvs)
-				      , not (tv `elemVarEnv` env)]
-
-    extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
--}
-
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
 \end{code}