X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=d3afc57ce04d04a2a02a8d85738a47a67c51920f;hb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;hp=ddc7658249641415fab80b87976e480133104448;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index ddc7658..d3afc57 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -12,7 +12,6 @@ module CoreUtils ( substCoreExpr, substCoreBindings , mkCoreIfThenElse - , mkErrorApp, escErrorMsg , argToExpr , unTagBinders, unTagBindersAlts , manifestlyWHNF, manifestlyBottom @@ -44,8 +43,7 @@ import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instances-} ) import Pretty ( ppAboves ) import PrelInfo ( trueDataCon, falseDataCon, - augmentId, buildId, - pAT_ERROR_ID + augmentId, buildId ) import PrimOp ( primOpType, PrimOp(..) ) import SrcLoc ( mkUnknownSrcLoc ) @@ -55,7 +53,7 @@ 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(..) ) @@ -131,7 +129,8 @@ default_ty (BindDefault _ rhs) = coreExprType rhs \end{code} \begin{code} -applyTypeToArgs = panic "applyTypeToArgs" +applyTypeToArgs op_ty args + = foldl applyTy op_ty [ ty | TyArg ty <- args ] \end{code} %************************************************************************ @@ -152,76 +151,49 @@ mkCoreIfThenElse guard then_expr else_expr 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} @@ -234,18 +206,6 @@ argToExpr (LitArg lit) = Lit lit \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 @@ -705,18 +665,19 @@ do_CoreBinding venv tenv (Rec binds) 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} @@ -736,15 +697,10 @@ do_CoreExpr venv tenv orig_expr@(Var var) 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 @@ -757,7 +713,6 @@ do_CoreExpr venv tenv (Prim op 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)) -> @@ -766,12 +721,9 @@ do_CoreExpr venv tenv (Lam binder expr) 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 ->