X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;h=369660a93984ebf5b34290f76621ab9d3d19ba37;hb=d1675fe00e1972a0acf130b0e484ac83e908ff0a;hp=9cb09ed73e5b83af7475646a631cd3e3a9b1ef42;hpb=db95d6e8d319b0c5cee1ccc23751e8190152ade3;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 9cb09ed..369660a 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -8,32 +8,34 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
 lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
-module DsBinds ( dsMonoBinds, AutoScc(..) ) where
+module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where
 
 #include "HsVersions.h"
 
 
-import {-# SOURCE #-}	DsExpr( dsExpr )
+import {-# SOURCE #-}	DsExpr( dsLExpr )
+import {-# SOURCE #-}	Match( matchWrapper )
 
-import HsSyn		-- lots of things
-import CoreSyn		-- lots of things
-import CoreUtils	( exprType, mkInlineMe, mkSCC )
-import TcHsSyn		( TypecheckedMonoBinds )
 import DsMonad
 import DsGRHSs		( dsGuarded )
 import DsUtils
-import Match		( matchWrapper )
+
+import HsSyn		-- lots of things
+import CoreSyn		-- lots of things
+import CoreUtils	( exprType, mkInlineMe, mkSCC )
 
 import CmdLineOpts	( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
 import CostCentre	( mkAutoCC, IsCafCC(..) )
 import Id		( idType, idName, isExportedId, isSpecPragmaId, Id )
 import NameSet
 import VarSet
-import Type		( mkTyVarTy )
-import Subst		( mkTyVarSubst, substTy )
+import Type		( mkTyVarTy, substTyWith )
 import TysWiredIn	( voidTy )
 import Outputable
+import SrcLoc		( Located(..) )
 import Maybe		( isJust )
+import Bag		( bagToList )
+import Monad		( foldM )
 \end{code}
 
 %************************************************************************
@@ -43,22 +45,31 @@ import Maybe		( isJust )
 %************************************************************************
 
 \begin{code}
-dsMonoBinds :: AutoScc			-- scc annotation policy (see below)
-	    -> TypecheckedMonoBinds
-	    -> [(Id,CoreExpr)]		-- Put this on the end (avoid quadratic append)
-	    -> DsM [(Id,CoreExpr)]	-- Result
+dsHsNestedBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
+dsHsNestedBinds binds = dsHsBinds NoSccs binds []
+
+dsHsBinds :: AutoScc		 -- scc annotation policy (see below)
+	  -> LHsBinds Id
+	  -> [(Id,CoreExpr)]	 -- Put this on the end (avoid quadratic append)
+	  -> DsM [(Id,CoreExpr)] -- Result
 
-dsMonoBinds _ EmptyMonoBinds rest = returnDs rest
+dsHsBinds auto_scc binds rest
+  =  foldM (dsLHsBind auto_scc) rest (bagToList binds)
 
-dsMonoBinds auto_scc (AndMonoBinds  binds_1 binds_2) rest
-  = dsMonoBinds auto_scc binds_2 rest	`thenDs` \ rest' ->
-    dsMonoBinds auto_scc binds_1 rest'
+dsLHsBind :: AutoScc
+	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
+	 -> LHsBind Id
+	 -> DsM [(Id,CoreExpr)] -- Result
+dsLHsBind auto_scc rest (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
 
-dsMonoBinds _ (CoreMonoBind var core_expr) rest
-  = returnDs ((var, core_expr) : rest)
+dsHsBind :: AutoScc
+	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
+	 -> HsBind Id
+	 -> DsM [(Id,CoreExpr)] -- Result
 
-dsMonoBinds _ (VarMonoBind var expr) rest
-  = dsExpr expr			`thenDs` \ core_expr ->
+dsHsBind auto_scc rest (VarBind var expr)
+  = dsLExpr expr		`thenDs` \ core_expr ->
 
 	-- Dictionary bindings are always VarMonoBinds, so
 	-- we only need do this here
@@ -76,54 +87,58 @@ dsMonoBinds _ (VarMonoBind var expr) rest
 
     returnDs ((var, core_expr'') : rest)
 
-dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
-  = putSrcLocDs locn	$
-    matchWrapper (FunMatch fun) matches error_string	`thenDs` \ (args, body) ->
+dsHsBind auto_scc rest (FunBind (L _ fun) _ matches)
+  = matchWrapper (FunRhs (idName fun)) matches		`thenDs` \ (args, body) ->
     addAutoScc auto_scc (fun, mkLams args body)		`thenDs` \ pair ->
     returnDs (pair : rest)
-  where
-    error_string = "function " ++ showSDoc (ppr fun)
 
-dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
-  = putSrcLocDs locn $
-    dsGuarded grhss				`thenDs` \ body_expr ->
+dsHsBind auto_scc rest (PatBind pat grhss ty)
+  = dsGuarded grhss ty				`thenDs` \ body_expr ->
     mkSelectorBinds pat body_expr		`thenDs` \ sel_binds ->
-    mapDs (addAutoScc auto_scc) sel_binds	`thenDs` \ sel_binds ->
+    mappM (addAutoScc auto_scc) sel_binds	`thenDs` \ sel_binds ->
     returnDs (sel_binds ++ rest)
 
 	-- Common special case: no type or dictionary abstraction
-dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
-  = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
-    let 
-	exports' = [(global, Var local) | (_, global, local) <- exports]
+	-- For the (rare) case when there are some mixed-up
+	-- dictionary bindings (for which a Rec is convenient)
+	-- we reply on the enclosing dsBind to wrap a Rec around.
+dsHsBind auto_scc rest (AbsBinds [] [] exports inlines binds)
+  = dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
+    let
+	core_prs' = addLocalInlines exports inlines core_prs
+	exports'  = [(global, Var local) | (_, global, local) <- exports]
     in
-    returnDs (addLocalInlines exports inlines core_prs ++ exports' ++ rest)
+    returnDs (core_prs' ++ exports' ++ rest)
 
 	-- Another common case: one exported variable
 	-- Non-recursive bindings come through this way
-dsMonoBinds auto_scc
-     (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest
+dsHsBind auto_scc rest
+     (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds)
   = ASSERT( all (`elem` tyvars) all_tyvars )
-    dsMonoBinds (addSccs auto_scc exps) binds []	`thenDs` \ core_prs ->
+    dsHsBinds (addSccs auto_scc exps) binds []	`thenDs` \ core_prs ->
     let 
 	-- Always treat the binds as recursive, because the typechecker
 	-- makes rather mixed-up dictionary bindings
-	core_binds = [Rec core_prs]
-	global'    = (global, mkInline (idName global `elemNameSet` inlines) $
+	core_bind = Rec core_prs
+
+	-- The mkInline does directly what the 
+	-- addLocalInlines do in the other cases
+	export'    = (global, mkInline (idName global `elemNameSet` inlines) $
 			      mkLams tyvars $ mkLams dicts $ 
-	                      mkDsLets core_binds (Var local))
+	                      Let core_bind (Var local))
     in
-    returnDs (global' : rest)
+    returnDs (export' : rest)
 
-dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
-  = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
+dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds)
+  = dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
     let 
-	core_binds = [Rec (addLocalInlines exports inlines core_prs)]
+	-- Rec because of mixed-up dictionary bindings
+	core_bind = Rec (addLocalInlines exports inlines core_prs)
 
 	tup_expr      = mkTupleExpr locals
 	tup_ty	      = exprType tup_expr
 	poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
-		        mkDsLets core_binds tup_expr
+		        Let core_bind tup_expr
 	locals        = [local | (_, _, local) <- exports]
 	local_tys     = map idType locals
     in
@@ -131,21 +146,21 @@ dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
     let
 	dict_args = map Var dicts
 
-	mk_bind (tyvars, global, local) n	-- locals !! n == local
+	mk_bind ((tyvars, global, local), n)	-- locals !! n == local
 	  = 	-- Need to make fresh locals to bind in the selector, because
 		-- some of the tyvars will be bound to voidTy
-	    newSysLocalsDs (map (substTy env) local_tys) 	`thenDs` \ locals' ->
-	    newSysLocalDs  (substTy env tup_ty)			`thenDs` \ tup_id ->
+	    newSysLocalsDs (map substitute local_tys) 	`thenDs` \ locals' ->
+	    newSysLocalDs  (substitute tup_ty)		`thenDs` \ tup_id ->
 	    returnDs (global, mkLams tyvars $ mkLams dicts $
 		              mkTupleSelector locals' (locals' !! n) tup_id $
 		              mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
 	  where
 	    mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
 				| otherwise		  = voidTy
-	    ty_args = map mk_ty_arg all_tyvars
-	    env     = mkTyVarSubst all_tyvars ty_args
+	    ty_args    = map mk_ty_arg all_tyvars
+	    substitute = substTyWith all_tyvars ty_args
     in
-    zipWithDs mk_bind exports [0..]		`thenDs` \ export_binds ->
+    mappM mk_bind (exports `zip` [0..])		`thenDs` \ export_binds ->
      -- don't scc (auto-)annotate the tuple itself.
     returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest))
 \end{code}