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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 4d8284d..42830e9 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,
 
@@ -17,9 +18,10 @@ module CoreSyn (
 	mkApp, mkCon, mkPrim,
 	mkValLam, mkTyLam, mkUseLam,
 	mkLam,
-	collectBinders, isValBinder, notValBinder,
+	collectBinders, collectUsageAndTyBinders, collectValBinders, 
+	isValBinder, notValBinder,
 	
-	collectArgs, isValArg, notValArg, numValArgs,
+	collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
 
 	mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
 	mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
@@ -28,42 +30,35 @@ module CoreSyn (
 	rhssOfAlts,
 
 	-- Common type instantiation...
-	CoreBinding(..),
-	CoreExpr(..),
-	CoreBinder(..),
-	CoreArg(..),
-	CoreCaseAlts(..),
-	CoreCaseDefault(..),
+	SYN_IE(CoreBinding),
+	SYN_IE(CoreExpr),
+	SYN_IE(CoreBinder),
+	SYN_IE(CoreArg),
+	SYN_IE(CoreCaseAlts),
+	SYN_IE(CoreCaseDefault),
 
 	-- And not-so-common type instantiations...
-	TaggedCoreBinding(..),
-	TaggedCoreExpr(..),
-	TaggedCoreBinder(..),
-	TaggedCoreArg(..),
-	TaggedCoreCaseAlts(..),
-	TaggedCoreCaseDefault(..),
-
-	SimplifiableCoreBinding(..),
-	SimplifiableCoreExpr(..),
-	SimplifiableCoreBinder(..),
-	SimplifiableCoreArg(..),
-	SimplifiableCoreCaseAlts(..),
-	SimplifiableCoreCaseDefault(..)
-
-	-- and to make the interface self-sufficient ...
-
+	SYN_IE(TaggedCoreBinding),
+	SYN_IE(TaggedCoreExpr),
+	SYN_IE(TaggedCoreBinder),
+	SYN_IE(TaggedCoreArg),
+	SYN_IE(TaggedCoreCaseAlts),
+	SYN_IE(TaggedCoreCaseDefault),
+
+	SYN_IE(SimplifiableCoreBinding),
+	SYN_IE(SimplifiableCoreExpr),
+	SYN_IE(SimplifiableCoreBinder),
+	SYN_IE(SimplifiableCoreArg),
+	SYN_IE(SimplifiableCoreCaseAlts),
+	SYN_IE(SimplifiableCoreCaseDefault)
     ) where
 
-import Ubiq{-uitous-}
-
--- ToDo:rm:
---import PprCore		( GenCoreExpr{-instance-} )
---import PprStyle		( PprStyle(..) )
+IMP_Ubiq(){-uitous-}
 
 import CostCentre	( showCostCentre, CostCentre )
 import Id		( idType, GenId{-instance Eq-} )
 import Type		( isUnboxedType )
-import Usage		( UVar(..) )
+import Usage		( SYN_IE(UVar) )
 import Util		( panic, assertPanic {-pprTrace:ToDo:rm-} )
 \end{code}
 
@@ -182,6 +177,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}
+
 
 %************************************************************************
 %*									*
@@ -215,23 +225,14 @@ mkCoLetrecAny binds body = Let (Rec binds) body
 mkCoLetsAny []    expr = expr
 mkCoLetsAny binds expr = foldr mkCoLetAny expr binds
 
-mkCoLetAny bind@(Rec binds) body = mkCoLetrecAny binds body
-mkCoLetAny bind@(NonRec binder rhs) body
-  = case body of
-      Var binder2 | binder == binder2
-	 -> rhs   -- hey, I have the rhs
-      other
-	 -> Let bind body
+mkCoLetAny bind@(Rec binds)         body = mkCoLetrecAny binds body
+mkCoLetAny bind@(NonRec binder rhs) body = Let bind body
 \end{code}
 
 \begin{code}
---mkCoLetNoUnboxed ::
---  GenCoreBinding val_bdr val_occ tyvar uvar ->
---  GenCoreExpr val_bdr val_occ tyvar uvar ->
---  GenCoreExpr val_bdr val_occ tyvar uvar
-
 mkCoLetNoUnboxed bind@(Rec binds) body
   = mkCoLetrecNoUnboxed binds body
