X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreUtils.lhs;h=c282c70ccb23c6ecefe9668ef33a7541c8dbb4d1;hb=5cf27e8f1731c52fe63a5b9615f927484164c61b;hp=ddc7658249641415fab80b87976e480133104448;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index ddc7658..c282c70 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -12,14 +12,14 @@ module CoreUtils ( substCoreExpr, substCoreBindings , mkCoreIfThenElse - , mkErrorApp, escErrorMsg , argToExpr , unTagBinders, unTagBindersAlts , manifestlyWHNF, manifestlyBottom , maybeErrorApp , nonErrorRHSs , squashableDictishCcExpr -{- exprSmallEnoughToDup, + , exprSmallEnoughToDup +{- coreExprArity, isWrapperFor, @@ -44,10 +44,9 @@ 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 PrimOp ( primOpType, fragilePrimOp, PrimOp(..) ) import SrcLoc ( mkUnknownSrcLoc ) import TyVar ( isNullTyVarEnv, TyVarEnv(..) ) import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, @@ -55,7 +54,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(..) ) @@ -82,6 +81,8 @@ coreExprType (Let _ body) = coreExprType body 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 of a PrimOp @@ -131,7 +132,12 @@ default_ty (BindDefault _ rhs) = coreExprType rhs \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} %************************************************************************ @@ -152,76 +158,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} @@ -233,25 +212,18 @@ argToExpr (LitArg lit) = Lit lit \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: applied to = case (collectArgs expr) of { (fun, _, _, vargs) -> case fun of @@ -273,12 +245,13 @@ left something out... [WDP] \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 @@ -308,12 +281,13 @@ some point. It isn't a disaster if it errs on the conservative side \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 @@ -453,6 +427,7 @@ bop_expr f (Prim op args) = Prim op args 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) @@ -696,7 +671,7 @@ do_CoreBinding venv tenv (Rec binds) 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} @@ -705,18 +680,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 +712,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 +728,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 +736,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 -> @@ -816,4 +783,8 @@ do_CoreExpr venv tenv (Let core_bind 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}