Commit 087fdd53 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-17 11:34:46 by sewardj]

Changes needed to get TcExpr to compile.
parent 51c3d221
......@@ -12,9 +12,10 @@ module CoreLint (
#include "HsVersions.h"
import IO ( hPutStr, hPutStrLn, stdout )
import IO ( hPutStr, hPutStrLn, stdout )
import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug )
import CmdLineOpts ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting,
opt_PprStyle_Debug )
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars, mustHaveLocalBinding )
......@@ -28,10 +29,10 @@ import VarSet
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message,
import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message,
ErrMsg, addErrLocHdrLine, pprBagOfErrors,
WarnMsg, pprBagOfWarnings)
import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc )
import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( Type, tyVarsOfType,
splitFunTy_maybe, mkTyVarTy,
splitForAllTy_maybe, splitTyConApp_maybe,
......@@ -58,29 +59,29 @@ place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
beginPass :: String -> IO ()
beginPass pass_name
| opt_D_show_passes
beginPass :: DynFlags -> String -> IO ()
beginPass dflags pass_name
| dopt_D_show_passes dflags
= hPutStrLn stdout ("*** " ++ pass_name)
| otherwise
= return ()
endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass pass_name dump_flag binds
endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind]
endPass dflags pass_name dump_flag binds
= do
(binds, _) <- endPassWithRules pass_name dump_flag binds Nothing
(binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing
return binds
endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase
endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase
-> IO ([CoreBind], Maybe RuleBase)
endPassWithRules pass_name dump_flag binds rules
endPassWithRules dflags pass_name dump_flag binds rules
= do
-- ToDo: force the rules?
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
if opt_D_show_passes then
if dopt_D_show_passes dflags then
hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
else
return ()
......@@ -92,7 +93,7 @@ endPassWithRules pass_name dump_flag binds rules
Just rb -> pprRuleBase rb)
-- Type check
lintCoreBindings pass_name binds
lintCoreBindings dflags pass_name binds
-- ToDo: lint the rules
return (binds, rules)
......@@ -130,13 +131,13 @@ Outstanding issues:
-- may well be happening...);
\begin{code}
lintCoreBindings :: String -> [CoreBind] -> IO ()
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
lintCoreBindings whoDunnit binds
| not opt_DoCoreLinting
lintCoreBindings dflags whoDunnit binds
| not (dopt_DoCoreLinting dflags)
= return ()
lintCoreBindings whoDunnit binds
lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
(Nothing, Nothing) -> done_lint
......@@ -156,7 +157,7 @@ lintCoreBindings whoDunnit binds
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
done_lint = doIfSet opt_D_show_passes
done_lint = doIfSet_dyn dflags dopt_D_show_passes
(hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
warn warnings
= vcat [
......@@ -190,19 +191,20 @@ We use this to check all unfoldings that come in from interfaces
(it is very painful to catch errors otherwise):
\begin{code}
lintUnfolding :: SrcLoc
lintUnfolding :: DynFlags
-> SrcLoc
-> [Var] -- Treat these as in scope
-> CoreExpr
-> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
lintUnfolding locn vars expr
| not opt_DoCoreLinting
lintUnfolding dflags locn vars expr
| not (dopt_DoCoreLinting dflags)
= (Nothing, Nothing)
| otherwise
= initL (addLoc (ImportedUnfolding locn) $
addInScopeVars vars $
lintCoreExpr expr)
addInScopeVars vars $
lintCoreExpr expr)
\end{code}
%************************************************************************
......
......@@ -11,7 +11,7 @@ module ErrUtils (
dontAddErrLoc,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
doIfSet, dumpIfSet, dumpIfSet_dyn
doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn
) where
#include "HsVersions.h"
......@@ -96,6 +96,10 @@ ghcExit val
doIfSet :: Bool -> IO () -> IO ()
doIfSet flag action | flag = action
| otherwise = return ()
doIfSet_dyn :: DynFlags -> (DynFlags -> Bool) -> IO () -> IO()
doIfSet_dyn dflags flag action | flag dflags = action
| otherwise = return ()
\end{code}
\begin{code}
......
......@@ -10,7 +10,8 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
import CoreSyn
import CoreUnfold ( Unfolding, certainlyWillInline )
import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_worker_wrapper )
import CmdLineOpts ( DynFlags,
dopt_D_verbose_core2core, dopt_D_dump_worker_wrapper )
import CoreLint ( beginPass, endPass )
import CoreUtils ( exprType, exprEtaExpandArity )
import MkId ( mkWorkerId )
......@@ -56,20 +57,23 @@ info for exported values).
\begin{code}
wwTopBinds :: UniqSupply
-> [CoreBind]
-> IO [CoreBind]
wwTopBinds :: DynFlags
-> UniqSupply
-> [CoreBind]
-> IO [CoreBind]
wwTopBinds us binds
wwTopBinds dflags us binds
= do {
beginPass "Worker Wrapper binds";
beginPass dflags "Worker Wrapper binds";
-- Create worker/wrappers, and mark binders with their
-- "strictness info" [which encodes their worker/wrapper-ness]
let { binds' = workersAndWrappers us binds };
endPass "Worker Wrapper binds" (opt_D_dump_worker_wrapper ||
opt_D_verbose_core2core) binds'
endPass dflags "Worker Wrapper binds"
(dopt_D_dump_worker_wrapper dflags ||
dopt_D_verbose_core2core dflags)
binds'
}
\end{code}
......
......@@ -18,8 +18,9 @@ import TcSimplify ( tcSimplifyCheckThetas )
import TysWiredIn ( integerTy, doubleTy )
import Type ( Type )
import PrelNames ( numClassKey )
import PrelNames ( numClassName )
import Outputable
import HscTypes ( TyThing(..) )
\end{code}
\begin{code}
......@@ -38,9 +39,9 @@ tc_defaults [DefaultDecl [] locn]
tc_defaults [DefaultDecl mono_tys locn]
= tcLookupGlobal_maybe numClassName `thenNF_Tc` \ maybe_num ->
case maybe_num of {
case maybe_num of
Just (AClass num_class) -> common_case num_class
other -> returnTc [] ;
other -> returnTc []
-- In the Nothing case, Num has not been sucked in, so the
-- defaults will never be used; so simply discard the default decl.
-- This slightly benefits modules that don't use any
......@@ -59,7 +60,7 @@ tc_defaults [DefaultDecl mono_tys locn]
[ (num_class, [ty]) | ty <- tau_tys ] `thenTc_`
returnTc tau_tys
}
tc_defaults decls@(DefaultDecl _ loc : _) =
tcAddSrcLoc loc $
......
......@@ -28,7 +28,10 @@ module TcEnv(
-- New Ids
newLocalId, newSpecPragmaId,
newDefaultMethodName, newDFunName
newDefaultMethodName, newDFunName,
-- ???
tcSetEnv, explicitLookupId
) where
#include "HsVersions.h"
......
......@@ -25,7 +25,7 @@ import Inst ( InstOrigin(..),
getIPsOfLIE, instToId, ipToId
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
import TcEnv ( TcTyThing(..), tcInstId,
tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
tcLookupTyCon, tcLookupDataCon, tcLookup,
tcExtendGlobalTyVars
......@@ -61,16 +61,18 @@ import UsageSPUtils ( unannotTy )
import VarSet ( elemVarSet, mkVarSet )
import TysWiredIn ( boolTy )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey,
enumFromClassOpKey, enumFromThenClassOpKey,
enumFromToClassOpKey, enumFromThenToClassOpKey,
thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
import PrelNames ( cCallableClassName,
cReturnableClassName,
enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
thenMName, failMName, returnMName, ioTyConName
)
import Outputable
import Maybes ( maybeToBool, mapMaybe )
import ListSetOps ( minusList )
import Util
import CmdLineOpts ( opt_WarnMissingFields )
import HscTypes ( TyThing(..) )
\end{code}
......@@ -396,7 +398,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
-- Check that the record bindings match the constructor
-- con_name is syntactically constrained to be a data constructor
tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
tcLookupDataCon con_name `thenTc` \ data_con ->
let
bad_fields = badFields rbinds data_con
in
......@@ -472,7 +474,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
-- STEP 1
-- Figure out the tycon and data cons from the first field name
let
(Just sel_id : _) = maybe_sel_ids
(Just (AnId sel_id) : _) = maybe_sel_ids
(_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) )
splitSigmaTy (idType sel_id) -- Selectors can be overloaded
-- when the data type has a context
......@@ -553,7 +555,7 @@ tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
= unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
tcLookupGlobalId enumFromClassOpName `thenNF_Tc` \ sel_id ->
tcLookupGlobalId enumFromName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) ->
......@@ -565,7 +567,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcLookupGlobalId enumFromThenClassOpName `thenNF_Tc` \ sel_id ->
tcLookupGlobalId enumFromThenName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
returnTc (ArithSeqOut (HsVar enum_from_then_id)
......@@ -577,7 +579,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcLookupGlobalId enumFromToClassOpName `thenNF_Tc` \ sel_id ->
tcLookupGlobalId enumFromToName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
returnTc (ArithSeqOut (HsVar enum_from_to_id)
......@@ -590,7 +592,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
tcLookupGlobalId enumFromThenToClassOpName `thenNF_Tc` \ sel_id ->
tcLookupGlobalId enumFromThenToName `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
returnTc (ArithSeqOut (HsVar eft_id)
......@@ -866,9 +868,9 @@ tcDoStmts do_or_lc stmts src_loc res_ty
-- then = then
-- where the second "then" sees that it already exists in the "available" stuff.
--
tcLookupGlobalId returnMClassOpName `thenNF_Tc` \ return_sel_id ->
tcLookupGlobalId thenMClassOpName `thenNF_Tc` \ then_sel_id ->
tcLookupGlobalId failMClassOpName `thenNF_Tc` \ fail_sel_id ->
tcLookupGlobalId returnMName `thenNF_Tc` \ return_sel_id ->
tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id ->
tcLookupGlobalId failMName `thenNF_Tc` \ fail_sel_id ->
newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) ->
newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) ->
newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) ->
......
......@@ -17,7 +17,7 @@ import TcMonoType ( tcHsType )
import TcEnv ( TcEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetEnv,
tcLookupGlobal_maybe, explicitLookupId, valueEnvIds
tcLookupGlobal_maybe, explicitLookupId, tcEnvIds
)
import RnHsSyn ( RenamedHsDecl )
......@@ -29,9 +29,7 @@ import CoreUnfold
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
import Id ( Id, mkId, mkVanillaId,
isDataConWrapId_maybe
)
import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
import MkId ( mkCCallOpId )
import IdInfo
import DataCon ( dataConSig, dataConArgTys )
......@@ -42,6 +40,7 @@ import Demand ( wwLazy )
import ErrUtils ( pprBagOfErrors )
import Outputable
import Util ( zipWithEqual )
import HscTypes ( TyThing(..) )
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
......@@ -61,7 +60,7 @@ tcInterfaceSigs unf_env decls
= listTc [ do_one name ty id_infos src_loc
| SigD (IfaceSig name ty id_infos src_loc) <- decls]
where
in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env)
do_one name ty id_infos src_loc
= tcAddSrcLoc src_loc $
......@@ -137,7 +136,8 @@ tcPragExpr unf_env name in_scope_vars expr
-- Check for type consistency in the unfolding
tcGetSrcLoc `thenNF_Tc` \ src_loc ->
case lintUnfolding src_loc in_scope_vars core_expr' of
getDOptsTc `thenTc` \ dflags ->
case lintUnfolding dflags src_loc in_scope_vars core_expr' of
(Nothing,_) -> returnTc core_expr' -- ignore warnings
(Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment