X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=49e66879a54fe5b3a1f2395e9dfbb3f6103ff2dc;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=4d8284d4d364b75dca92b130b7bbe14376e4f724;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 4d8284d..49e6687 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -10,6 +10,7 @@ module CoreSyn (
 	GenCoreBinding(..), GenCoreExpr(..),
 	GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
 	GenCoreCaseDefault(..),
+	Coercion(..),
 
 	bindersOf, pairsFromCoreBinds, rhssOfBind,
 
@@ -182,6 +183,21 @@ transformations of which we are unaware.
 		(GenCoreExpr val_bdr val_occ tyvar uvar)    -- scc expression
 \end{code}
 
+Coercions arise from uses of the constructor of a @newtype@
+declaration, either in construction (resulting in a @CoreceIn@) or
+pattern matching (resulting in a @CoerceOut@).
+
+\begin{code}
+    | Coerce	Coercion
+		(GenType tyvar uvar)		-- Type of the whole expression
+		(GenCoreExpr val_bdr val_occ tyvar uvar)
+\end{code}
+
+\begin{code}
+data Coercion	= CoerceIn Id		-- Apply this constructor
+		| CoerceOut Id		-- Strip this constructor
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -243,9 +259,9 @@ mkCoLetNoUnboxed bind@(NonRec binder rhs) body
 mkCoLetsNoUnboxed []    expr = expr
 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
 
---mkCoLetrecNoUnboxed :: [(Id, CoreExpr)]	-- bindings
---  	            -> CoreExpr		-- body
---		    -> CoreExpr 		-- result
+mkCoLetrecNoUnboxed :: [(GenId (GenType a b), GenCoreExpr (GenId (GenType a b)) c d e)]
+		    -> GenCoreExpr (GenId (GenType a b)) c d e
+		    -> GenCoreExpr (GenId (GenType a b)) c d e
 
 mkCoLetrecNoUnboxed []    body = body
 mkCoLetrecNoUnboxed binds body
@@ -484,32 +500,21 @@ collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
 	        [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
 
 collectArgs expr
-  = usages expr []
+  = valvars expr []
   where
-    usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
-    usages fun uacc
-      = case (tyvars fun []) of { (expr, tacc, vacc) ->
+    valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
+    valvars fun vacc
+      = case (tyvars fun []) of { (expr, uacc, tacc) ->
 	(expr, uacc, tacc, vacc) }
 
     tyvars (App fun (TyArg t))    tacc = tyvars fun (t:tacc)
     tyvars fun tacc
-      = ASSERT(not (usage_app fun))
-	case (valvars fun []) of { (expr, vacc) ->
-	(expr, tacc, vacc) }
-
-    valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
-    valvars fun vacc
-      = --ASSERT(not (usage_app fun))
-	--ASSERT(not (ty_app    fun))
-	(if (usage_app fun || ty_app fun) then trace "CoreSyn:valvars" {-(ppr PprDebug fun)-} else id) $
-	(fun, vacc)
-
-    ---------------------------------------
-    usage_app (App _ (UsageArg _)) = True
-    usage_app _			   = False
+      = case (usages fun []) of { (expr, uacc) ->
+	(expr, uacc, tacc) }
 
-    ty_app    (App _ (TyArg _))    = True
-    ty_app    _			   = False
+    usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
+    usages fun uacc
+      = (fun,uacc)
 \end{code}
 
 %************************************************************************