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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 2e017b8..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,
 
@@ -56,11 +57,15 @@ module CoreSyn (
 
 import Ubiq{-uitous-}
 
+-- ToDo:rm:
+--import PprCore		( GenCoreExpr{-instance-} )
+--import PprStyle		( PprStyle(..) )
+
 import CostCentre	( showCostCentre, CostCentre )
 import Id		( idType, GenId{-instance Eq-} )
 import Type		( isUnboxedType )
 import Usage		( UVar(..) )
-import Util		( panic, assertPanic )
+import Util		( panic, assertPanic {-pprTrace:ToDo:rm-} )
 \end{code}
 
 %************************************************************************
@@ -178,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}
+
 
 %************************************************************************
 %*									*
@@ -239,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
@@ -480,31 +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))
-	(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}
 
 %************************************************************************