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,
IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre, CostCentre )
-import Id ( idType, GenId{-instance Eq-} )
-import Type ( isUnboxedType )
-import Usage ( SYN_IE(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}
%************************************************************************
| Prim PrimOp [GenCoreArg val_occ tyvar uvar]
-- saturated primitive operation;
+
-- comment on Cons applies here, too.
\end{code}
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}
([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
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}
%************************************************************************
= (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}