[project @ 1997-05-19 00:12:10 by sof]

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

diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index d66f7b6..6e28cf4 100644 (file)
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -18,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,
@@ -29,40 +30,42 @@ 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(..)
+       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
 
 IMP_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 Id              ( idType, GenId{-instance Eq-}, SYN_IE(Id) )
+import Type            ( isUnboxedType,GenType, SYN_IE(Type) )
+import TyVar           ( GenTyVar, SYN_IE(TyVar) )
+import Usage           ( SYN_IE(UVar),GenUsage,SYN_IE(Usage) )
 import Util            ( panic, assertPanic {-pprTrace:ToDo:rm-} )
+#if __GLASGOW_HASKELL__ >= 202
+import Literal          ( Literal )
+import BinderInfo       ( BinderInfo )
+import PrimOp           ( PrimOp )
+#endif
 \end{code}
 
 %************************************************************************
@@ -136,6 +139,7 @@ desugarer sets up constructors as applications of global @Vars@s.
 
      | Prim    PrimOp [GenCoreArg val_occ tyvar uvar]
                -- saturated primitive operation;
+
                -- comment on Cons applies here, too.
 \end{code}
 
@@ -228,23 +232,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
@@ -256,10 +251,6 @@ mkCoLetNoUnboxed bind@(NonRec binder rhs) body
 mkCoLetsNoUnboxed []    expr = expr
 mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds
 
-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
   = ASSERT (all is_boxed_bind binds)
@@ -270,13 +261,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
@@ -400,24 +387,26 @@ collectBinders ::
   ([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
 
 collectBinders expr
-  = usages expr []
+  = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) }
+  where
+    (usages, tyvars, body1) = collectUsageAndTyBinders expr
+--    (vals, body)         = collectValBinders body1
+
+
+collectUsageAndTyBinders expr
+  = case usages expr [] of
+      ([],tyvars,body) -> ([],tyvars,body)
+      v                -> v
   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
@@ -425,6 +414,18 @@ 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
+  = case go [] expr of
+      ([],body) -> ([],body)
+      v         -> v
+  where
+    go acc (Lam (ValBinder v) b) = go (v:acc) b
+    go acc body                 = (reverse acc, body)
+
 \end{code}
 
 %************************************************************************
@@ -514,6 +515,21 @@ collectArgs expr
       = (fun,uacc)
 \end{code}
 
+
+\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}