substCoreExpr, substCoreBindings
, mkCoreIfThenElse
- , escErrorMsg -- ToDo: kill
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy
)
import UniqSupply ( initUs, returnUs, thenUs,
- mapUs, mapAndUnzipUs,
+ mapUs, mapAndUnzipUs, getUnique,
UniqSM(..), UniqSupply
)
import Usage ( UVar(..) )
\end{code}
\begin{code}
-applyTypeToArgs = panic "applyTypeToArgs"
+applyTypeToArgs op_ty args
+ = foldl applyTy op_ty [ ty | TyArg ty <- args ]
\end{code}
%************************************************************************
NoDefault )
\end{code}
-\begin{code}
-{- OLD:
-mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr
-
-mkErrorApp err_fun ty str_var error_msg
- = Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
- mkApp (Var err_fun) [] [ty] [VarArg str_var])
--}
-
-escErrorMsg = panic "CoreUtils.escErrorMsg: To Die"
-{- OLD:
-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}
\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
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 ->