GenCoreBinding(..), GenCoreExpr(..),
GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreCaseDefault(..),
+ Coercion(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
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,
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-}
-
--- ToDo:rm:
---import PprCore ( GenCoreExpr{-instance-} )
---import PprStyle ( PprStyle(..) )
+IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre, CostCentre )
import Id ( idType, GenId{-instance Eq-} )
import Type ( isUnboxedType )
-import Usage ( UVar(..) )
+import Usage ( SYN_IE(UVar) )
import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} )
\end{code}
(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}
+
%************************************************************************
%* *
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
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)
\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
([uvar], [tyvar], [val_bdr], GenCoreExpr val_bdr val_occ tyvar uvar)
collectBinders expr
+ = (usages, tyvars, vals, body)
+ where
+ (usages, tyvars, body1) = collectUsageAndTyBinders expr
+ (vals, body) = collectValBinders body1
+
+
+collectUsageAndTyBinders expr
= usages expr []
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
+ = go [] expr
+ where
+ go acc (Lam (ValBinder v) b) = go (v:acc) b
+ go acc body = (reverse acc, body)
+
\end{code}
%************************************************************************
[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) }
+ = case (usages fun []) of { (expr, uacc) ->
+ (expr, uacc, tacc) }
- valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
- valvars fun vacc
- = --ASSERT(not (usage_app fun))
- --ASSERT(not (ty_app fun))
- (if (usage_app fun || ty_app fun) then trace "CoreSyn:valvars" {-(ppr PprDebug fun)-} else id) $
- (fun, vacc)
+ usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
+ usages fun uacc
+ = (fun,uacc)
+\end{code}
- ---------------------------------------
- usage_app (App _ (UsageArg _)) = True
- usage_app _ = False
- ty_app (App _ (TyArg _)) = True
- ty_app _ = False
+\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