Commit 3af411e9 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-05-25 08:55:03 by simonpj]

-------------------------------------
	Wibbles to Don's runtime-types commit
	-------------------------------------

There was an upside down predicate which utterly broke the compiler.

While I was about it

* I changed the global flag to
	opt_RuntimeTypes
  with command line option
	-fruntime-types (was -fkeep-stg-types)

* I moved isRuntimeArg, isRuntimeVar to CoreSyn
parent 86cdf87a
......@@ -169,7 +169,7 @@ corePrepArg env arg dem
mkNonRec v dem floats arg' `thenUs` \ floats' ->
returnUs (floats', Var v)
needs_binding | opt_KeepStgTypes = exprIsAtom
needs_binding | opt_RuntimeTypes = exprIsAtom
| otherwise = exprIsTrivial
-- version that doesn't consider an scc annotation to be trivial.
......
......@@ -22,7 +22,7 @@ module CoreSyn (
coreExprCc,
flattenBinds,
isValArg, isTypeArg, valArgCount, valBndrCount,
isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-- Unfoldings
Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
......@@ -49,6 +49,7 @@ module CoreSyn (
#include "HsVersions.h"
import CmdLineOpts ( opt_RuntimeTypes )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
......@@ -490,6 +491,22 @@ coreExprCc other = noCostCentre
%* *
%************************************************************************
@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
i.e. if type applications are actual lambdas because types are kept around
at runtime.
Similarly isRuntimeArg.
\begin{code}
isRuntimeVar :: Var -> Bool
isRuntimeVar | opt_RuntimeTypes = \v -> True
| otherwise = \v -> isId v
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg | opt_RuntimeTypes = \e -> True
| otherwise = \e -> isValArg e
\end{code}
\begin{code}
isValArg (Type _) = False
isValArg other = True
......
......@@ -19,7 +19,7 @@ module CoreUtils (
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
exprArity, isRuntimeVar, isRuntimeArg,
exprArity,
-- Expr transformation
etaReduce, etaExpand,
......@@ -67,7 +67,6 @@ import CostCentre ( CostCentre )
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import CmdLineOpts ( opt_KeepStgTypes )
\end{code}
......@@ -413,7 +412,7 @@ exprIsCheap other_expr
go (App f a) n_args args_cheap
| not (isRuntimeArg a) = go f n_args args_cheap
| otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
| otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
go other n_args args_cheap = False
......@@ -483,7 +482,7 @@ exprOkForSpeculation other_expr
go (App f a) n_args args_ok
| not (isRuntimeArg a) = go f n_args args_ok
| otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
| otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
go other n_args args_ok = False
\end{code}
......@@ -540,7 +539,7 @@ exprIsValue other_expr
go (App f a) n_args
| not (isRuntimeArg a) = go f n_args
| otherwise = go f (n_args + 1)
| otherwise = go f (n_args + 1)
go (Note _ f) n_args = go f n_args
......@@ -557,20 +556,7 @@ idAppIsValue id n_val_args
-- then we could get an infinite loop...
\end{code}
@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
i.e. if type applications are actual lambdas because types are kept around
at runtime.
\begin{code}
isRuntimeVar :: Var -> Bool
isRuntimeVar v = opt_KeepStgTypes || isId v
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg v = opt_KeepStgTypes || isTypeArg v
\end{code}
\begin{code}
exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
-- We ignore InlineMe notes in case we have
......@@ -720,15 +706,6 @@ exprEtaExpandArity e
-- giving just
-- f = \x -> e
-- A Bad Idea
min_zero :: [Int] -> Int -- Find the minimum, but zero is the smallest
min_zero (x:xs) = go x xs
where
go 0 xs = 0 -- Nothing beats zero
go min [] = min
go min (x:xs) | x < min = go x xs
| otherwise = go min xs
\end{code}
......
......@@ -503,7 +503,7 @@ ilxExpr (IlxEEnv env _) (StgConApp data_con args) sequel
= text " /* ilxExpr:StgConApp */ " <+> ilxConApp env data_con args $$ ilxSequel sequel
-- ilxExpr eenv (StgPrimApp primop args _) sequel
ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall) args ret_ty) sequel
ilxExpr (IlxEEnv env _) (StgOpApp (StgFCallOp fcall _) args ret_ty) sequel
= ilxFCall env fcall args ret_ty $$ ilxSequel sequel
ilxExpr (IlxEEnv env _) (StgOpApp (StgPrimOp primop) args ret_ty) sequel
......@@ -737,7 +737,7 @@ ilxFunApp env fun args tail_call
Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs)
_ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing
type KnownClosure = Maybe (Place -- Of the binding site of the function
type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function
, Id -- The function
, [Var] -- Binders
, [Var]) -- Free vars of the closure
......@@ -1569,7 +1569,7 @@ ilxConApp env data_con args
-- Base the higher-kinded checks off a corresponding list of formals.
splitTyArgs :: [Var] -- Formals
-> [StgArg] -- Actuals
-> ([StgArg], [StgArg])
-> ([Type], [StgArg])
splitTyArgs (htv:ttv) (StgTypeArg h:t)
| isIlxTyVar htv = ((h:l), r)
| otherwise = trace "splitTyArgs: threw away higher kinded type arg" (l, r)
......@@ -1577,11 +1577,11 @@ splitTyArgs (htv:ttv) (StgTypeArg h:t)
splitTyArgs _ l = ([],l)
-- Split some type arguments off, where none should be higher kinded
splitTyArgs1 :: [StgArg] -> ([StgArg], [StgArg])
splitTyArgs1 args = span is_type_arg args
where
is_type_arg (StgTypeArg _) = True
is_type_arg other = False
splitTyArgs1 :: [StgArg] -> ([Type], [StgArg])
splitTyArgs1 (StgTypeArg ty : args) = (ty:tys, args')
where
(tys, args') = splitTyArgs1 args
splitTyArgs1 args = ([], args)
ilxConRef env data_con
= pprId data_con <> pprValArgTys ilxTypeL env' (map deepIlxRepType (filter (not . isVoidIlxRepType) arg_tys))
......@@ -2291,10 +2291,10 @@ ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty
| otherwise = ilxTypeR env (deepIlxRepType ret_ty)
(ty_args,tm_args) = splitTyArgs1 args
ilxFCall env (CCall (DNCallSpec call_instr)) args ret_ty
ilxFCall env (DNCall (DNCallSpec call_instr)) args ret_ty
= ilxComment (text "IL call") <+>
vcat [vcat (ilxMapPlaceArgs 0 pushILArg env tm_args),
text call_instr
ptext call_instr
-- In due course we'll need to pass the type arguments
-- and to do that we'll need to have more than just a string
-- for call_instr
......@@ -2303,7 +2303,7 @@ ilxFCall env (CCall (DNCallSpec call_instr)) args ret_ty
(ty_args,tm_args) = splitTyArgs1 args
pushILArg env arg | isUnLiftedType (stgArgType arg) = pushArg env arg
| otherwise = pushArg env arg <+> error "call ilxFunAppArgs"
| otherwise = pushArg env arg <+> text "EVAL!"
hasTyCon (TyConApp tc _) tc2 = tc == tc2
hasTyCon _ _ = False
......
......@@ -59,7 +59,7 @@ module CmdLineOpts (
opt_Parallel,
opt_SMP,
opt_NoMonomorphismRestriction,
opt_KeepStgTypes,
opt_RuntimeTypes,
-- optimisation opts
opt_NoMethodSharing,
......@@ -515,7 +515,7 @@ opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
opt_KeepStgTypes = lookUp SLIT("-fkeep-stg-types")
opt_RuntimeTypes = lookUp SLIT("-fruntime-types")
-- Simplifier switches
opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining")
......
......@@ -31,7 +31,7 @@ import Maybes ( maybeToBool )
import Name ( getOccName, isExternallyVisibleName, isDllName )
import OccName ( occNameUserString )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
import FastTypes hiding ( fastOr )
import Outputable
......@@ -512,7 +512,7 @@ coreToStgApp maybe_thunk_body f args
-- e.g. (f :: a -> int) (x :: a)
-- Here the free variables are "f", "x" AND the type variable "a"
-- coreToStgArgs will deal with the arguments recursively
if opt_KeepStgTypes then
if opt_RuntimeTypes then
fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
else fvs
......@@ -579,7 +579,7 @@ coreToStgArgs []
coreToStgArgs (Type ty : args) -- Type argument
= coreToStgArgs args `thenLne` \ (args', fvs) ->
if opt_KeepStgTypes then
if opt_RuntimeTypes then
returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
else
returnLne (args', fvs)
......@@ -970,7 +970,7 @@ minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
minusFVBinders vs fv = foldr minusFVBinder fv vs
minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
minusFVBinder v fv | isId v && opt_KeepStgTypes
minusFVBinder v fv | isId v && opt_RuntimeTypes
= (fv `delVarEnv` v) `unionFVInfo`
tyvarFVInfo (tyVarsOfType (idType v))
| otherwise = fv `delVarEnv` v
......@@ -993,7 +993,7 @@ allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only
allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
-- Non-top-level things only, both type variables and ids (type variables
-- only if opt_KeepStgTypes.
-- only if opt_RuntimeTypes.
getFVs :: FreeVarsInfo -> [Var]
getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
......@@ -1009,7 +1009,7 @@ Misc.
\begin{code}
filterStgBinders :: [Var] -> [Var]
filterStgBinders bndrs
| opt_KeepStgTypes = bndrs
| opt_RuntimeTypes = bndrs
| otherwise = filter isId bndrs
\end{code}
......@@ -1121,7 +1121,7 @@ rhsIsNonUpd :: CoreExpr -> Bool
-- This function has to line up with what the update flag
-- for the StgRhs gets set to in mkStgRhs (above)
--
-- When opt_KeepStgTypes is on, we keep type lambdas and treat
-- When opt_RuntimeTypes is on, we keep type lambdas and treat
-- them as making the RHS re-entrant (non-updatable).
rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
rhsIsNonUpd (Note (SCC _) e) = False
......
......@@ -403,7 +403,7 @@ stgRhsArity :: StgRhs -> Int
stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) = count isId bndrs
-- The arity never includes type parameters, so
-- when keeping type arguments and binders in the Stg syntax
-- (opt_KeepStgTypes) we have to fliter out the type binders.
-- (opt_RuntimeTypes) we have to fliter out the type binders.
stgRhsArity (StgRhsCon _ _ _) = 0
\end{code}
......
......@@ -45,9 +45,10 @@ import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy,
isFFILabelTy
)
import Type ( Type )
import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget )
import ForeignCall ( CCallSpec(..), CExportSpec(..), CCallTarget(..), isDynamicTarget, isCasmTarget )
import CStrings ( CLabelString, isCLabelString )
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
import Outputable
\end{code}
......@@ -95,15 +96,17 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
------------ Checking types for foreign import ----------------------
\begin{code}
tcCheckFIType _ _ _ (DNImport _)
= returnNF_Tc () -- No error checking yet
= checkCg checkDotNet
tcCheckFIType sig_ty arg_tys res_ty (LblImport _)
= check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
= checkCg checkCOrAsm `thenNF_Tc_`
check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
= -- Foreign export dynamic
-- The first (and only!) arg has got to be a function type
-- and it must return IO t; result type is IO Addr
checkCg checkCOrAsm `thenNF_Tc_`
case arg_tys of
[arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenNF_Tc_`
checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenNF_Tc_`
......@@ -114,7 +117,8 @@ tcCheckFIType sig_ty arg_tys res_ty (CDynImport _)
tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
| isDynamicTarget target -- Foreign import dynamic
= case arg_tys of -- The first arg must be Addr
= checkCg checkCOrAsm `thenNF_Tc_`
case arg_tys of -- The first arg must be Addr
[] -> check False (illegalForeignTyErr empty sig_ty)
(arg1_ty:arg_tys) -> getDOptsTc `thenNF_Tc` \ dflags ->
check (isFFIDynArgumentTy arg1_ty)
......@@ -123,15 +127,21 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport (CCallSpec target _ safety))
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
| otherwise -- Normal foreign import
= getDOptsTc `thenNF_Tc` \ dflags ->
= checkCg (if isCasmTarget target
then checkC else checkCOrAsm) `thenNF_Tc_`
checkCTarget target `thenNF_Tc_`
getDOptsTc `thenNF_Tc` \ dflags ->
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenNF_Tc_`
checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget (StaticTarget str) | not (isCLabelString str) = addErrTc (badCName str)
checkCTarget other = returnNF_Tc ()
checkCTarget (StaticTarget str)
= checkCg checkCOrAsm `thenNF_Tc_`
check (isCLabelString str) (badCName str)
checkCTarget (CasmTarget _)
= checkCg checkC
\end{code}
......@@ -222,6 +232,24 @@ checkForeignRes non_io_result_ok pred_res_ty ty =
(illegalForeignTyErr result ty)
\end{code}
\begin{code}
checkDotNet HscILX = Nothing
checkDotNet other = Just (text "requires .NET code generation (-filx)")
checkC HscC = Nothing
checkC other = Just (text "requires C code generation (-fvia-C)")
checkCOrAsm HscC = Nothing
checkCOrAsm HscAsm = Nothing
checkCOrAsm other = Just (text "via-C or native code generation (-fvia-C)")
checkCg check
= getDOptsTc `thenNF_Tc` \ dflags ->
case check (dopt_HscLang dflags) of
Nothing -> returnNF_Tc ()
Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
Warnings
\begin{code}
......
......@@ -133,7 +133,10 @@ tcMatch :: [(Name,Id)]
-> TcM (TcMatch, LIE)
tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
= tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
= tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
returnTc (Match [] pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
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