X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBinds.lhs;h=5540dd806ba2312c8352fce097f7461cb3637ac5;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=4d2f9f15dde66cf24a867421dcfbb977ce6998ce;hpb=e5ca7e6e5137a2e6081717e5e90ca52a30840f68;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 4d2f9f1..5540dd8 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -10,6 +10,13 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
 lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
 		 dsCoercion,
 		 AutoScc(..)
@@ -46,7 +53,6 @@ import BasicTypes hiding ( TopLevel )
 import FastString
 import Util		( mapSnd )
 
-
 import Control.Monad
 import Data.List
 \end{code}
@@ -90,8 +96,9 @@ dsHsBind auto_scc rest (VarBind var expr)
     addDictScc var core_expr	`thenDs` \ core_expr' ->
     returnDs ((var, core_expr') : rest)
 
-dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, fun_tick = tick })
-  = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
+dsHsBind auto_scc rest (FunBind { fun_id = L _ fun, fun_matches = matches, 
+				  fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf })
+  = matchWrapper (FunRhs (idName fun) inf) matches	`thenDs` \ (args, body) ->
     mkOptTickBox tick body 				`thenDs` \ body' ->
     dsCoercion co_fn (return (mkLams args body'))	`thenDs` \ rhs ->
     returnDs ((fun,rhs) : rest)
@@ -168,7 +175,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 		-- Rec because of mixed-up dictionary bindings
 	      core_bind = Rec (map do_one core_prs)
 
-	      tup_expr      = mkTupleExpr locals
+	      tup_expr      = mkBigCoreVarTup locals
 	      tup_ty	    = exprType tup_expr
 	      poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
 	 	     	      Let core_bind tup_expr
@@ -182,7 +189,9 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 	      mk_bind ((tyvars, global, local, prags), n)	-- locals !! n == local
 	        = 	-- Need to make fresh locals to bind in the selector, because
 		      	-- some of the tyvars will be bound to 'Any'
-		  do { locals' <- newSysLocalsDs (map substitute local_tys)
+		  do { ty_args <- mapM mk_ty_arg all_tyvars
+		     ; let substitute = substTyWith all_tyvars ty_args
+		     ; locals' <- newSysLocalsDs (map substitute local_tys)
 		     ; tup_id  <- newSysLocalDs  (substitute tup_ty)
 		     ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) 
 				      	 prags
@@ -193,10 +202,9 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 			         mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
 		     ; returnDs ((global', rhs) : spec_binds) }
 	        where
-	          mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
-	      			      | otherwise		= mkArbitraryType all_tyvar
-	          ty_args    = map mk_ty_arg all_tyvars
-	          substitute = substTyWith all_tyvars ty_args
+	          mk_ty_arg all_tyvar
+			| all_tyvar `elem` tyvars = return (mkTyVarTy all_tyvar)
+	      		| otherwise		  = dsMkArbitraryType all_tyvar
 
 	; export_binds_s <- mappM mk_bind (exports `zip` [0..])
 	     -- don't scc (auto-)annotate the tuple itself.
@@ -264,27 +272,30 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 	  case mb_lhs of
 	    Nothing -> do { warnDs decomp_msg; return Nothing }
 
-	    Just (var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
-		where
-		  local_poly  = setIdNotExported poly_id
+	    Just (var, args) -> do
+	
+	{ f_body <- fix_up (Let mono_bind (Var mono_id))
+
+	; let	  local_poly  = setIdNotExported poly_id
 			-- Very important to make the 'f' non-exported,
 			-- else it won't be inlined!
 		  spec_id     = mkLocalId spec_name spec_ty
 		  spec_rhs    = Let (NonRec local_poly poly_f_body) ds_spec_expr
-		  poly_f_body = mkLams (tvs ++ dicts) $
-			   	fix_up (Let mono_bind (Var mono_id))
-
+		  poly_f_body = mkLams (tvs ++ dicts) f_body
+			   	
 		  rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
 				AlwaysActive poly_name
 			        bndrs args
 				(mkVarApps (Var spec_id) bndrs)
-	} }
+	; return (Just (addInlineInfo inl spec_id spec_rhs, rule))
+	} } }
   where
 	-- Bind to Any any of all_ptvs that aren't 
 	-- relevant for this particular function 
-    fix_up body | null void_tvs = body
-		| otherwise	= mkTyApps (mkLams void_tvs body) 
-					   (map mkArbitraryType void_tvs)
+    fix_up body | null void_tvs = return body
+		| otherwise	= do { void_tys <- mapM dsMkArbitraryType void_tvs
+				     ; return (mkTyApps (mkLams void_tvs body) void_tys) }
+
     void_tvs = all_tvs \\ tvs
 
     dead_msg bs = vcat [ sep [ptext SLIT("Useless constraint") <> plural bs
@@ -295,6 +306,10 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 
     decomp_msg = hang (ptext SLIT("Specialisation too complicated to desugar; ignored"))
 		    2 (ppr spec_expr)
+
+dsMkArbitraryType tv = mkArbitraryType warn tv
+  where
+    warn span msg = putSrcSpanDs span (warnDs msg)
 \end{code}
 
 Note [Unused spec binders]
@@ -456,6 +471,8 @@ dsCoercion (WpApp id)        thing_inside = do { expr <- thing_inside
 					       ; return (App expr (Var id)) }
 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
 					       ; return (App expr (Type ty)) }
+dsCoercion WpInline 	     thing_inside = do { expr <- thing_inside
+					       ; return (mkInlineMe expr) }
 dsCoercion (WpLet bs)        thing_inside = do { prs <- dsLHsBinds bs
 					       ; expr <- thing_inside
 					       ; return (Let (Rec prs) expr) }