[project @ 1996-05-06 11:01:29 by partain]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreSyn.lhs

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 2e017b8..49e6687 100644 (file)
--- 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}
 
 %************************************************************************