substCoreExpr, substCoreBindings
, mkCoreIfThenElse
- , mkErrorApp, escErrorMsg
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
, maybeErrorApp
, nonErrorRHSs
, squashableDictishCcExpr
-{- exprSmallEnoughToDup,
+ , exprSmallEnoughToDup
+{-
coreExprArity,
isWrapperFor,
import PprType ( GenType{-instances-} )
import Pretty ( ppAboves )
import PrelInfo ( trueDataCon, falseDataCon,
- augmentId, buildId,
- pAT_ERROR_ID
+ augmentId, buildId
)
-import PrimOp ( primOpType, PrimOp(..) )
+import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
import UniqSupply ( initUs, returnUs, thenUs,
- mapUs, mapAndUnzipUs,
+ mapUs, mapAndUnzipUs, getUnique,
UniqSM(..), UniqSupply
)
import Usage ( UVar(..) )
coreExprType (SCC _ expr) = coreExprType expr
coreExprType (Case _ alts) = coreAltsType alts
+coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
\end{code}
\begin{code}
-applyTypeToArgs = panic "applyTypeToArgs"
+applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
+
+applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
+applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
+applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
+ Just (_, res_ty) -> res_ty
\end{code}
%************************************************************************
NoDefault )
\end{code}
-\begin{code}
-mkErrorApp :: Type -> Id -> String -> CoreExpr
-
-mkErrorApp ty str_var error_msg
- = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
- mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
-
-escErrorMsg [] = []
-escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
-escErrorMsg (x:xs) = x : escErrorMsg xs
-\end{code}
-
For making @Apps@ and @Lets@, we must take appropriate evasive
action if the thing being bound has unboxed type. @mkCoApp@ requires
-a name supply to do its work. Other-monad code will call @mkCoApp@
-through its own interface function (e.g., the desugarer uses
-@mkCoAppDs@).
+a name supply to do its work.
-@mkCoApp@, @mkCoCon@ and @mkCoPrim@ also handle the
+@mkCoApps@, @mkCoCon@ and @mkCoPrim@ also handle the
arguments-must-be-atoms constraint.
\begin{code}
-{- LATER:
---mkCoApp :: CoreExpr -> CoreExpr -> UniqSM CoreExpr
+data CoreArgOrExpr
+ = AnArg CoreArg
+ | AnExpr CoreExpr
-mkCoApp e1 (Var v) = returnUs (App e1 (VarArg v))
-mkCoApp e1 (Lit l) = returnUs (App e1 (LitArg l))
-mkCoApp e1 e2
- = let
- e2_ty = coreExprType e2
- in
- panic "getUnique" `thenUs` \ uniq ->
- let
- new_var = mkSysLocal SLIT("a") uniq e2_ty mkUnknownSrcLoc
- in
- returnUs (
- mkCoLetUnboxedToCase (NonRec new_var e2)
- (App e1 (VarArg new_var))
- )
--}
-\end{code}
+mkCoApps :: CoreExpr -> [CoreArgOrExpr] -> UniqSM CoreExpr
+mkCoCon :: Id -> [CoreArgOrExpr] -> UniqSM CoreExpr
+mkCoPrim :: PrimOp -> [CoreArgOrExpr] -> UniqSM CoreExpr
-\begin{code}
-{-LATER
-mkCoCon :: Id -> [CoreExpr] -> UniqSM CoreExpr
-mkCoPrim :: PrimOp -> [CoreExpr] -> UniqSM CoreExpr
+mkCoApps fun args = co_thing (mkGenApp fun) args
+mkCoCon con args = co_thing (Con con) args
+mkCoPrim op args = co_thing (Prim op) args
-mkCoCon con args = mkCoThing (Con con) args
-mkCoPrim op args = mkCoThing (Prim op) args
+co_thing :: ([CoreArg] -> CoreExpr)
+ -> [CoreArgOrExpr]
+ -> UniqSM CoreExpr
-mkCoThing thing arg_exprs
+co_thing thing arg_exprs
= mapAndUnzipUs expr_to_arg arg_exprs `thenUs` \ (args, maybe_binds) ->
returnUs (mkCoLetsUnboxedToCase (catMaybes maybe_binds) (thing args))
where
- expr_to_arg :: CoreExpr
- -> UniqSM (CoreArg, Maybe CoreBinding)
+ expr_to_arg :: CoreArgOrExpr
+ -> UniqSM (CoreArg, Maybe CoreBinding)
- expr_to_arg (Var v) = returnUs (VarArg v, Nothing)
- expr_to_arg (Lit l) = returnUs (LitArg l, Nothing)
- expr_to_arg other_expr
+ expr_to_arg (AnArg arg) = returnUs (arg, Nothing)
+ expr_to_arg (AnExpr (Var v)) = returnUs (VarArg v, Nothing)
+ expr_to_arg (AnExpr (Lit l)) = returnUs (LitArg l, Nothing)
+ expr_to_arg (AnExpr other_expr)
= let
e_ty = coreExprType other_expr
in
- panic "getUnique" `thenUs` \ uniq ->
+ getUnique `thenUs` \ uniq ->
let
new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
- new_atom = VarArg new_var
in
- returnUs (new_atom, Just (NonRec new_var other_expr))
--}
+ returnUs (VarArg new_var, Just (NonRec new_var other_expr))
\end{code}
\begin{code}
\end{code}
\begin{code}
-{- LATER:
---mkCoApps ::
--- GenCoreExpr val_bdr val_occ tyvar uvar ->
--- [GenCoreExpr val_bdr val_occ tyvar uvar] ->
--- UniqSM(GenCoreExpr val_bdr val_occ tyvar uvar)
-
-mkCoApps fun [] = returnUs fun
-mkCoApps fun (arg:args)
- = mkCoApp fun arg `thenUs` \ new_fun ->
- mkCoApps new_fun args
-\end{code}
-
-\begin{code}
-exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
-
-exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
+exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
+exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+exprSmallEnoughToDup expr
+ = case (collectArgs expr) of { (fun, _, _, vargs) ->
+ case fun of
+ Var v | length vargs == 0 -> True
+ _ -> False
+ }
+{- LATER:
+WAS: MORE CLEVER:
exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
= case (collectArgs expr) of { (fun, _, _, vargs) ->
case fun of
\begin{code}
manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-manifestlyWHNF (Var _) = True
-manifestlyWHNF (Lit _) = True
-manifestlyWHNF (Con _ _) = True
-manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e) = False
-manifestlyWHNF (Case _ _) = False
+manifestlyWHNF (Var _) = True
+manifestlyWHNF (Lit _) = True
+manifestlyWHNF (Con _ _) = True
+manifestlyWHNF (SCC _ e) = manifestlyWHNF e
+manifestlyWHNF (Coerce _ _ e) = _trace "manifestlyWHNF:Coerce" $ manifestlyWHNF e
+manifestlyWHNF (Let _ e) = False
+manifestlyWHNF (Case _ _) = False
manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
\begin{code}
manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-manifestlyBottom (Var v) = isBottomingId v
-manifestlyBottom (Lit _) = False
-manifestlyBottom (Con _ _) = False
-manifestlyBottom (Prim _ _) = False
-manifestlyBottom (SCC _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e) = manifestlyBottom e
+manifestlyBottom (Var v) = isBottomingId v
+manifestlyBottom (Lit _) = False
+manifestlyBottom (Con _ _) = False
+manifestlyBottom (Prim _ _) = False
+manifestlyBottom (SCC _ e) = manifestlyBottom e
+manifestlyBottom (Coerce _ _ e) = _trace "manifestlyBottom:Coerce" $ manifestlyBottom e
+manifestlyBottom (Let _ e) = manifestlyBottom e
-- We do not assume \x.bottom == bottom:
manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
bop_expr f (App expr arg) = App (bop_expr f expr) arg
bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
+bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
let new_venv = growIdEnvList venv new_maps in
mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss ->
- returnUs (Rec (new_binders `zipEqual` new_rhss), new_venv)
+ returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv)
where
(binders, rhss) = unzip binds
\end{code}
do_CoreArg :: ValEnv
-> TypeEnv
-> CoreArg
- -> UniqSM CoreExpr
+ -> UniqSM CoreArgOrExpr
-do_CoreArg venv tenv (LitArg lit) = returnUs (Lit lit)
-do_CoreArg venv tenv (TyArg ty) = panic "do_CoreArg: TyArg"
-do_CoreArg venv tenv (UsageArg usage) = panic "do_CoreArg: UsageArg"
-do_CoreArg venv tenv (VarArg v)
+do_CoreArg venv tenv a@(VarArg v)
= returnUs (
case (lookupIdEnv venv v) of
- Nothing -> --false:ASSERT(toplevelishId v)
- Var v
- Just expr -> expr
+ Nothing -> AnArg a
+ Just expr -> AnExpr expr
)
+
+do_CoreArg venv tenv (TyArg ty)
+ = returnUs (AnArg (TyArg (applyTypeEnvToTy tenv ty)))
+
+do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg)
\end{code}
\begin{code}
do_CoreExpr venv tenv e@(Lit _) = returnUs e
do_CoreExpr venv tenv (Con con as)
- = panic "CoreUtils.do_CoreExpr:Con"
-{- LATER:
= mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
mkCoCon con new_as
--}
do_CoreExpr venv tenv (Prim op as)
- = panic "CoreUtils.do_CoreExpr:Prim"
-{- LATER:
= mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as ->
do_PrimOp op `thenUs` \ new_op ->
mkCoPrim new_op new_as
returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty)
do_PrimOp other_op = returnUs other_op
--}
do_CoreExpr venv tenv (Lam binder expr)
= dup_binder tenv binder `thenUs` \(new_binder, (old,new)) ->
returnUs (Lam new_binder new_expr)
do_CoreExpr venv tenv (App expr arg)
- = panic "CoreUtils.do_CoreExpr:App"
-{-
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
do_CoreArg venv tenv arg `thenUs` \ new_arg ->
- mkCoApp new_expr new_arg
--}
+ mkCoApps new_expr [new_arg] -- ToDo: more efficiently?
do_CoreExpr venv tenv (Case expr alts)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
do_CoreExpr venv tenv (SCC label expr)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
returnUs (SCC label new_expr)
+
+do_CoreExpr venv tenv (Coerce c ty expr)
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
\end{code}
projects / ghc-hetmet.git / blobdiff