+
 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
   = --ASSERT (not (isUnboxedType (idType binder)))
     case body of
@@ -243,10 +244,6 @@ 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 []    body = body
 mkCoLetrecNoUnboxed binds body
   = ASSERT (all is_boxed_bind binds)
@@ -257,13 +254,9 @@ mkCoLetrecNoUnboxed binds body
 \end{code}
 
 \begin{code}
---mkCoLetUnboxedToCase ::
---  GenCoreBinding val_bdr val_occ tyvar uvar ->
---  GenCoreExpr val_bdr val_occ tyvar uvar ->
---  GenCoreExpr val_bdr val_occ tyvar uvar
-
 mkCoLetUnboxedToCase bind@(Rec binds) body
   = mkCoLetrecNoUnboxed binds body
+
 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
   = case body of
       Var binder2 | binder == binder2
@@ -387,24 +380,24 @@ collectBinders ::
   ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
 
 collectBinders expr
+  = (usages, tyvars, vals, body)
+  where
+    (usages, tyvars, body1) = collectUsageAndTyBinders expr
+    (vals, body) 	    = collectValBinders body1
+
+
+collectUsageAndTyBinders expr
   = usages expr []
   where
     usages (Lam (UsageBinder u) body) uacc = usages body (u:uacc)
     usages other uacc
-      = case (tyvars other []) of { (tacc, vacc, expr) ->
-	(reverse uacc, tacc, vacc, expr) }
+      = case (tyvars other []) of { (tacc, expr) ->
+	(reverse uacc, tacc, expr) }
 
-    tyvars (Lam (TyBinder t)    body) tacc = tyvars body (t:tacc)
+    tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
     tyvars other tacc
       = ASSERT(not (usage_lambda other))
-	case (valvars other []) of { (vacc, expr) ->
-	(reverse tacc, vacc, expr) }
-
-    valvars (Lam (ValBinder v)  body) vacc = valvars body (v:vacc)
-    valvars other vacc
-      = ASSERT(not (usage_lambda other))
-	ASSERT(not (tyvar_lambda other))
-	(reverse vacc, other)
+	(reverse tacc, other)
 
     ---------------------------------------
     usage_lambda (Lam (UsageBinder _) _) = True
@@ -412,6 +405,16 @@ collectBinders expr
 
     tyvar_lambda (Lam (TyBinder _) _)    = True
     tyvar_lambda _			 = False
+
+
+collectValBinders :: GenCoreExpr val_bdr val_occ tyvar uvar ->
+		     ([val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
+collectValBinders expr
+  = go [] expr
+  where
+    go acc (Lam (ValBinder v) b) = go (v:acc) b
+    go acc body 		 = (reverse acc, body)
+
 \end{code}
 
 %************************************************************************
@@ -484,34 +487,38 @@ 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) }
+      = case (usages fun []) of { (expr, uacc) ->
+	(expr, uacc, tacc) }
 
-    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)
+    usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
+    usages fun uacc
+      = (fun,uacc)
+\end{code}
 
-    ---------------------------------------
-    usage_app (App _ (UsageArg _)) = True
-    usage_app _			   = False
 
-    ty_app    (App _ (TyArg _))    = True
-    ty_app    _			   = False
+\begin{code}
+initialTyArgs :: [GenCoreArg val_occ tyvar uvar]
+	      -> ([GenType tyvar uvar], [GenCoreArg val_occ tyvar uvar])
+initialTyArgs (TyArg ty : args) = (ty:tys, args') 
+				where
+				  (tys, args') = initialTyArgs args
+initialTyArgs other 		= ([],other)
+
+initialValArgs :: [GenCoreArg val_occ tyvar uvar]
+	      -> ([GenCoreArg val_occ tyvar uvar], [GenCoreArg val_occ tyvar uvar])
+initialValArgs args = span isValArg args
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection{The main @Core*@ instantiation of the @GenCore*@ types}