module CoreSyn (
GenCoreBinding(..), GenCoreExpr(..),
- GenCoreArg(..),GenCoreBinder(..), GenCoreCaseAlts(..),
+ GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreCaseDefault(..),
+ Coercion(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
mkApp, mkCon, mkPrim,
mkValLam, mkTyLam, mkUseLam,
mkLam,
- digForLambdas,
+ collectBinders, collectUsageAndTyBinders, collectValBinders,
+ isValBinder, notValBinder,
- collectArgs, isValArg,
+ collectArgs, initialTyArgs, initialValArgs, isValArg, notValArg, numValArgs,
mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase,
mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase,
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-}
+IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre, CostCentre )
-import Id ( idType )
-import Usage ( UVar(..) )
-import Util ( panic, assertPanic )
-
-isUnboxedDataType = panic "CoreSyn.isUnboxedDataType"
---eqId :: Id -> Id -> Bool
-eqId = panic "CoreSyn.eqId"
+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}
Ye olde abstraction and application operators.
\begin{code}
| Lam (GenCoreBinder val_bdr tyvar uvar)
- (GenCoreExpr val_bdr val_occ tyvar uvar)
+ (GenCoreExpr val_bdr val_occ tyvar uvar)
| App (GenCoreExpr val_bdr val_occ tyvar uvar)
- (GenCoreArg val_occ tyvar uvar)
+ (GenCoreArg val_occ tyvar uvar)
\end{code}
Case expressions (\tr{case <expr> of <List of alternatives>}): there
(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}
+
%************************************************************************
%* *
(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
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 `eqId` 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 (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
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)
Let (Rec binds) body
where
is_boxed_bind (binder, rhs)
- = (not . isUnboxedDataType . idType) binder
+ = (not . isUnboxedType . idType) binder
\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 `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...
= ValBinder val_bdr
| TyBinder tyvar
| UsageBinder uvar
+
+isValBinder (ValBinder _) = True
+isValBinder _ = False
+
+notValBinder = not . isValBinder
\end{code}
Clump Lams together if possible.
\end{code}
We often want to strip off leading lambdas before getting down to
-business. @digForLambdas@ is your friend.
+business. @collectBinders@ is your friend.
We expect (by convention) usage-, type-, and value- lambdas in that
order.
\begin{code}
-digForLambdas ::
+collectBinders ::
GenCoreExpr val_bdr val_occ tyvar uvar ->
([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
-digForLambdas (Lam (UsageBinder u) body)
- = let
- (uvars, tyvars, args, final_body) = digForLambdas body
- in
- (u:uvars, tyvars, args, final_body)
-
-digForLambdas other
- = let
- (tyvars, args, body) = dig_for_tyvars other
- in
- ([], tyvars, args, body)
+collectBinders expr
+ = case collectValBinders body1 of { (vals,body) -> (usages, tyvars, vals, body) }
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)
+ (usages, tyvars, body1) = collectUsageAndTyBinders expr
+-- (vals, body) = collectValBinders body1
- ---------------------------------------
- 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)
+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, expr) ->
+ (reverse uacc, tacc, expr) }
+
+ tyvars (Lam (TyBinder t) body) tacc = tyvars body (t:tacc)
+ tyvars other tacc
+ = ASSERT(not (usage_lambda 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}
%************************************************************************
isValArg (LitArg _) = True -- often used for sanity-checking
isValArg (VarArg _) = True
isValArg _ = False
+
+notValArg = not . isValArg -- exists only because it's a common use of isValArg
+
+numValArgs as = length [ a | a <- as, isValArg a ] -- again, convenience
\end{code}
\begin{code}
\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}
+
+\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}
projects / ghc-hetmet.git / blobdiff