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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 037afb4..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,
 
@@ -17,7 +18,7 @@ module CoreSyn (
 	mkApp, mkCon, mkPrim,
 	mkValLam, mkTyLam, mkUseLam,
 	mkLam,
-	collectBinders,
+	collectBinders, isValBinder, notValBinder,
 	
 	collectArgs, isValArg, notValArg, numValArgs,
 
@@ -56,14 +57,15 @@ module CoreSyn (
 
 import Ubiq{-uitous-}
 
+-- ToDo:rm:
+--import PprCore		( GenCoreExpr{-instance-} )
+--import PprStyle		( PprStyle(..) )
+
 import CostCentre	( showCostCentre, CostCentre )
-import Id		( idType )
+import Id		( idType, GenId{-instance Eq-} )
+import Type		( isUnboxedType )
 import Usage		( UVar(..) )
-import Util		( panic, assertPanic )
-
-isUnboxedDataType = panic "CoreSyn.isUnboxedDataType"
---eqId :: Id -> Id -> Bool
-eqId = panic "CoreSyn.eqId"
+import Util		( panic, assertPanic {-pprTrace:ToDo:rm-} )
 \end{code}
 
 %************************************************************************
@@ -181,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}
+
 
 %************************************************************************
 %*									*
@@ -197,12 +214,13 @@ being bound has unboxed type. We have different variants ...
 				(unboxed bindings in a letrec are still prohibited)
 
 \begin{code}
-mkCoLetAny :: GenCoreBinding val_bdr val_occ tyvar uvar
-	   -> GenCoreExpr    val_bdr val_occ tyvar uvar
-	   -> GenCoreExpr    val_bdr val_occ tyvar uvar
-mkCoLetsAny :: [GenCoreBinding val_bdr val_occ tyvar uvar] ->
-		GenCoreExpr val_bdr val_occ tyvar uvar ->
-		GenCoreExpr val_bdr val_occ tyvar uvar
+mkCoLetAny :: GenCoreBinding Id Id tyvar uvar
+	   -> GenCoreExpr    Id Id tyvar uvar
+	   -> GenCoreExpr    Id Id tyvar uvar
+mkCoLetsAny :: [GenCoreBinding Id Id tyvar uvar] ->
+		GenCoreExpr Id Id tyvar uvar ->
+		GenCoreExpr Id Id tyvar uvar
+
 mkCoLetrecAny :: [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)]
 	      -> GenCoreExpr val_bdr val_occ tyvar uvar
 	      -> GenCoreExpr val_bdr val_occ tyvar uvar
@@ -216,7 +234,7 @@ 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 `eqId` binder2
+      Var binder2 | binder == binder2
 	 -> rhs   -- hey, I have the rhs
       other
 	 -> Let bind body
@@ -231,9 +249,9 @@ mkCoLetAny bind@(NonRec binder rhs) body
 mkCoLetNoUnboxed bind@(Rec binds) body
   = mkCoLetrecNoUnboxed binds body
 mkCoLetNoUnboxed bind@(NonRec binder rhs) body
-  = --ASSERT (not (isUnboxedDataType (idType binder)))
+  = --ASSERT (not (isUnboxedType (idType binder)))
     case body of
-      Var binder2 | binder `eqId` binder2
+      Var binder2 | binder == binder2
 	 -> rhs   -- hey, I have the rhs
       other
 	 -> Let bind body
@@ -241,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
@@ -251,7 +269,7 @@ mkCoLetrecNoUnboxed binds body
     Let (Rec binds) body
   where
     is_boxed_bind (binder, rhs)
-      = (not . isUnboxedDataType . idType) binder
+      = (not . isUnboxedType . idType) binder
 \end{code}
 
 \begin{code}
@@ -264,10 +282,10 @@ mkCoLetUnboxedToCase bind@(Rec binds) body
   = mkCoLetrecNoUnboxed binds body
 mkCoLetUnboxedToCase bind@(NonRec binder rhs) body
   = case body of
-      Var binder2 | binder `eqId` binder2
+      Var binder2 | binder == binder2
 	 -> rhs   -- hey, I have the rhs
       other
-	 -> if (not (isUnboxedDataType (idType binder))) then
+	 -> if (not (isUnboxedType (idType binder))) then
 		Let bind body		 -- boxed...
 	    else
 		Case rhs		  -- unboxed...
@@ -341,6 +359,11 @@ data GenCoreBinder val_bdr tyvar uvar
   = ValBinder	val_bdr
   | TyBinder	tyvar
   | UsageBinder	uvar
+
+isValBinder (ValBinder _) = True
+isValBinder _		  = False
+
+notValBinder = not . isValBinder
 \end{code}
 
 Clump Lams together if possible.
@@ -379,42 +402,25 @@ collectBinders ::
   GenCoreExpr val_bdr val_occ tyvar uvar ->
   ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
 
-collectBinders (Lam (UsageBinder u) body)
-  = let
-	(uvars, tyvars, args, final_body) = collectBinders body
-    in
-    (u:uvars, tyvars, args, final_body)
-
-collectBinders other
-  = let
-	(tyvars, args, body) = dig_for_tyvars other
-    in
-    ([], tyvars, args, body)
+collectBinders expr
+  = usages expr []
   where
-    dig_for_tyvars (Lam (TyBinder tv) body)
-      = let
-	    (tyvars, args, body2) = dig_for_tyvars body
-	in
-	(tv : tyvars, args, body2)
-
-    dig_for_tyvars body
-      = ASSERT(not (usage_lambda body))
-	let
-	    (args, body2) = dig_for_valvars body
-	in
-	([], args, body2)
-
-    ---------------------------------------
-    dig_for_valvars (Lam (ValBinder v) body)
-      = let
-	    (args, body2) = dig_for_valvars body
-	in
-	(v : args, body2)
-
-    dig_for_valvars body
-      = ASSERT(not (usage_lambda body))
-	ASSERT(not (tyvar_lambda body))
-	([], body)
+    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) }
+
+    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)
 
     ---------------------------------------
     usage_lambda (Lam (UsageBinder _) _) = True
@@ -489,13 +495,26 @@ and the arguments to which it is applied.
 \begin{code}
 collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
 	    -> (GenCoreExpr val_bdr val_occ tyvar uvar,
-	        [GenCoreArg val_occ tyvar uvar])
+		[GenUsage uvar],
+		[GenType tyvar uvar],
+	        [GenCoreArg val_occ tyvar uvar]{-ValArgs-})
 
 collectArgs expr
-  = collect expr []
+  = valvars expr []
   where
-    collect (App fun arg) args = collect fun (arg : args)
-    collect fun		  args = (fun, args)
+    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
+      = case (usages fun []) of { (expr, uacc) ->
+	(expr, uacc, tacc) }
+
+    usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
+    usages fun uacc
+      = (fun,uacc)
 \end{code}
 
 %************************************************************************